Changeset 257


Ignore:
Timestamp:
2011-06-17T14:02:17+02:00 (13 years ago)
Author:
didier.solyga
Message:

Externalized version merged with the trunk

Location:
branches/ORCHIDEE_EXT/ORCHIDEE
Files:
59 edited

Legend:

Unmodified
Added
Removed

  • branches/ORCHIDEE_EXT/ORCHIDEE/AA_make

    r64 r257  
    1 #- $Id: AA_make,v 1.4 2007/09/20 13:32:32 ssipsl Exp $ 
    2 all : libparameters libparallel liborglob libstomate libsechiba 
     1#- $Id: AA_make 41 2011-01-01 19:56:53Z mmaipsl $ 
     2all : libparallel libparameters liborglob libstomate libsechiba 
    33 
    44libparameters : 

  • branches/ORCHIDEE_EXT/ORCHIDEE/AA_make.ldef

    r64 r257  
    1 #- $Id: AA_make.ldef,v 1.1 2007/06/21 09:11:58 ssipsl Exp $ 
     1#- $Id: AA_make.ldef 12 2010-11-05 15:42:13Z mmaipsl $ 
    22#--------------------------------------------------------------------- 
    33#- 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_global/AA_make

    r64 r257  
    11#- 
    2 #- $Id: AA_make,v 1.5 2010/04/06 14:26:07 ssipsl Exp $ 
     2#- $Id: AA_make 41 2011-01-01 19:56:53Z mmaipsl $ 
    33#- 
    44PARAM_LIB = $(LIBDIR)/libparameters.a 
    … …  
    2121#- 
    2222all: 
     23        $(M_K) libparallel 
    2324        $(M_K) libparameters 
    2425        $(M_K) m_all 
    … …  
    2627 
    2728m_all: $(MODEL_LIB)($(OBJSMODS1)) 
     29 
     30libparallel: 
     31        (cd ../src_parallel; $(M_K) -f Makefile) 
    2832 
    2933libparameters: 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_global/AA_make.ldef

    r64 r257  
    11#- 
    2 #- $Id: AA_make.ldef,v 1.2 2008/01/08 11:49:07 ssipsl Exp $ 
     2#- $Id: AA_make.ldef 12 2010-11-05 15:42:13Z mmaipsl $ 
    33#- 
    44#--------------------------------------------------------------------- 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_global/grid.f90

    r64 r257  
    44!! @call sechiba_main 
    55!! @Version : $Revision: 1.8 $, $Date: 2009/01/28 08:32:45 $ 
     6!! @Version : $Revision: 42 $, $Date: 2011-01-01 21:15:03 +0100 (Sat, 01 Jan 2011) $ 
    67!!  
    78!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_global/grid.f90,v 1.8 2009/01/28 08:32:45 ssipsl Exp $ 
     9!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_global/grid.f90 $ 
     10!< $Date: 2011-01-01 21:15:03 +0100 (Sat, 01 Jan 2011) $ 
     11!< $Author: mmaipsl $ 
     12!< $Revision: 42 $ 
    813!! 
    914!! @author Marie-Alice Foujols, Jan Polcher and Martial Mancip 
    … …  
    2328  ! default resolution (m) 
    2429  REAL(r_std), PARAMETER :: default_resolution = 250000. 
    25   ! 
    2630  ! 
    2731  ! VARIABLES 
    … …  
    189193    ! ========================================================================= 
    190194     
    191  
    192  
    193195    IF ( bavard .GE. 4 ) WRITE(numout,*) 'Entering grid_stuff' 
    194196 
    … …  
    239241       ! initialize output 
    240242       neighbours_g(:,:) = -1 
    241        resolution_g(:,:) = 0. 
     243       resolution_g(:,:) = zero 
    242244       min_resol(:) = 1.e6 
    243        max_resol(:) = -1. 
     245       max_resol(:) = moins_un 
    244246        
    245247       correspondance(:,:) = -1 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_global/interpol_help.f90

    r64 r257  
    88! 
    99!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_global/interpol_help.f90,v 1.7 2010/04/06 14:30:23 ssipsl Exp $ 
     10! 
     11!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_global/interpol_help.f90 $ 
     12!< $Date: 2011-01-01 20:56:53 +0100 (Sat, 01 Jan 2011) $ 
     13!< $Author: mmaipsl $ 
     14!< $Revision: 41 $ 
    1015! 
    1116! 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_global/solar.f90

    r64 r257  
    33!! @call sechiba_main 
    44!! @Version : $Revision: 1.1 $, $Date: 2010/04/06 14:26:07 $ 
     5!! @Version : $Revision: 42 $, $Date: 2011-01-01 21:15:03 +0100 (Sat, 01 Jan 2011) $ 
    56!!  
    67!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_global/solar.f90,v 1.1 2010/04/06 14:26:07 ssipsl Exp $ 
     8! 
     9!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_global/solar.f90 $ 
     10!< $Date: 2011-01-01 21:15:03 +0100 (Sat, 01 Jan 2011) $ 
     11!< $Author: mmaipsl $ 
     12!< $Revision: 42 $ 
    713!! 
    814!! @author Marie-Alice Foujols, Jan Polcher and Martial Mancip 
    … …  
    5460    !--------------------------------------------------------------------- 
    5561    ! 
    56 !    pi = 4.*ATAN(1.) 
    5762    IF (check) WRITE(numout,*) 'We get the right calendar information' 
    5863    !- 
    … …  
    132137          llat  = llatd*pi/180. 
    133138          csang(ilon,ilat) = & 
    134                &  MAX(0.,SIN(dec)*SIN(llat)+COS(dec)*COS(llat)*COS(omega)) 
     139               &  MAX(zero,SIN(dec)*SIN(llat)+COS(dec)*COS(llat)*COS(omega)) 
    135140       ENDDO 
    136141    ENDDO 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parallel/AA_make

    r64 r257  
    11#- 
    2 #- $Id: AA_make,v 1.6 2010/04/06 14:34:32 ssipsl Exp $ 
     2#- $Id: AA_make 41 2011-01-01 19:56:53Z mmaipsl $ 
    33#- 
    4 MODS1 = timer.f90 \ 
    5         data_para.f90 \ 
     4MODS1 = data_para.f90 \ 
     5        timer.f90 \ 
    66        transfert_para.f90 \ 
    77        ioipsl_para.f90 \ 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parallel/AA_make.ldef

    r64 r257  
    11#- 
    2 #- $Id: AA_make.ldef,v 1.3 2008/01/08 11:49:07 ssipsl Exp $ 
     2#- $Id: AA_make.ldef 12 2010-11-05 15:42:13Z mmaipsl $ 
    33#- 
    44#--------------------------------------------------------------------- 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parallel/data_para.f90

    r64 r257  
    1111!- 
    1212  USE defprec 
    13   USE constantes 
    1413  USE ioipsl 
    1514!- 
    1615#include "src_parallel.h" 
    1716!- 
     17!- 
     18! Unit for output messages 
     19  INTEGER(i_std), SAVE :: numout = 6 
     20 
    1821  INTEGER, SAVE :: mpi_size                                           !! Number of parallel processes 
    1922  INTEGER, SAVE :: mpi_rank                                           !! my rank num 
    … …  
    203206  
    204207  SUBROUTINE init_data_para(iim,jjm,nbpoints,index_x) 
    205     USE constantes 
     208 
    206209    IMPLICIT NONE 
    207210#ifdef CPP_PARA 
    … …  
    457460  SUBROUTINE Write_Load_balance(times) 
    458461    IMPLICIT NONE 
    459     REAL,INTENT(IN) :: times 
     462    REAL(r_std),INTENT(IN) :: times 
    460463   
    461464#ifdef CPP_PARA   

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parallel/ioipsl_para.f90

    r64 r257  
    99  USE data_para 
    1010  USE transfert_para 
    11   USE constantes 
    1211!- 
    1312  IMPLICIT NONE 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parallel/orch_write_field.f90

    r64 r257  
    77module orch_Write_Field 
    88   
    9   USE constantes 
     9  USE data_para 
    1010 
    1111  IMPLICIT NONE 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parallel/timer.f90

    r64 r257  
    77MODULE timer 
    88 
    9   USE constantes 
     9  USE data_para 
    1010   
    1111  INTEGER, PARAMETER :: nb_timer=2 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parallel/tools_para.f90

    r64 r257  
    1111  USE timer 
    1212  USE data_para 
    13   USE constantes 
    1413!- 
    1514#include "src_parallel.h" 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parallel/transfert_para.f90

    r64 r257  
    99  USE data_para 
    1010  USE timer 
    11   USE constantes 
    1211!- 
    1312  IMPLICIT NONE 
    … …  
    552551    USE data_para 
    553552    USE timer 
    554     USE constantes 
    555553 
    556554    IMPLICIT NONE 
    … …  
    599597    USE data_para 
    600598    USE timer 
    601     USE constantes 
    602599 
    603600    IMPLICIT NONE 
    … …  
    647644    USE data_para 
    648645    USE timer 
    649     USE constantes 
    650646 
    651647    IMPLICIT NONE 
    … …  
    19531949    USE data_para 
    19541950    USE timer 
    1955     USE constantes 
    19561951 
    19571952    IMPLICIT NONE 
    … …  
    19851980    USE data_para 
    19861981    USE timer 
    1987     USE constantes 
    19881982 
    19891983    IMPLICIT NONE 
    … …  
    20182012    USE data_para 
    20192013    USE timer 
    2020     USE constantes 
    20212014 
    20222015    IMPLICIT NONE 
    … …  
    20502043    USE data_para 
    20512044    USE timer 
    2052     USE constantes 
    20532045 
    20542046    IMPLICIT NONE 
    … …  
    20842076    USE data_para 
    20852077    USE timer 
    2086     USE constantes 
    20872078 
    20882079    IMPLICIT NONE 
    … …  
    21392130    USE data_para 
    21402131    USE timer 
    2141     USE constantes 
    21422132 
    21432133    IMPLICIT NONE 
    … …  
    21952185    USE data_para 
    21962186    USE timer 
    2197     USE constantes 
    21982187 
    21992188    IMPLICIT NONE 
    … …  
    22502239    USE data_para 
    22512240    USE timer 
    2252     USE constantes 
    22532241 
    22542242    IMPLICIT NONE 
    … …  
    23192307    USE data_para 
    23202308    USE timer 
    2321     USE constantes 
    23222309 
    23232310    IMPLICIT NONE 
    … …  
    23872374    USE data_para 
    23882375    USE timer 
    2389     USE constantes 
    23902376 
    23912377    IMPLICIT NONE 
    … …  
    24562442    USE data_para, iim=>iim_g,jjm=>jjm_g 
    24572443    USE timer 
    2458     USE constantes 
    24592444 
    24602445    IMPLICIT NONE 
    … …  
    25212506    USE data_para, iim=>iim_g,jjm=>jjm_g 
    25222507    USE timer 
    2523     USE constantes 
    25242508 
    25252509    IMPLICIT NONE 
    … …  
    25902574    USE data_para, iim=>iim_g,jjm=>jjm_g 
    25912575    USE timer 
    2592     USE constantes 
    25932576 
    25942577    IMPLICIT NONE 
    … …  
    26552638    USE data_para, iim=>iim_g,jjm=>jjm_g 
    26562639    USE timer 
    2657     USE constantes 
    26582640 
    26592641    IMPLICIT NONE 
    … …  
    27332715    USE data_para, iim=>iim_g,jjm=>jjm_g 
    27342716    USE timer 
    2735     USE constantes 
    27362717 
    27372718    IMPLICIT NONE 
    … …  
    28102791    USE data_para, iim=>iim_g,jjm=>jjm_g 
    28112792    USE timer 
    2812     USE constantes 
    28132793 
    28142794    IMPLICIT NONE 
    … …  
    28872867    USE data_para 
    28882868    USE timer 
    2889     USE constantes 
    28902869 
    28912870    IMPLICIT NONE 
    … …  
    29222901    USE data_para 
    29232902    USE timer 
    2924     USE constantes 
    29252903 
    29262904    IMPLICIT NONE 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parameters/AA_make

    r64 r257  
    11#- 
    2 #- $Id: AA_make,v 1.17 2010/04/06 14:34:32 ssipsl Exp $ 
     2#- $Id: AA_make 41 2011-01-01 19:56:53Z mmaipsl $ 
    33#- 
    44IOIPSL_LIB = $(LIBDIR)/libioipsl.a 
    … …  
    88#-Q- eshpux SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a 
    99#-Q- sx8brodie SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a 
     10#- 
     11PARALLEL_LIB = $(LIBDIR)/libparallel.a 
     12SXPARALLEL_LIB = $(PARALLEL_LIB) 
     13#-Q- sxnec  SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     14#-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     15#-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     16#-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    1017#- 
    1118MODS1 = constantes.f90 \ 
    … …  
    2330all: 
    2431        $(M_K) libioipsl 
     32        $(M_K) libparallel 
    2533        $(M_K) m_all 
    2634        @echo parameter is OK 
    … …  
    3038libioipsl: 
    3139        (cd ../../IOIPSL/src; $(M_K) -f Makefile) 
     40 
     41libparallel: 
     42        (cd ../src_parallel; $(M_K) -f Makefile) 
    3243 
    3344$(MODEL_LIB)(%.o): %.f90 
    … …  
    5768  $(MODEL_LIB)(constantes_mtc.o) 
    5869$(MODEL_LIB)(constantes.o): \ 
     70  $(PARALLEL_LIB) \ 
    5971  $(IOIPSL_LIB) 
    6072 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parameters/AA_make.ldef

    r64 r257  
    11#- 
    2 #- $Id: AA_make.ldef,v 1.7 2008/01/08 11:49:07 ssipsl Exp $ 
     2#- $Id: AA_make.ldef 12 2010-11-05 15:42:13Z mmaipsl $ 
    33#- 
    44#--------------------------------------------------------------------- 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parameters/constantes.f90

    r251 r257  
    88!!-------------------------------------------------------------------- 
    99  USE defprec 
    10   USE ioipsl 
     10  USE parallel 
    1111!- 
    1212  IMPLICIT NONE 
    … …  
    2121  !---------------- 
    2222 
    23   ! Unit for output messages 
    24   INTEGER(i_std), SAVE :: numout = 6 
    2523  !- 
    2624  ! To set for more printing 
    … …  
    185183  INTEGER(i_std),PARAMETER :: ipassive = 3 
    186184  INTEGER(i_std),PARAMETER :: ncarb = 3 
     185  ! 
     186  ! transformation between types of surface (DS : not used in the code?) 
     187  INTEGER(i_std),PARAMETER :: ito_natagri = 1 
     188  INTEGER(i_std),PARAMETER :: ito_total = 2 
     189 
    187190 
    188191 
    … …  
    197200  REAL(r_std), PARAMETER :: pi = 4.*ATAN(1.) 
    198201  ! e 
    199   REAL(r_std),PARAMETER :: euler = 2.71828182846 
     202  REAL(r_std),PARAMETER :: euler = 2.71828182846 !or euler = EXP(1.) 
    200203  !- 
    201204  ! Integer constant set to zero 
    … …  
    230233  ! 
    231234  ! radius of the Earth (m) 
     235  ! comment : 
     236  ! Earth radius ~= Equatorial radius 
     237  ! 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. 
     238  ! The equatorial radius is often used to compare Earth with other planets. 
    232239  REAL(r_std), PARAMETER :: R_Earth = 6378000. 
     240  !The meridional mean is well approximated by the semicubic mean of the two axe yielding 6367.4491 km 
     241  ! or less accurately by the quadratic mean of the two axes about 6,367.454 km 
     242  ! or even just the mean of the two axes about 6,367.445 km. 
     243  !- 
    233244  ! standard pressure 
    234245  REAL(r_std), PARAMETER :: pb_std = 1013.  
    … …  
    333344 
    334345 
    335 !----------------------------------------------- 
    336 !---------------------------------------------- 
    337 ! SCALAR PARAMETERS EXTERNALIZED 
    338 !---------------------------------------------- 
    339 !----------------------------------------------- 
    340 !------------------------------------------ 
    341 !  SECHIBA, SOIL AND VEGETATION parameters 
    342 !----------------------------------------- 
    343  
    344   !!--------------------------------------- 
    345   !! Parameters for soil type distribution 
    346   !!--------------------------------------- 
    347   ! 
    348   ! Default soil texture distribution in the following order : 
    349   !    sand, loam and clay 
    350   REAL(r_std),SAVE, DIMENSION(nstm) :: soiltype_default = (/ 0.0, 1.0, 0.0 /) 
    351  
    352   !!---------------------------------------- 
    353   !! Constantes from the Choisnel hydrology 
    354   !!---------------------------------------- 
     346 
     347                           !------------------------! 
     348                           !  SECHIBA PARAMETERS    ! 
     349                           !------------------------! 
     350 
     351! DS Maybe should I move these constants in the modules they belong 
     352!- 
     353! Specific parameters for the CWRR hydrology module 
     354!- 
     355! 
     356! CWRR linearisation 
     357INTEGER(i_std),PARAMETER :: imin = 1 
     358! number of interval for CWRR 
     359INTEGER(i_std),PARAMETER :: nbint = 100 
     360! number of points for CWRR 
     361INTEGER(i_std),PARAMETER :: imax = nbint+1 
     362 
     363!- 
     364! diffuco 
     365!- 
     366REAL(r_std),PARAMETER :: Tetens_1 = 0.622    
     367REAL(r_std),PARAMETER :: Tetens_2 = 0.378 
     368REAL(r_std),PARAMETER :: std_ci_frac = 0.667 
     369REAL(r_std),PARAMETER :: alpha_j = 0.8855 
     370REAL(r_std),PARAMETER :: curve_assim = 0.7 
     371REAL(r_std),PARAMETER :: WJ_coeff1 = 4.5 
     372REAL(r_std),PARAMETER :: WJ_coeff2 = 10.5 
     373REAL(r_std),PARAMETER :: Vc_to_Rd_ratio = 0.011 
     374REAL(r_std),PARAMETER :: O2toCO2_stoechio = 1.6 
     375REAL(r_std),PARAMETER :: mmol_to_m_1 = 0.0244 
     376REAL(r_std),PARAMETER  :: RG_to_PAR = 0.5  
     377REAL(r_std),PARAMETER  :: W_to_mmol = 4.6 ! W_to_mmol * RG_to_PAR = 2.3 
     378 
     379 
     380 
     381                               !-----------! 
     382                               ! Global    ! 
     383                               !-----------! 
     384  ! The minimum wind 
     385  REAL(r_std),SAVE :: min_wind = 0.1 
     386  ! Sets the amount above which only sublimation occures [Kg/m^2] 
     387  REAL(r_std),SAVE :: snowcri=1.5 
     388  ! Transforms leaf area index into size of interception reservoir 
     389  REAL(r_std),SAVE      :: qsintcst = 0.1 
     390  ! Total depth of soil reservoir (for hydrolc) 
     391  REAL(r_std),SAVE :: dpu_cste =  deux 
     392  ! Total depth of soil reservoir (m) 
     393  REAL(r_std),SAVE,DIMENSION(nstm) :: dpu =  (/ 2.0_r_std, 2.0_r_std, 2.0_r_std /) 
     394 
     395  ! FLAGS 
     396 
     397  ! allow agricultural PFTs 
     398  LOGICAL,SAVE :: agriculture = .TRUE. !(read in slowproc) 
     399  ! Do we treat PFT expansion across a grid point after introduction? 
     400  ! default = .FALSE. 
     401  LOGICAL,SAVE :: treat_expansion = .FALSE. 
     402  ! herbivores? 
     403  LOGICAL,SAVE :: ok_herbivores = .FALSE. 
     404  ! harvesting ? 
     405  LOGICAL,SAVE :: harvest_agri = .TRUE. 
     406  ! constant moratlity 
     407  LOGICAL,SAVE :: lpj_gap_const_mort=.TRUE. 
     408 
     409  ! Parameters used by both hydrology models 
     410 
     411  ! Maximum period of snow aging 
     412  REAL(r_std),SAVE :: max_snow_age = 50._r_std 
     413  ! Transformation time constant for snow (m) 
     414  REAL(r_std),SAVE :: snow_trans = 0.3_r_std 
     415  ! Lower limit of snow amount 
     416  REAL(r_std),SAVE :: sneige 
     417  ! The maximum mass (kg/m^2) of a glacier. 
     418  REAL(r_std),SAVE :: maxmass_glacier = 3000. 
     419  ! Maximum quantity of water (Kg/M3) 
     420  REAL(r_std),SAVE :: mx_eau_eau = 150. 
     421 
     422  ! UNKNOW 
     423 
     424  ! Is veget_ori array stored in restart file 
     425!!$! DS: Where is it used ? 
     426  !  LOGICAL,PARAMETER :: ldveget_ori_on_restart = .TRUE. 
     427  !- 
     428!!$! DS not used in the code ?  
     429  ! Limit of air temperature for snow 
     430  REAL(r_std),SAVE :: tsnow=273. 
     431 
     432 
     433 
     434 
     435                               !-------------! 
     436                               ! condveg.f90 ! 
     437                               !-------------! 
     438 
     439  ! 1. Scalar 
     440 
     441  ! to get z0 from height 
     442  REAL(r_std), SAVE  :: z0_over_height = un/16. 
     443  ! Magic number which relates the height to the displacement height. 
     444  REAL(r_std), SAVE  :: height_displacement = 0.75 
     445  ! bare soil roughness length (m) 
     446  REAL(r_std),SAVE :: z0_bare = 0.01 
     447  ! ice roughness length (m) 
     448  REAL(r_std),SAVE :: z0_ice = 0.001 
     449  ! Time constant of the albedo decay of snow 
     450  REAL(r_std),SAVE :: tcst_snowa = 5.0 
     451  ! Critical value for computation of snow albedo [Kg/m^2] 
     452  REAL(r_std),SAVE :: snowcri_alb=10. 
     453 
     454  ! 2. Arrays 
     455 
     456  ! albedo of dead leaves, VIS+NIR 
     457  REAL(r_std),DIMENSION(2),SAVE :: alb_deadleaf = (/ .12, .35/) 
     458  ! albedo of ice, VIS+NIR 
     459  REAL(r_std),DIMENSION(2),SAVE :: alb_ice = (/ .60, .20/) 
     460  !   The correspondance table for the soil color numbers and their albedo 
     461  ! 
     462  REAL(r_std), DIMENSION(classnb) :: vis_dry = (/0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.27/) 
     463  REAL(r_std), DIMENSION(classnb) :: nir_dry = (/0.48, 0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20, 0.55/)   
     464  REAL(r_std), DIMENSION(classnb) :: vis_wet = (/0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.15/)   
     465  REAL(r_std), DIMENSION(classnb) :: nir_wet = (/0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.31/) 
     466  !    
     467  ! Nathalie, introduction d'un albedo moyen, VIS+NIR 
     468  ! Les valeurs suivantes correspondent a la moyenne des valeurs initiales 
     469  !  REAL(stnd), DIMENSION(classnb) :: albsoil_vis = (/0.18, 0.165, 0.15, 0.135, 0.12, 0.105, 0.09, 0.075, 0.21/) 
     470  !  REAL(stnd), DIMENSION(classnb) :: albsoil_nir = (/0.36, 0.33, 0.30, 0.27, 0.24, 0.21, 0.18, 0.15, 0.43/) 
     471  ! les valeurs retenues accentuent le contraste entre equateur et Sahara.  
     472  ! On diminue aussi l'albedo des deserts (tous sauf Sahara) 
     473  REAL(r_std), DIMENSION(classnb) :: albsoil_vis = (/0.18, 0.16, 0.16, 0.15, 0.12, 0.105, 0.09, 0.075, 0.25/) 
     474  REAL(r_std), DIMENSION(classnb) :: albsoil_nir = (/0.36, 0.34, 0.34, 0.33, 0.30, 0.25, 0.20, 0.15, 0.45/)  
     475 
     476 
     477                               !-------------! 
     478                               ! diffuco.f90 ! 
     479                               !-------------! 
     480 
     481  ! 1. Scalar 
     482 
     483  INTEGER(i_std), SAVE        :: nlai = 20 ! dimension de tableau 
     484  ! used in diffuco_trans 
     485  REAL(r_std), SAVE                :: laimax = 12. 
     486  REAL(r_std), SAVE                :: xc4_1 = .83 
     487  REAL(r_std), SAVE                :: xc4_2 = .93 
     488  ! Set to .TRUE. if you want q_cdrag coming from GCM 
     489  LOGICAL,SAVE :: ldq_cdrag_from_gcm = .FALSE. 
     490 
     491  ! 2; Arrays 
     492 
     493  ! 3. Coefficients of equations 
     494 
     495  REAL(r_std), SAVE      :: lai_level_depth = .15 
     496  REAL(r_std), SAVE      :: x1_coef =  0.177 
     497  REAL(r_std), SAVE      :: x1_Q10 =  0.069 
     498  REAL(r_std), SAVE      :: quantum_yield =  0.092 
     499  REAL(r_std), SAVE      :: kt_coef = 0.7      
     500  REAL(r_std), SAVE      :: kc_coef = 39.09 
     501  REAL(r_std), SAVE      :: Ko_Q10 = .085 
     502  REAL(r_std), SAVE      :: Oa = 210000. 
     503  REAL(r_std), SAVE      :: Ko_coef =  2.412 
     504  REAL(r_std), SAVE      :: CP_0 = 42. 
     505  REAL(r_std), SAVE      :: CP_temp_coef = 9.46  
     506  REAL(r_std), SAVE      :: CP_temp_ref = 25. 
     507  ! 
     508  REAL(r_std), SAVE, DIMENSION(2)  :: rt_coef = (/ 0.8, 1.3 /)  
     509  REAL(r_std), SAVE, DIMENSION(2)  :: vc_coef = (/ 0.39, 0.3 /) 
     510  ! 
     511  ! coefficients of the polynome of degree 5 used inthe equation of coeff_dew_veg 
     512  REAL(r_std), SAVE, DIMENSION(6)     :: dew_veg_poly_coeff = & 
     513  & (/ 0.887773, 0.205673, 0.110112, 0.014843,  0.000824,  0.000017 /)  
     514 
     515 
     516 
     517                              !-------------! 
     518                              ! hydrolc.f90 ! 
     519                              !-------------! 
     520 
     521  ! 1. Scalar 
     522 
    355523  ! 
    356524  ! Wilting point (Has a numerical role for the moment) 
    357525  REAL(r_std),SAVE :: qwilt = 5.0 
    358   ! Total depth of soil reservoir (for hydrolc) 
    359   REAL(r_std),SAVE :: dpu_cste =  deux 
    360526  ! The minimal size we allow for the upper reservoir (m) 
    361527  REAL(r_std),SAVE :: min_resdis = 2.e-5 
    … …  
    369535  REAL(r_std),SAVE :: exp_drain = 1.5 
    370536  !- 
    371   ! Transforms leaf area index into size of interception reservoir 
    372   REAL(r_std),SAVE      :: qsintcst = 0.1 
    373   ! Maximum quantity of water (Kg/M3) 
    374   REAL(r_std),SAVE :: mx_eau_eau = 150. 
    375   !- 
    376537  ! Constant in the computation of resistance for bare  soil evaporation 
    377538  REAL(r_std),SAVE :: rsol_cste = 33.E3 
    … …  
    380541  REAL(r_std),SAVE :: hcrit_litter=0.08_r_std 
    381542 
    382   !!--------------------------------------------------- 
    383   !! Specific parameters for the CWRR hydrology module 
    384   !!---------------------------------------------------  
    385   ! 
    386 !!$ DS To externalise ?  
    387 !!$ advice of MM : to put in hydrol 
    388   ! CWRR linearisation 
    389   INTEGER(i_std),PARAMETER :: imin = 1 
    390   ! number of interval for CWRR 
    391   INTEGER(i_std),PARAMETER :: nbint = 100 
    392   ! number of points for CWRR 
    393   INTEGER(i_std),PARAMETER :: imax = nbint+1 
     543 
     544 
     545 
     546                              !-------------! 
     547                              ! hydrol.f90  ! 
     548                              !-------------! 
     549 
     550 
     551  ! 1. Scalar 
     552 
     553  ! Allowed moisture above mcs (boundary conditions) 
     554  REAL(r_std), SAVE                :: dmcs = 0.002      
     555  ! Allowed moisture below mcr (boundary conditions) 
     556  REAL(r_std), SAVE                :: dmcr = 0.002   
     557 
     558  ! 2. Arrays 
     559  
    394560  !- 
    395561  ! externalise w_time (some bug in hydrol) 
    … …  
    406572  ! Saturated soil water content 
    407573  REAL(r_std),SAVE,DIMENSION(nstm) :: mcs = (/ 0.41_r_std, 0.43_r_std, 0.41_r_std /) 
    408   ! Total depth of soil reservoir (m) 
    409   REAL(r_std),SAVE,DIMENSION(nstm) :: dpu =  (/ 2.0_r_std, 2.0_r_std, 2.0_r_std /) 
    410574  !- 
    411575  ! dpu must be constant over the different soil types 
    … …  
    427591 
    428592 
    429   !!----------------------------------------------------- 
    430   !! Vegetation parameters (previously in constantes_veg) 
    431   !!-----------------------------------------------------  
    432   ! 
    433   ! Value for frac_nobio for tests in 0-dim simulations 
     593   
     594                              !-------------! 
     595                              ! routing.f90 ! 
     596                              !-------------! 
     597 
     598  ! 1. Scalar 
     599 
     600  ! Parameter for the Kassel irrigation parametrization linked to the crops 
     601  REAL(r_std), SAVE          :: crop_coef = 1.5 
     602 
     603 
     604 
     605                              !--------------! 
     606                              ! slowproc.f90 ! 
     607                              !--------------! 
     608 
     609 
     610  ! 1. Scalar 
     611 
     612  REAL(r_std), SAVE          :: clayfraction_default = 0.2 
     613  ! Minimal fraction of mesh a vegetation type can occupy 
     614  REAL(r_std),SAVE :: min_vegfrac=0.001 
     615 ! Value for frac_nobio for tests in 0-dim simulations 
    434616  ! laisser ca tant qu'il n'y a que de la glace (pas de lacs) 
    435617  !DS : used in slowproc 
    436618  REAL(r_std),SAVE :: frac_nobio_fixed_test_1 = 0.0 
    437   !- 
    438   ! Is veget_ori array stored in restart file 
    439 !!$ DS: Where is it used ? 
    440   !  LOGICAL,PARAMETER :: ldveget_ori_on_restart = .TRUE. 
    441   !- 
    442   ! Set to .TRUE. if you want q_cdrag coming from GCM 
    443   ! used in diffuco 
    444   LOGICAL,SAVE :: ldq_cdrag_from_gcm = .FALSE. 
    445   !- 
    446   ! allow agricultural PFTs 
    447   LOGICAL,SAVE :: agriculture = .TRUE. 
    448   !- 
    449   ! The maximum mass (kg/m^2) of a glacier. 
    450   REAL(r_std),SAVE :: maxmass_glacier = 3000. 
    451   !- 
    452   ! Minimal fraction of mesh a vegetation type can occupy 
    453   REAL(r_std),SAVE :: min_vegfrac=0.001 
    454   !- 
    455 !!$ DS not used in the code ?  
    456   ! Limit of air temperature for snow 
    457   REAL(r_std),SAVE :: tsnow=273. 
    458   !- 
    459   ! Sets the amount above which only sublimation occures [Kg/m^2] 
    460   REAL(r_std),SAVE :: snowcri=1.5 
    461   ! Critical value for computation of snow albedo [Kg/m^2] 
    462   REAL(r_std),SAVE :: snowcri_alb=10. 
    463   ! Lower limit of snow amount 
    464   REAL(r_std),SAVE :: sneige 
    465   !- 
    466   ! The minimum wind 
    467   REAL(r_std),SAVE :: min_wind = 0.1 
    468   ! bare soil roughness length (m) 
    469   REAL(r_std),SAVE :: z0_bare = 0.01 
    470   ! ice roughness length (m) 
    471   REAL(r_std),SAVE :: z0_ice = 0.001 
    472   !- 
    473   ! Time constant of the albedo decay of snow 
    474   REAL(r_std),SAVE :: tcst_snowa = cinq 
    475   ! Maximum period of snow aging 
    476   REAL(r_std),SAVE :: max_snow_age = 50._r_std 
    477   ! Transformation time constant for snow (m) 
    478   REAL(r_std),SAVE :: snow_trans = 0.3_r_std 
    479   !- 
    480   ! albedo of dead leaves, VIS+NIR 
    481   REAL(r_std),DIMENSION(2),SAVE :: alb_deadleaf = (/ .12, .35/) 
    482   ! albedo of ice, VIS+NIR 
    483   REAL(r_std),DIMENSION(2),SAVE :: alb_ice = (/ .60, .20/) 
    484  
    485   !!-------------------------------- 
    486   !!  SECHIBA specific parameters 
    487   !!-------------------------------- 
    488   ! 
    489   !- 
    490   ! condveg 
     619 
     620  ! 2. Arrays 
     621 
     622  ! Default soil texture distribution in the following order : 
     623  !    sand, loam and clay 
     624  REAL(r_std),SAVE, DIMENSION(nstm) :: soiltype_default = (/ 0.0, 1.0, 0.0 /) 
     625 
     626 
     627 
     628 
     629                           !-----------------------------! 
     630                           !  STOMATE AND LPJ PARAMETERS ! 
     631                           !-----------------------------! 
     632 
     633  !- 
     634  ! stomate_alloc 
    491635  !-  
    492   ! to get z0 from height 
    493   REAL(r_std), SAVE  :: z0_over_height = un/16. 
    494   ! Magic number which relates the height to the displacement height. 
    495   REAL(r_std), SAVE  :: height_displacement = 0.75 
    496   !- 
    497   ! diffuco 
    498   !- 
    499   INTEGER(i_std), SAVE        :: nlai = 20 ! dimension de tableau 
    500   ! used in diffuco_trans 
    501   REAL(r_std), SAVE                :: laimax = 12. 
    502   REAL(r_std), SAVE                :: xc4_1 = .83 
    503   REAL(r_std), SAVE                :: xc4_2 = .93 
    504   !- 
    505   ! hydrol. 
    506   !- 
    507   ! Allowed moisture above mcs (boundary conditions) 
    508   REAL(r_std), SAVE                :: dmcs = 0.002      
    509   ! Allowed moisture below mcr (boundary conditions) 
    510   REAL(r_std), SAVE                :: dmcr = 0.002   
    511   !- 
    512   ! routing 
    513   !-  
    514   ! Parameter for the Kassel irrigation parametrization linked to the crops 
    515   REAL(r_std), SAVE          :: crop_coef = 1.5 
    516   !- 
    517   ! slowproc 
    518   !-  
    519   REAL(r_std), SAVE          :: clayfraction_default = 0.2 
     636  REAL(r_std), PARAMETER  ::  max_possible_lai = 10.  
     637  REAL(r_std), PARAMETER  ::  Nlim_Q10 = 10.  
     638  !- 
     639  ! stomate_litter 
     640  !- 
     641  REAL(r_std), PARAMETER    :: Q10 = 10. 
     642  ! 
     643 
     644! DS 31/03/2011 test new organization 
     645! List of Externalized Parameters by modules 
     646 
     647 
     648                              !----------------------! 
     649                              ! lpj_constraints.f90  ! 
     650                              !----------------------! 
     651 
    520652   
    521 !----------------------------- 
    522 !  STOMATE AND LPJ PARAMETERS 
    523 !----------------------------- 
    524   ! 
    525   !- 
    526   ! lpj_constraints 
    527   !- 
     653  ! 1. Scalar 
     654 
    528655  ! longest sustainable time without regeneration (vernalization) 
    529656  REAL(r_std), SAVE  :: too_long = 5. 
    530   ! 
    531   !- 
    532   ! lpj_fire 
    533   !- 
     657 
     658 
     659                              !--------------------! 
     660                              ! lpj_establish.f90  ! 
     661                              !--------------------! 
     662 
     663  ! 1. Scalar 
     664  ! Maximum tree establishment rate 
     665  REAL(r_std),SAVE :: estab_max_tree = 0.12 
     666  ! Maximum grass establishment rate 
     667  REAL(r_std),SAVE :: estab_max_grass = 0.12  
     668   
     669  ! 3. Coefficients of equations 
     670 
     671  REAL(r_std), SAVE      :: establish_scal_fact = 15. 
     672  REAL(r_std), SAVE      :: fpc_crit_max = .075 
     673  REAL(r_std), SAVE      :: fpc_crit_min= .05  
     674 
     675 
     676                              !---------------! 
     677                              ! lpj_fire.f90  ! 
     678                              !---------------! 
     679 
     680  ! 1. Scalar 
     681 
    534682  ! Time scale for memory of the fire index (days). Validated for one year in the DGVM. 
    535683  REAL(r_std), SAVE  :: tau_fire = 30.  
    536684  ! Critical litter quantity for fire 
    537685  REAL(r_std), SAVE  :: litter_crit = 200. 
    538   ! 
    539   !- 
    540   ! lpj_light 
    541   !- 
     686 
     687  ! 2. Arrays 
     688 
     689  ! What fraction of a burned plant compartment goes into the atmosphere 
     690  !   (rest into litter) 
     691  REAL(r_std), SAVE, DIMENSION(nparts) :: co2frac = (/ .95, .95, 0., 0.3, 0., 0., .95, .95 /) 
     692 
     693 
     694  ! 3. Coefficients of equations 
     695 
     696  REAL(r_std), SAVE, DIMENSION(3) :: bcfrac_coeff = (/ .3,  1.3,  88.2 /)  
     697  REAL(r_std), SAVE, DIMENSION(4)  :: firefrac_coeff = (/ 0.45, 0.8, 0.6, 0.13 /) 
     698 
     699 
     700                              !--------------! 
     701                              ! lpj_gap.f90  ! 
     702                              !--------------! 
     703 
     704  ! 1. Scalar 
     705! DS 15/06/2011 : the name of the parameter constant_mortality was replaced by its keyword   
     706!!$  ! which kind of mortality 
     707!!$  LOGICAL, SAVE          :: constant_mortality = .TRUE. 
     708 
     709  ! 3. Coefficients of equations 
     710 
     711  REAL(r_std), SAVE      ::  availability_fact = 0.02 
     712  REAL(r_std), SAVE      ::  vigour_ref = 0.17 
     713  REAL(r_std), SAVE      ::  vigour_coeff = 70. 
     714 
     715 
     716                              !----------------! 
     717                              ! lpj_light.f90  ! 
     718                              !----------------! 
     719 
     720  ! 1. Scalar 
     721   
    542722  ! maximum total number of grass individuals in a closed canopy 
    543723  REAL(r_std), SAVE  :: grass_mercy = 0.01 
    … …  
    547727  ! to fpc of last time step (F)? 
    548728  LOGICAL, SAVE     :: annual_increase = .TRUE. 
    549   ! 
    550   !- 
    551   ! lpj_pftinout 
    552   !- 
     729  ! For trees, minimum fraction of crown area occupied 
     730  ! (due to its branches etc.) 
     731  ! This means that only a small fraction of its crown area 
     732  ! can be invaded by other trees. 
     733  REAL(r_std),SAVE :: min_cover = 0.05   
     734 
     735 
     736                              !------------------! 
     737                              ! lpj_pftinout.f90 ! 
     738                              !------------------! 
     739 
     740  ! 1. Scalar 
     741 
    553742  ! minimum availability 
    554743  REAL(r_std), SAVE  :: min_avail = 0.01 
    555   ! 
    556   !- 
    557   ! stomate_alloc 
    558   !- 
     744  ! initial density of individuals 
     745  REAL(r_std),SAVE :: ind_0 = 0.02 
     746 
     747  ! 2. Arrays 
     748 
     749  ! 3. Coefficients of equations 
     750   
     751  REAL(r_std), SAVE      :: RIP_time_min = 1.25 
     752  REAL(r_std), SAVE      :: npp_longterm_init = 10.  
     753  REAL(r_std), SAVE      :: everywhere_init = 0.05 
     754 
     755 
     756 
     757                              !-------------------! 
     758                              ! stomate_alloc.f90 ! 
     759                              !-------------------! 
     760 
     761  ! 1. Scalar 
     762 
    559763  ! Do we try to reach a minimum reservoir even if we are severely stressed? 
    560764  LOGICAL, SAVE                                        :: ok_minres = .TRUE. 
    … …  
    582786  ! scaling depth for nitrogen limitation (m) 
    583787  REAL(r_std), SAVE                                     :: z_nitrogen = 0.2 
    584   ! 
    585   !- 
    586   ! stomate_data 
    587   !- 
    588   !!------------------------------- 
    589   !! Parameters for the pipe model 
    590   !!------------------------------ 
    591   !- 
     788 
     789 
     790  ! 2. Arrays 
     791   
     792 
     793  ! 3. Coefficients of equations 
     794 
     795  REAL(r_std), SAVE  :: lai_max_to_happy = 0.5   
     796  REAL(r_std), SAVE  ::  Nlim_tref = 25. 
     797 
     798 
     799                              !------------------! 
     800                              ! stomate_data.f90 ! 
     801                              !------------------! 
     802  ! 1. Scalar  
     803 
     804  ! 
     805  ! 1.1 Parameters for the pipe model 
     806  ! 
    592807  ! crown area = pipe_tune1. stem diameter**(1.6) (Reinicke's theory) 
    593808  REAL(r_std),SAVE :: pipe_tune1 = 100.0 
    … …  
    601816  ! one more SAVE 
    602817  REAL(r_std),SAVE :: pipe_k1 = 8.e3 
    603   ! 
    604   !- 
    605   ! Maximum tree establishment rate 
    606   REAL(r_std),SAVE :: estab_max_tree = 0.12 
    607   ! Maximum grass establishment rate 
    608   REAL(r_std),SAVE :: estab_max_grass = 0.12 
    609   ! initial density of individuals 
    610   REAL(r_std),SAVE :: ind_0 = 0.02 
    611   ! For trees, minimum fraction of crown area occupied 
    612   ! (due to its branches etc.) 
    613   ! This means that only a small fraction of its crown area 
    614   ! can be invaded by other trees. 
    615   REAL(r_std),SAVE :: min_cover = 0.05   
    616   !- 
    617   ! alpha's : ? 
    618   REAL(r_std),SAVE :: alpha_grass = .5 
    619   REAL(r_std),SAVE :: alpha_tree = 1. 
    620   !- 
    621   ! maximum reference long term temperature (K) 
    622   REAL(r_std),SAVE :: tlong_ref_max = 303.1 
    623   ! minimum reference long term temperature (K) 
    624   REAL(r_std),SAVE :: tlong_ref_min = 253.1 
    625   ! 
    626   !! LOGICAL 
    627   !- 
    628   ! Do we treat PFT expansion across a grid point after introduction? 
    629   ! default = .FALSE. 
    630   LOGICAL,SAVE :: treat_expansion = .FALSE. 
    631   ! 
    632   ! herbivores? 
    633   LOGICAL,SAVE :: ok_herbivores = .FALSE. 
    634   ! 
    635   ! harvesting ? 
    636   LOGICAL,SAVE :: harvest_agri = .TRUE. 
    637   !!---------------------- 
    638   !! climatic parameters  
    639   !!--------------------- 
     818  ! pipe tune exponential coeff 
     819  REAL(r_std), SAVE      :: pipe_tune_exp_coeff = 1.6  
     820 
     821  ! 
     822  !  1.2 climatic parameters  
    640823  ! 
    641824  ! minimum precip, in mm/year 
    … …  
    645828  ! critical fpc, needed for light competition and establishment 
    646829  REAL(r_std),SAVE :: fpc_crit = 0.95 
    647   !- 
    648   ! fraction of GPP which is lost as growth respiration 
    649   REAL(r_std),SAVE :: frac_growthresp = 0.28 
    650   ! 
    651   !- 
     830 
     831  ! 
     832  ! 1.3 sapling characteristics 
     833  ! 
     834  ! alpha's : ? 
     835  REAL(r_std),SAVE :: alpha_grass = .5 
     836  REAL(r_std),SAVE :: alpha_tree = 1. 
    652837  ! mass ratio (heartwood+sapwood)/sapwood 
    653838  REAL(r_std), SAVE  :: mass_ratio_heart_sap = 3. 
    654   ! 
    655   !!--------------------------------------------------------- 
    656   ! time scales for phenology and other processes (in days) 
    657   !!--------------------------------------------------------- 
     839  ! fraction of GPP which is lost as growth respiration 
     840  REAL(r_std),SAVE :: frac_growthresp = 0.28   
     841 
     842  ! 
     843  ! 1.4  time scales for phenology and other processes (in days) 
    658844  ! 
    659845  REAL(r_std), SAVE    ::  tau_hum_month = 20.             
    … …  
    667853  REAL(r_std), SAVE    ::  tau_ngd = 50. 
    668854  REAL(r_std), SAVE    ::  coeff_tau_longterm = 3. 
    669   ! used in stomate_data and in stomate_season 
    670855  REAL(r_std), SAVE    ::  tau_longterm  
    671   ! 
    672   !- 
    673   ! stomate_litter 
    674   !- 
    675   ! scaling depth for soil activity (m) 
    676   REAL(r_std), SAVE    :: z_decomp = 0.2 
    677   ! 
    678   !- 
    679   ! stomate_lpj 
    680   !- 
    681   REAL(r_std), SAVE    :: frac_turnover_daily = 0.55 
    682   ! 
    683   !- 
    684   ! stomate_npp 
    685   !- 
    686   ! maximum fraction of allocatable biomass used for maintenance respiration 
    687   REAL(r_std), SAVE   :: tax_max = 0.8 
    688   ! 
    689   !- 
    690   ! stomate_phenology 
    691   !-  
    692   ! take carbon from atmosphere if carbohydrate reserve too small? 
    693   LOGICAL, SAVE                                         :: always_init = .FALSE. 
    694   ! minimum time (d) since last beginning of a growing season 
    695   REAL(r_std), SAVE                                      :: min_growthinit_time = 300. 
    696   ! moisture availability above which moisture tendency doesn't matter 
    697   REAL(r_std), SAVE                                   :: moiavail_always_tree = 1.0 
    698   REAL(r_std), SAVE                                   :: moiavail_always_grass = 0.6 
    699   ! monthly temp. above which temp. tendency doesn't matter 
    700   REAL(r_std), SAVE                                   ::  t_always 
    701   REAL(r_std), SAVE                                   ::  t_always_add = 10. 
    702   ! 
    703   !- 
    704   ! stomate_season 
    705   !- 
    706   ! rapport maximal GPP/GGP_max pour dormance 
    707   REAL(r_std), SAVE                                  :: gppfrac_dormance = 0.2 
    708   ! minimum gpp considered as not "lowgpp" 
    709   REAL(r_std), SAVE                                  :: min_gpp_allowed = 0.3 
    710   ! tau (year) for "climatologic variables 
    711   REAL(r_std), SAVE                                  :: tau_climatology = 20 
    712   ! parameters for herbivore activity 
    713   REAL(r_std), SAVE                                  :: hvc1 = 0.019 
    714   REAL(r_std), SAVE                                  :: hvc2 = 1.38 
    715   REAL(r_std), SAVE                                  :: leaf_frac_hvc =.33 
    716   ! 
    717   !- 
    718   ! stomate_vmax 
    719   !- 
    720   ! offset (minimum relative vcmax) 
    721   REAL(r_std), SAVE                                      :: vmax_offset = 0.3 
    722   ! leaf age at which vmax attains vcmax_opt (in fraction of critical leaf age) 
    723   REAL(r_std), SAVE                                      :: leafage_firstmax = 0.03 
    724   ! leaf age at which vmax falls below vcmax_opt (in fraction of critical leaf age) 
    725   REAL(r_std), SAVE                                      :: leafage_lastmax = 0.5 
    726   ! leaf age at which vmax attains its minimum (in fraction of critical leaf age) 
    727   REAL(r_std), SAVE                                      :: leafage_old = 1. 
    728  
    729  
    730 !-------------------------- 
    731 !-------------------------- 
    732 ! ARRAYS-PARAMETERS 
    733 !-------------------------- 
    734 !-------------------------- 
    735   !- 
    736   ! condveg 
    737   !- 
    738   !   The correspondance table for the soil color numbers and their albedo 
    739   ! 
    740   REAL(r_std), DIMENSION(classnb) :: vis_dry = (/0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.27/) 
    741   REAL(r_std), DIMENSION(classnb) :: nir_dry = (/0.48, 0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20, 0.55/)   
    742   REAL(r_std), DIMENSION(classnb) :: vis_wet = (/0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.15/)   
    743   REAL(r_std), DIMENSION(classnb) :: nir_wet = (/0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.31/) 
    744   !    
    745   ! Nathalie, introduction d'un albedo moyen, VIS+NIR 
    746   ! Les valeurs suivantes correspondent a la moyenne des valeurs initiales 
    747   !  REAL(stnd), DIMENSION(classnb) :: albsoil_vis = (/0.18, 0.165, 0.15, 0.135, 0.12, 0.105, 0.09, 0.075, 0.21/) 
    748   !  REAL(stnd), DIMENSION(classnb) :: albsoil_nir = (/0.36, 0.33, 0.30, 0.27, 0.24, 0.21, 0.18, 0.15, 0.43/) 
    749   ! les valeurs retenues accentuent le contraste entre equateur et Sahara.  
    750   ! On diminue aussi l'albedo des deserts (tous sauf Sahara) 
    751   REAL(r_std), DIMENSION(classnb) :: albsoil_vis = (/0.18, 0.16, 0.16, 0.15, 0.12, 0.105, 0.09, 0.075, 0.25/) 
    752   REAL(r_std), DIMENSION(classnb) :: albsoil_nir = (/0.36, 0.34, 0.34, 0.33, 0.30, 0.25, 0.20, 0.15, 0.45/) 
    753  
    754   !- 
    755   ! lpj_fire 
    756   !- 
    757  
    758   ! What fraction of a burned plant compartment goes into the atmosphere 
    759   !   (rest into litter) 
    760   REAL(r_std), SAVE, DIMENSION(nparts) :: co2frac = (/ .95, .95, 0., 0.3, 0., 0., .95, .95 /) 
    761  
    762   !- 
    763   ! stomate_litter  
    764   !- 
    765  
    766   ! C/N ratio 
    767   REAL(r_std), SAVE, DIMENSION(nparts) :: CN = 40.0  
    768   ! Lignine/C ratio of the different plant parts 
    769   REAL(r_std), SAVE, DIMENSION(nparts) :: LC = (/ 0.22, 0.35, 0.35, 0.35, 0.35, 0.22, 0.22, 0.22 /) 
    770   ! corresponding to frac_soil(istructural,iactive,iabove)  
    771   REAL(r_std), SAVE      ::  frac_soil_struct_aa = .55 
    772   ! corresponding to frac_soil(istructural,iactive,ibelow) 
    773   REAL(r_std), SAVE      :: frac_soil_struct_ab = .45 
    774   ! corresponding to frac_soil(istructural,islow,iabove) 
    775   REAL(r_std), SAVE      ::  frac_soil_struct_sa = .7 
    776   ! corresponding to frac_soil(istructural,islow,ibelow)  
    777   REAL(r_std), SAVE      ::  frac_soil_struct_sb = .7 
    778   ! corresponding to frac_soil(imetabolic,iactive,iabove) 
    779   REAL(r_std), SAVE      ::  frac_soil_metab_aa = .45 
    780   ! corresponding to frac_soil(imetabolic,iactive,ibelow) 
    781   REAL(r_std), SAVE      ::  frac_soil_metab_ab = .45 
    782   !- 
    783   ! stomate_soilcarbon 
    784   !- 
    785   ! frac_carb_coefficients 
    786   ! from active pool: depends on clay content 
    787   ! correspnding to  frac_carb(:,iactive,iactive) 
    788   REAL(r_std), SAVE      :: frac_carb_aa = 0.0 
    789   ! correspnding to  frac_carb(:,iactive,ipassive) 
    790   REAL(r_std), SAVE      :: frac_carb_ap = 0.004 
    791   !frac_carb(;;iactive,islow) is computed in stomate_soilcarbon.f90 
    792   !- 
    793   ! from slow pool 
    794   ! correspnding to  frac_carb(:,islow,islow) 
    795   REAL(r_std), SAVE      :: frac_carb_ss = 0.0   
    796   ! correspnding to  frac_carb(:,islow,iactive) 
    797   REAL(r_std), SAVE      :: frac_carb_sa = .42 
    798   ! correspnding to  frac_carb(:,islow,ipassive) 
    799   REAL(r_std), SAVE      :: frac_carb_sp = .03 
    800   !- 
    801   ! from passive pool 
    802   ! correspnding to  frac_carb(:,ipassive,ipassive) 
    803   REAL(r_std), SAVE      :: frac_carb_pp = .0 
    804   ! correspnding to  frac_carb(:,ipassive,iactive) 
    805   REAL(r_std), SAVE      :: frac_carb_pa = .45 
    806   ! correspnding to  frac_carb(:,ipassive,islow) 
    807   REAL(r_std), SAVE      :: frac_carb_ps = .0 
    808   
    809  
    810 !---------------------------------------- 
    811 !--------------------------------------- 
    812 ! COEFFICIENTS OF EQUATIONS 
    813 !------------------------------------- 
    814 !--------------------------------------- 
    815  
    816   !--------- 
    817   ! SECHIBA 
    818   !--------- 
    819   !- 
    820   ! diffuco 
    821   !- 
    822   REAL(r_std),PARAMETER :: Tetens_1 = 0.622    
    823   REAL(r_std),PARAMETER :: Tetens_2 = 0.378 
    824   REAL(r_std),PARAMETER :: std_ci_frac = 0.667 
    825   REAL(r_std),PARAMETER :: alpha_j = 0.8855 
    826   REAL(r_std),PARAMETER :: curve_assim = 0.7 
    827   REAL(r_std),PARAMETER :: WJ_coeff1 = 4.5 
    828   REAL(r_std),PARAMETER :: WJ_coeff2 = 10.5 
    829   REAL(r_std),PARAMETER :: Vc_to_Rd_ratio = 0.011 
    830   REAL(r_std),PARAMETER :: O2toCO2_stoechio = 1.6 
    831   REAL(r_std),PARAMETER :: mmol_to_m_1 = 0.0244 
    832   REAL(r_std),PARAMETER  :: RG_to_PAR = 0.5  
    833   REAL(r_std),PARAMETER  :: W_to_mmol = 4.6 ! W_to_mmol * RG_to_PAR = 2.3 
    834   ! 
    835   REAL(r_std), SAVE      :: lai_level_depth = .15 
    836   REAL(r_std), SAVE      :: x1_coef =  0.177 
    837   REAL(r_std), SAVE      :: x1_Q10 =  0.069 
    838   REAL(r_std), SAVE      :: quantum_yield =  0.092 
    839   REAL(r_std), SAVE      :: kt_coef = 0.7      
    840   REAL(r_std), SAVE      :: kc_coef = 39.09 
    841   REAL(r_std), SAVE      :: Ko_Q10 = .085 
    842   REAL(r_std), SAVE      :: Oa = 210000. 
    843   REAL(r_std), SAVE      :: Ko_coef =  2.412 
    844   REAL(r_std), SAVE      :: CP_0 = 42. 
    845   REAL(r_std), SAVE      :: CP_temp_coef = 9.46  
    846   REAL(r_std), SAVE      :: CP_temp_ref = 25. 
    847   ! 
    848   REAL(r_std), SAVE, DIMENSION(2)  :: rt_coef = (/ 0.8, 1.3 /)  
    849   REAL(r_std), SAVE, DIMENSION(2)  :: vc_coef = (/ 0.39, 0.3 /) 
    850   ! 
    851   ! coefficients of the polynome of degree 5 used inthe equation of coeff_dew_veg 
    852   REAL(r_std), SAVE, DIMENSION(6)     :: dew_veg_poly_coeff = & 
    853   & (/ 0.887773, 0.205673, 0.110112, 0.014843,  0.000824,  0.000017 /)  
    854   
    855   !--------- 
    856   ! LPJ 
    857   !--------- 
    858   !- 
    859   ! lpj_crown 
    860   !- 
    861   REAL(r_std), SAVE      :: pipe_tune_exp_coeff = 1.6  
    862   ! 
    863   !- 
    864   ! lpj_establish 
    865   !- 
    866   REAL(r_std), SAVE      :: establish_scal_fact = 15. 
    867   REAL(r_std), SAVE      :: fpc_crit_max = .075 
    868   REAL(r_std), SAVE      :: fpc_crit_min= .05  
    869   ! 
    870   !- 
    871   ! lpj_fire 
    872   !- 
    873   REAL(r_std), SAVE, DIMENSION(3) :: bcfrac_coeff = (/ .3,  1.3,  88.2 /)  
    874   REAL(r_std), SAVE, DIMENSION(4)  :: firefrac_coeff = (/ 0.45, 0.8, 0.6, 0.13 /) 
    875   ! 
    876   !- 
    877   ! lpj_gap 
    878   !-  
    879   REAL(r_std), SAVE      ::  availability_fact = 0.02 
    880   REAL(r_std), SAVE      ::  vigour_ref = 0.17 
    881   REAL(r_std), SAVE      ::  vigour_coeff = 70.  
    882   !- 
    883   ! lpj_pftinout 
    884   !- 
    885   REAL(r_std), SAVE      :: RIP_time_min = 1.25 
    886   REAL(r_std), SAVE      :: npp_longterm_init = 10.  
    887   REAL(r_std), SAVE      :: everywhere_init = 0.05 
    888   ! 
    889  
    890   !--------- 
    891   ! STOMATE 
    892   !--------- 
    893   !- 
    894   ! stomate_alloc 
    895   !-  
    896   REAL(r_std), PARAMETER  ::  max_possible_lai = 10.  
    897   REAL(r_std), PARAMETER  ::  Nlim_Q10 = 10.  
    898   ! 
    899   REAL(r_std), SAVE      :: lai_max_to_happy = 0.5   
    900   REAL(r_std), SAVE  ::  Nlim_tref = 25. 
    901   ! 
    902   !- 
    903   ! stomate_data 
    904   !- 
     856 
     857  ! 3. Coefficients of equations 
     858 
    905859  REAL(r_std), SAVE  :: bm_sapl_carbres = 5. 
    906860  REAL(r_std), SAVE  :: bm_sapl_sapabove = 0.5 
    … …  
    920874  REAL(r_std), SAVE, DIMENSION(2)  :: maxdia_coeff =(/ 100., 0.01/) 
    921875  REAL(r_std), SAVE, DIMENSION(4)  :: bm_sapl_leaf = (/ 4., 4., .8, 5./) 
    922   ! 
    923   !- 
    924   ! stomate_litter 
    925   !- 
    926   REAL(r_std), PARAMETER    :: Q10 = 10. 
    927   ! 
    928   REAL(r_std), SAVE      :: metabolic_ref_frac = 0.85 
     876 
     877 
     878 
     879                              !--------------------! 
     880                              ! stomate_litter.f90 ! 
     881                              !--------------------! 
     882 
     883 
     884  ! 1. Scalar 
     885 
     886  ! scaling depth for soil activity (m) 
     887  REAL(r_std), SAVE    :: z_decomp = 0.2 
     888 
     889  ! 2. Arrays 
     890 
     891  ! C/N ratio 
     892  REAL(r_std), SAVE, DIMENSION(nparts) :: CN = 40.0  
     893  ! Lignine/C ratio of the different plant parts 
     894  REAL(r_std), SAVE, DIMENSION(nparts) :: LC = (/ 0.22, 0.35, 0.35, 0.35, 0.35, 0.22, 0.22, 0.22 /) 
     895  ! corresponding to frac_soil(istructural,iactive,iabove)  
     896  REAL(r_std), SAVE      ::  frac_soil_struct_aa = .55 
     897  ! corresponding to frac_soil(istructural,iactive,ibelow) 
     898  REAL(r_std), SAVE      :: frac_soil_struct_ab = .45 
     899  ! corresponding to frac_soil(istructural,islow,iabove) 
     900  REAL(r_std), SAVE      ::  frac_soil_struct_sa = .7 
     901  ! corresponding to frac_soil(istructural,islow,ibelow)  
     902  REAL(r_std), SAVE      ::  frac_soil_struct_sb = .7 
     903  ! corresponding to frac_soil(imetabolic,iactive,iabove) 
     904  REAL(r_std), SAVE      ::  frac_soil_metab_aa = .45 
     905  ! corresponding to frac_soil(imetabolic,iactive,ibelow) 
     906  REAL(r_std), SAVE      ::  frac_soil_metab_ab = .45 
     907 
     908  ! 3. Coefficients of equations 
     909 
     910  REAL(r_std), SAVE      :: metabolic_ref_frac = 0.85  ! used by litter and soilcarbon 
    929911  REAL(r_std), SAVE      :: metabolic_LN_ratio = 0.018     
    930912  REAL(r_std), SAVE      :: tau_metabolic = .066 
    … …  
    934916  REAL(r_std), SAVE      :: litter_struct_coef = 3. 
    935917  REAL(r_std), SAVE, DIMENSION(3)   :: moist_coeff = (/ 1.1,  2.4,  0.29 /) 
    936   ! 
    937   !- 
    938   ! stomate_phenology 
    939   !- 
     918 
     919 
     920 
     921                             !-----------------! 
     922                             ! stomate_lpj.f90 ! 
     923                             !-----------------! 
     924 
     925  ! 1. Scalar 
     926 
     927  REAL(r_std), SAVE    :: frac_turnover_daily = 0.55 
     928 
     929 
     930                             !-----------------! 
     931                             ! stomate_npp.f90 ! 
     932                             !-----------------! 
     933 
     934  ! 1. Scalar 
     935 
     936  ! maximum fraction of allocatable biomass used for maintenance respiration 
     937  REAL(r_std), SAVE   :: tax_max = 0.8 
     938 
     939 
     940                             !-----------------------! 
     941                             ! stomate_phenology.f90 ! 
     942                             !-----------------------! 
     943 
     944 
     945 
     946  ! 1. Scalar 
     947 
     948  ! take carbon from atmosphere if carbohydrate reserve too small? 
     949  LOGICAL, SAVE                                         :: always_init = .FALSE. 
     950  ! minimum time (d) since last beginning of a growing season 
     951  REAL(r_std), SAVE                                      :: min_growthinit_time = 300. 
     952  ! moisture availability above which moisture tendency doesn't matter 
     953  REAL(r_std), SAVE                                   :: moiavail_always_tree = 1.0 
     954  REAL(r_std), SAVE                                   :: moiavail_always_grass = 0.6 
     955  ! monthly temp. above which temp. tendency doesn't matter 
     956  REAL(r_std), SAVE                                   ::  t_always 
     957  REAL(r_std), SAVE                                   ::  t_always_add = 10. 
     958 
     959  ! 3. Coefficients of equations 
     960   
    940961  REAL(r_std), SAVE      :: gddncd_ref = 603. 
    941962  REAL(r_std), SAVE      :: gddncd_curve = 0.0091 
    942963  REAL(r_std), SAVE      :: gddncd_offset = 64. 
    943   ! 
    944   !- 
    945   ! stomate_prescribe 
    946   !- 
     964 
     965 
     966 
     967 
     968                             !-----------------------! 
     969                             ! stomate_prescribe.f90 ! 
     970                             !-----------------------! 
     971 
     972  ! 3. Coefficients of equations 
     973 
    947974  REAL(r_std), SAVE      :: cn_tree = 4. 
    948975  REAL(r_std), SAVE      :: bm_sapl_rescale = 40. 
    949   ! 
    950   !- 
    951   ! stomate_resp 
    952   !- 
     976 
     977 
     978 
     979                             !------------------! 
     980                             ! stomate_resp.f90 ! 
     981                             !------------------! 
     982 
     983  ! 3. Coefficients of equations 
     984 
    953985  REAL(r_std), SAVE      :: maint_resp_min_vmax = 0.3   
    954986  REAL(r_std), SAVE      :: maint_resp_coeff = 1.4 
    955   ! 
    956   !- 
    957   ! stomate_season 
    958   !- 
    959   REAL(r_std), SAVE  :: ncd_max_year = 3. 
    960   REAL(r_std), SAVE  :: gdd_threshold = 5. 
    961   REAL(r_std), SAVE  :: green_age_ever = 2. 
    962   REAL(r_std), SAVE  :: green_age_dec = 0.5 
    963   !- 
    964   ! stomate_soilcarbon 
    965   !- 
     987 
     988 
     989 
     990                             !------------------------! 
     991                             ! stomate_soilcarbon.f90 ! 
     992                             !------------------------! 
     993 
     994  ! 2. Arrays  
     995 
     996  ! frac_carb_coefficients 
     997  ! from active pool: depends on clay content 
     998  ! correspnding to  frac_carb(:,iactive,iactive) 
     999  REAL(r_std), SAVE      :: frac_carb_aa = 0.0 
     1000  ! correspnding to  frac_carb(:,iactive,ipassive) 
     1001  REAL(r_std), SAVE      :: frac_carb_ap = 0.004 
     1002  !frac_carb(;;iactive,islow) is computed in stomate_soilcarbon.f90 
     1003  !- 
     1004  ! from slow pool 
     1005  ! correspnding to  frac_carb(:,islow,islow) 
     1006  REAL(r_std), SAVE      :: frac_carb_ss = 0.0   
     1007  ! correspnding to  frac_carb(:,islow,iactive) 
     1008  REAL(r_std), SAVE      :: frac_carb_sa = .42 
     1009  ! correspnding to  frac_carb(:,islow,ipassive) 
     1010  REAL(r_std), SAVE      :: frac_carb_sp = .03 
     1011  !- 
     1012  ! from passive pool 
     1013  ! correspnding to  frac_carb(:,ipassive,ipassive) 
     1014  REAL(r_std), SAVE      :: frac_carb_pp = .0 
     1015  ! correspnding to  frac_carb(:,ipassive,iactive) 
     1016  REAL(r_std), SAVE      :: frac_carb_pa = .45 
     1017  ! correspnding to  frac_carb(:,ipassive,islow) 
     1018  REAL(r_std), SAVE      :: frac_carb_ps = .0 
     1019 
     1020 
     1021  ! 3. Coefficients of equations 
     1022 
    9661023  REAL(r_std), SAVE      :: active_to_pass_clay_frac = .68   
    9671024  !residence times in carbon pools (days) 
    … …  
    9711028  ! 
    9721029  REAL(r_std), SAVE, DIMENSION(3) :: flux_tot_coeff = (/ 1.2, 1.4, .75/) 
    973   ! 
    974   !- 
    975   ! stomate_turnover 
    976   !- 
     1030 
     1031 
     1032 
     1033                             !----------------------! 
     1034                             ! stomate_turnover.f90 ! 
     1035                             !----------------------! 
     1036 
     1037  ! 3.Coefficients of equations 
     1038 
    9771039  REAL(r_std), SAVE      ::  new_turnover_time_ref = 20. 
    9781040  REAL(r_std), SAVE      ::  dt_turnover_time = 10.  
    … …  
    9801042  REAL(r_std), SAVE, DIMENSION(3)   :: leaf_age_crit_coeff = (/ 1.5, 0.75, 10./) 
    9811043 
    982 !************************************************************** 
     1044 
     1045 
     1046 
     1047                             !------------------! 
     1048                             ! stomate_vmax.f90 ! 
     1049                             !------------------! 
     1050 
     1051  ! 1. Scalar 
     1052 
     1053  ! offset (minimum relative vcmax) 
     1054  REAL(r_std), SAVE                                      :: vmax_offset = 0.3 
     1055  ! leaf age at which vmax attains vcmax_opt (in fraction of critical leaf age) 
     1056  REAL(r_std), SAVE                                      :: leafage_firstmax = 0.03 
     1057  ! leaf age at which vmax falls below vcmax_opt (in fraction of critical leaf age) 
     1058  REAL(r_std), SAVE                                      :: leafage_lastmax = 0.5 
     1059  ! leaf age at which vmax attains its minimum (in fraction of critical leaf age) 
     1060  REAL(r_std), SAVE                                      :: leafage_old = 1. 
     1061 
     1062 
     1063 
     1064                             !--------------------! 
     1065                             ! stomate_season.f90 ! 
     1066                             !--------------------! 
     1067 
     1068 
     1069  ! 1. Scalar 
     1070 
     1071  ! rapport maximal GPP/GGP_max pour dormance 
     1072  REAL(r_std), SAVE                                  :: gppfrac_dormance = 0.2 
     1073  ! minimum gpp considered as not "lowgpp" 
     1074  REAL(r_std), SAVE                                  :: min_gpp_allowed = 0.3 
     1075  ! tau (year) for "climatologic variables 
     1076  REAL(r_std), SAVE                                  :: tau_climatology = 20 
     1077  ! parameters for herbivore activity 
     1078  REAL(r_std), SAVE                                  :: hvc1 = 0.019 
     1079  REAL(r_std), SAVE                                  :: hvc2 = 1.38 
     1080  REAL(r_std), SAVE                                  :: leaf_frac_hvc =.33 
     1081  ! maximum reference long term temperature (K) 
     1082  REAL(r_std),SAVE :: tlong_ref_max = 303.1 
     1083  ! minimum reference long term temperature (K) 
     1084  REAL(r_std),SAVE :: tlong_ref_min = 253.1 
     1085 
     1086  ! 3. Coefficients of equations 
     1087 
     1088  REAL(r_std), SAVE  :: ncd_max_year = 3. 
     1089  REAL(r_std), SAVE  :: gdd_threshold = 5. 
     1090  REAL(r_std), SAVE  :: green_age_ever = 2. 
     1091  REAL(r_std), SAVE  :: green_age_dec = 0.5 
     1092 
     1093 
    9831094 
    9841095 CONTAINS 
    9851096 
    986  ! Subroutine called for getin the new parameters values used in sechiba 
    987  ! 
    988  SUBROUTINE getin_sechiba_parameters 
    989  
    990   IMPLICIT NONE 
    991   ! first call 
    992   LOGICAL, SAVE ::  first_call = .TRUE. 
    993  
    994   IF(first_call) THEN  
    995  
    996 !!$   CALL getin('DIAG_QSAT',diag_qsat) 
    997    !   
    998    CALL getin('QWILT',qwilt) 
    999    CALL getin('MIN_RESDIS',min_resdis) 
    1000    CALL getin('MIN_DRAIN',min_drain) 
    1001    CALL getin('MAX_DRAIN',max_drain) 
    1002    CALL getin('EXP_DRAIN',exp_drain) 
    1003    CALL getin('MX_EAU_EAU',mx_eau_eau) 
    1004    CALL getin('RSOL_CSTE',rsol_cste) 
    1005    CALL getin('HCRIT_LITTER',hcrit_litter) 
    1006    !- 
    1007    CALL getin('SOILTYPE_DEFAULT',soiltype_default) 
    1008    !- 
    1009    CALL getin('MAXMASS_GLACIER',maxmass_glacier) 
    1010    CALL getin('MIN_VEGFRAC',min_vegfrac) 
    1011    !- 
    1012    CALL getin('SNOWCRI',snowcri) 
    1013    !- 
    1014    CALL getin('SNOWCRI_ALB',snowcri_alb) 
    1015    CALL getin('MIN_WIND',min_wind) 
    1016    CALL getin('Z0_BARE',z0_bare) 
    1017    CALL getin('Z0_ICE',z0_ice) 
    1018    CALL getin('TCST_SNOWA',tcst_snowa) 
    1019    CALL getin('MAX_SNOW_AGE',max_snow_age) 
    1020    CALL getin('SNOW_TRANS',snow_trans) 
    1021    CALL getin('ALB_DEADLEAF',alb_deadleaf) 
    1022    CALL getin('ALB_ICE',alb_ice) 
    1023    !- 
    1024    CALL getin('Z0_OVER_HEIGHT',z0_over_height) 
    1025    CALL getin('HEIGHT_DISPLACEMENT',height_displacement) 
    1026    !- 
    1027    CALL getin('NLAI',nlai) 
    1028    CALL getin('LAIMAX',laimax) 
    1029    CALL getin('XC4_1',xc4_1) 
    1030    CALL getin('XC4_2',xc4_2) 
    1031    !- 
    1032    CALL getin('DMCS',dmcs) 
    1033    CALL getin('DMCR',dmcr) 
    1034    !- 
    1035    CALL getin('VIS_DRY',vis_dry) 
    1036    CALL getin('NIR_DRY',nir_dry) 
    1037    CALL getin('VIS_WET',vis_wet) 
    1038    CALL getin('NIR_WET',nir_wet) 
    1039    CALL getin('ALBSOIL_VIS',albsoil_vis) 
    1040    CALL getin('ALBSOIL_NIR',albsoil_nir) 
    1041    !- 
    1042    CALL getin('CLAYFRACTION_DEFAULT',clayfraction_default) 
    1043    ! 
    1044    CALL getin('DEW_VEG_POLY_COEFF',dew_veg_poly_coeff) 
    1045  
    1046    first_call =.FALSE. 
    1047  
    1048   ENDIF 
    1049  
    1050   END SUBROUTINE getin_sechiba_parameters 
    1051  
    1052 !********************************************************* 
    1053  
    1054   ! Subroutine called only if river_routing is activated 
    1055  
    1056   SUBROUTINE getin_routing_parameters 
    1057  
    1058   IMPLICIT NONE 
    1059  
    1060   LOGICAL, SAVE ::  first_call = .TRUE. 
    1061  
    1062   IF(first_call) THEN 
    1063  
    1064      CALL getin('CROP_COEF',crop_coef) 
    1065  
    1066      first_call =.FALSE. 
    1067  
    1068   ENDIF    
    1069  
    1070   END SUBROUTINE getin_routing_parameters   
    1071  
    1072 !******************************************************* 
    1073  
    1074   ! Subroutine called only if hydrol_cwrr is activated 
    1075  
    1076   SUBROUTINE getin_hydrol_cwrr_parameters 
    1077  
    1078   IMPLICIT NONE 
    1079  
    1080   LOGICAL, SAVE ::  first_call = .TRUE. 
    1081  
     1097   SUBROUTINE getin_sechiba_parameters 
     1098 
     1099     IMPLICIT NONE 
     1100     ! first call 
     1101     LOGICAL, SAVE ::  first_call = .TRUE. 
     1102      
     1103     IF(first_call) THEN  
     1104         
     1105        ! Global 
     1106        ! DS by global I mean the parameters used by two or more modules 
     1107        ! Example : the common parameters for both hydrology models 
     1108        CALL getin_p('MAXMASS_GLACIER',maxmass_glacier) 
     1109        CALL getin_p('SNOWCRI',snowcri) 
     1110        CALL getin_p('SECHIBA_QSINT', qsintcst) 
     1111        WRITE(numout, *)' SECHIBA_QSINT, qsintcst = ', qsintcst 
     1112        CALL getin_p("HYDROL_SOIL_DEPTH", dpu_cste) 
     1113        ! 
     1114        CALL getin_p('MIN_WIND',min_wind) 
     1115        CALL getin_p('MAX_SNOW_AGE',max_snow_age) 
     1116        CALL getin_p('SNOW_TRANS',snow_trans) 
     1117        CALL getin_p('MX_EAU_EAU',mx_eau_eau) 
     1118        !- 
     1119        ! condveg 
     1120        CALL getin_p('Z0_OVER_HEIGHT',z0_over_height) 
     1121        CALL getin_p('HEIGHT_DISPLACEMENT',height_displacement) 
     1122        CALL getin_p('Z0_BARE',z0_bare) 
     1123        CALL getin_p('Z0_ICE',z0_ice) 
     1124        CALL getin_p('TCST_SNOWA',tcst_snowa) 
     1125        CALL getin_p('SNOWCRI_ALB',snowcri_alb) 
     1126        ! 
     1127        CALL getin_p('VIS_DRY',vis_dry) 
     1128        CALL getin_p('NIR_DRY',nir_dry) 
     1129        CALL getin_p('VIS_WET',vis_wet) 
     1130        CALL getin_p('NIR_WET',nir_wet) 
     1131        CALL getin_p('ALBSOIL_VIS',albsoil_vis) 
     1132        CALL getin_p('ALBSOIL_NIR',albsoil_nir) 
     1133        !- 
     1134        CALL getin_p('ALB_DEADLEAF',alb_deadleaf) 
     1135        CALL getin_p('ALB_ICE',alb_ice) 
     1136        !- 
     1137        ! diffuco  
     1138        ! DS the rest of diffuco parameters are only read when ok_co2 is set to TRUE 
     1139        CALL getin_p('NLAI',nlai) 
     1140        CALL getin_p('LAIMAX',laimax) 
     1141        CALL getin_p('XC4_1',xc4_1) 
     1142        CALL getin_p('XC4_2',xc4_2) 
     1143        CALL getin_p('DEW_VEG_POLY_COEFF',dew_veg_poly_coeff) 
     1144        !- 
     1145        ! slowproc 
     1146        CALL getin_p('CLAYFRACTION_DEFAULT',clayfraction_default) 
     1147        CALL getin_p('MIN_VEGFRAC',min_vegfrac) 
     1148        CALL getin_p('SOILTYPE_DEFAULT',soiltype_default) 
     1149         
     1150         
     1151        first_call =.FALSE. 
     1152         
     1153     ENDIF 
     1154      
     1155   END SUBROUTINE getin_sechiba_parameters 
     1156! 
     1157!= 
     1158! 
     1159   ! Subroutine called only if ok_co2 is activated 
     1160   ! only for diffuco_trans_co2 
     1161    
     1162   SUBROUTINE getin_co2_parameters 
     1163      
     1164     IMPLICIT NONE 
     1165      
     1166     LOGICAL, SAVE ::  first_call = .TRUE. 
     1167      
     1168     IF(first_call) THEN 
     1169         
     1170        CALL getin_p('LAI_LEVEL_DEPTH',lai_level_depth) 
     1171        CALL getin_p('X1_COEF',x1_coef) 
     1172        CALL getin_p('X1_Q10',x1_Q10) 
     1173        CALL getin_p('QUANTUM_YIELD',quantum_yield) 
     1174        CALL getin_p('KT_COEF',kt_coef) 
     1175        CALL getin_p('KC_COEF',kc_coef) 
     1176        CALL getin_p('KO_Q10',Ko_Q10) 
     1177        CALL getin_p('OA',Oa) 
     1178        CALL getin_p('KO_COEF',Ko_coef) 
     1179        CALL getin_p('CP_0',CP_0) 
     1180        CALL getin_p('CP_TEMP_COEF',cp_temp_coef) 
     1181        CALL getin_p('CP_TEMP_REF',cp_temp_ref) 
     1182        CALL getin_p('RT_COEF',rt_coef) 
     1183        CALL getin_p('VC_COEF',vc_coef) 
     1184         
     1185        first_call =.FALSE. 
     1186         
     1187     ENDIF 
     1188      
     1189   END SUBROUTINE getin_co2_parameters 
     1190! 
     1191!= 
     1192! 
     1193   SUBROUTINE getin_hydrolc_parameters 
     1194      
     1195     LOGICAL, SAVE ::  first_call = .TRUE. 
     1196      
     1197     IF(first_call) THEN  
     1198         
     1199        CALL getin_p('QWILT',qwilt) 
     1200        CALL getin_p('MIN_RESDIS',min_resdis) 
     1201        CALL getin_p('MIN_DRAIN',min_drain) 
     1202        CALL getin_p('MAX_DRAIN',max_drain) 
     1203        CALL getin_p('EXP_DRAIN',exp_drain) 
     1204        CALL getin_p('RSOL_CSTE',rsol_cste) 
     1205        CALL getin_p('HCRIT_LITTER',hcrit_litter) 
     1206         
     1207        first_call =.FALSE. 
     1208         
     1209     ENDIF 
     1210      
     1211   END SUBROUTINE getin_hydrolc_parameters 
     1212    
     1213! 
     1214!= 
     1215! 
     1216   ! Subroutine called only if hydrol_cwrr is activated 
     1217    
     1218   SUBROUTINE getin_hydrol_cwrr_parameters 
     1219      
     1220     IMPLICIT NONE 
     1221      
     1222     LOGICAL, SAVE ::  first_call = .TRUE. 
     1223      
     1224     IF(first_call) THEN 
     1225         
     1226        CALL getin_p('W_TIME',w_time) 
     1227        CALL getin_p('NVAN',nvan)    
     1228        CALL getin_p('AVAN',avan) 
     1229        CALL getin_p('MCR',mcr) 
     1230        CALL getin_p('MCS',mcs) 
     1231        CALL getin_p('KS',ks) 
     1232        CALL getin_p('PCENT',pcent) 
     1233        CALL getin_p('FREE_DRAIN_MAX',free_drain_max) 
     1234        CALL getin_p('MCF',mcf) 
     1235        CALL getin_p('MCW',mcw) 
     1236        CALL getin_p('MC_AWET',mc_awet) 
     1237         
     1238        first_call =.FALSE. 
     1239         
     1240     ENDIF 
     1241 
     1242   END SUBROUTINE getin_hydrol_cwrr_parameters 
     1243! 
     1244!= 
     1245! 
     1246   SUBROUTINE getin_routing_parameters 
     1247      
     1248     IMPLICIT NONE 
     1249      
     1250     LOGICAL, SAVE ::  first_call = .TRUE. 
     1251      
     1252     IF(first_call) THEN 
     1253         
     1254        CALL getin_p('CROP_COEF',crop_coef) 
     1255         
     1256        first_call =.FALSE. 
     1257         
     1258     ENDIF 
     1259      
     1260   END SUBROUTINE getin_routing_parameters 
     1261! 
     1262!= 
     1263! 
     1264   SUBROUTINE getin_stomate_parameters 
     1265      
     1266    IMPLICIT NONE 
     1267     
     1268    LOGICAL, SAVE ::  first_call = .TRUE. 
     1269     
    10821270    IF(first_call) THEN 
    1083  
    1084        CALL getin('W_TIME',w_time) 
    1085        CALL getin('NVAN',nvan)    
    1086        CALL getin('AVAN',avan) 
    1087        CALL getin('MCR',mcr) 
    1088        CALL getin('MCS',mcs) 
    1089        CALL getin('KS',ks) 
    1090        CALL getin('PCENT',pcent) 
    1091        CALL getin('FREE_DRAIN_MAX',free_drain_max) 
    1092        CALL getin('MCF',mcf) 
    1093        CALL getin('MCW',mcw) 
    1094        CALL getin('MC_AWET',mc_awet) 
    1095  
    1096        first_call =.FALSE. 
    1097    
     1271        
     1272       ! constraints_parameters 
     1273       CALL getin_p('TOO_LONG',too_long) 
     1274       !- 
     1275       ! fire parameters 
     1276       CALL getin_p('TAU_FIRE',tau_fire) 
     1277       CALL getin_p('LITTER_CRIT',litter_crit) 
     1278       CALL getin_p('CO2FRAC',co2frac) 
     1279       CALL getin_p('BCFRAC_COEFF',bcfrac_coeff) 
     1280       CALL getin_p('FIREFRAC_COEFF',firefrac_coeff) 
     1281       !- 
     1282       ! gap parameters (+ lpj_const_mort) 
     1283       CALL getin_p('AVAILABILITY_FACT', availability_fact)   
     1284       CALL getin_p('VIGOUR_REF',vigour_ref) 
     1285       CALL getin_p('VIGOUR_COEFF',vigour_coeff)  
     1286       !- 
     1287       ! allocation parameters 
     1288       CALL getin_p('OK_MINRES',ok_minres) 
     1289       CALL getin_p('TAU_LEAFINIT', tau_leafinit) 
     1290       CALL getin_p('RESERVE_TIME_TREE',reserve_time_tree) 
     1291       CALL getin_p('RESERVE_TIME_GRASS',reserve_time_grass) 
     1292       CALL getin_p('R0',R0) 
     1293       CALL getin_p('S0',S0) 
     1294       CALL getin_p('F_FRUIT',f_fruit) 
     1295       CALL getin_p('ALLOC_SAP_ABOVE_TREE',alloc_sap_above_tree) 
     1296       CALL getin_p('ALLOC_SAP_ABOVE_GRASS',alloc_sap_above_grass) 
     1297       CALL getin_p('MIN_LTOLSR',min_LtoLSR) 
     1298       CALL getin_p('MAX_LTOLSR',max_LtoLSR) 
     1299       CALL getin_p('Z_NITROGEN',z_nitrogen) 
     1300       CALL getin_p('LAI_MAX_TO_HAPPY',lai_max_to_happy) 
     1301       CALL getin_p('NLIM_TREF',Nlim_tref)    
     1302       !- 
     1303       ! data parameters 
     1304       CALL getin_p('PIPE_TUNE1',pipe_tune1) 
     1305       CALL getin_p('PIPE_TUNE2',pipe_tune2)    
     1306       CALL getin_p('PIPE_TUNE3',pipe_tune3) 
     1307       CALL getin_p('PIPE_TUNE4',pipe_tune4) 
     1308       CALL getin_p('PIPE_DENSITY',pipe_density) 
     1309       CALL getin_p('PIPE_K1',pipe_k1) 
     1310       CALL getin_p('PIPE_TUNE_EXP_COEFF',pipe_tune_exp_coeff) 
     1311       ! 
     1312       CALL getin_p('PRECIP_CRIT',precip_crit) 
     1313       CALL getin_p('GDD_CRIT_ESTAB',gdd_crit_estab)  
     1314       CALL getin_p('FPC_CRIT',fpc_crit) 
     1315       CALL getin_p('ALPHA_GRASS',alpha_grass) 
     1316       CALL getin_p('ALPHA_TREE',alpha_tree) 
     1317       !- 
     1318       CALL getin_p('MASS_RATIO_HEART_SAP',mass_ratio_heart_sap) 
     1319       CALL getin_p('FRAC_GROWTHRESP',frac_growthresp) 
     1320       CALL getin_p('TAU_HUM_MONTH',tau_hum_month) 
     1321       CALL getin_p('TAU_HUM_WEEK',tau_hum_week) 
     1322       CALL getin_p('TAU_T2M_MONTH',tau_t2m_month) 
     1323       CALL getin_p('TAU_T2M_WEEK',tau_t2m_week) 
     1324       CALL getin_p('TAU_TSOIL_MONTH',tau_tsoil_month) 
     1325       CALL getin_p('TAU_SOILHUM_MONTH',tau_soilhum_month) 
     1326       CALL getin_p('TAU_GPP_WEEK',tau_gpp_week) 
     1327       CALL getin_p('TAU_GDD',tau_gdd) 
     1328       CALL getin_p('TAU_NGD',tau_ngd) 
     1329       CALL getin_p('COEFF_TAU_LONGTERM',coeff_tau_longterm) 
     1330       !- 
     1331       CALL getin_p('BM_SAPL_CARBRES',bm_sapl_carbres) 
     1332       CALL getin_p('BM_SAPL_SAPABOVE',bm_sapl_sapabove) 
     1333       CALL getin_p('BM_SAPL_HEARTABOVE',bm_sapl_heartabove) 
     1334       CALL getin_p('BM_SAPL_HEARTBELOW',bm_sapl_heartbelow) 
     1335       CALL getin_p('INIT_SAPL_MASS_LEAF_NAT',init_sapl_mass_leaf_nat) 
     1336       CALL getin_p('INIT_SAPL_MASS_LEAF_AGRI',init_sapl_mass_leaf_agri) 
     1337       CALL getin_p('INIT_SAPL_MASS_CARBRES',init_sapl_mass_carbres) 
     1338       CALL getin_p('INIT_SAPL_MASS_ROOT',init_sapl_mass_root) 
     1339       CALL getin_p('INIT_SAPL_MASS_FRUIT',init_sapl_mass_fruit) 
     1340       CALL getin_p('CN_SAPL_INIT',cn_sapl_init) 
     1341       CALL getin_p('MIGRATE_TREE',migrate_tree) 
     1342       CALL getin_p('MIGRATE_GRASS',migrate_grass) 
     1343       CALL getin_p('MAXDIA_COEFF',maxdia_coeff) 
     1344       CALL getin_p('LAI_INITMIN_TREE',lai_initmin_tree) 
     1345       CALL getin_p('LAI_INITMIN_GRASS',lai_initmin_grass) 
     1346       CALL getin_p('DIA_COEFF',dia_coeff) 
     1347       CALL getin_p('MAXDIA_COEFF',maxdia_coeff) 
     1348       CALL getin_p('BM_SAPL_LEAF',bm_sapl_leaf) 
     1349       !- 
     1350       ! litter parameters 
     1351       CALL getin_p('METABOLIC_REF_FRAC',metabolic_ref_frac) 
     1352       CALL getin_p('Z_DECOMP',z_decomp) 
     1353       CALL getin_p('CN',CN) 
     1354       CALL getin_p('LC',LC) 
     1355       CALL getin_p('FRAC_SOIL_STRUCT_AA',frac_soil_struct_aa) 
     1356       CALL getin_p('FRAC_SOIL_STRUCT_AB',frac_soil_struct_ab) 
     1357       CALL getin_p('FRAC_SOIL_STRUCT_SA',frac_soil_struct_sa) 
     1358       CALL getin_p('FRAC_SOIL_STRUCT_SB',frac_soil_struct_sb) 
     1359       CALL getin_p('FRAC_SOIL_METAB_AA',frac_soil_metab_aa) 
     1360       CALL getin_p('FRAC_SOIL_METAB_AB',frac_soil_metab_ab) 
     1361       ! 
     1362       CALL getin_p('METABOLIC_LN_RATIO',metabolic_LN_ratio)    
     1363       CALL getin_p('TAU_METABOLIC',tau_metabolic) 
     1364       CALL getin_p('TAU_STRUCT',tau_struct) 
     1365       CALL getin_p('SOIL_Q10',soil_Q10) 
     1366       CALL getin_p('TSOIL_REF',tsoil_ref) 
     1367       CALL getin_p('LITTER_STRUCT_COEF',litter_struct_coef) 
     1368       CALL getin_p('MOIST_COEFF',moist_coeff) 
     1369       !- 
     1370       ! lpj parameters 
     1371       CALL getin_p('FRAC_TURNOVER_DAILY',frac_turnover_daily)    
     1372       !- 
     1373       ! npp parameters 
     1374       CALL getin_p('TAX_MAX',tax_max)  
     1375       !- 
     1376       ! phenology parameters 
     1377       CALL getin_p('ALWAYS_INIT',always_init) 
     1378       CALL getin_p('MIN_GROWTHINIT_TIME',min_growthinit_time) 
     1379       CALL getin_p('MOIAVAIL_ALWAYS_TREE',moiavail_always_tree) 
     1380       CALL getin_p('MOIAVAIL_ALWAYS_GRASS',moiavail_always_grass) 
     1381       CALL getin_p('T_ALWAYS_ADD',t_always_add) 
     1382       ! 
     1383       CALL getin_p('GDDNCD_REF',gddncd_ref) 
     1384       CALL getin_p('GDDNCD_CURVE',gddncd_curve) 
     1385       CALL getin_p('GDDNCD_OFFSET',gddncd_offset) 
     1386       !- 
     1387       ! prescribe parameters 
     1388       CALL getin_p('CN_TREE',cn_tree) 
     1389       CALL getin_p('BM_SAPL_RESCALE',bm_sapl_rescale) 
     1390       !- 
     1391       ! respiration parameters 
     1392       CALL getin_p('MAINT_RESP_MIN_VMAX',maint_resp_min_vmax)   
     1393       CALL getin_p('MAINT_RESP_COEFF',maint_resp_coeff) 
     1394       !- 
     1395       ! soilcarbon parameters 
     1396       CALL getin_p('FRAC_CARB_AA',frac_carb_aa) 
     1397       CALL getin_p('FRAC_CARB_AP',frac_carb_ap)    
     1398       CALL getin_p('FRAC_CARB_SS',frac_carb_ss) 
     1399       CALL getin_p('FRAC_CARB_SA',frac_carb_sa) 
     1400       CALL getin_p('FRAC_CARB_SP',frac_carb_sp) 
     1401       CALL getin_p('FRAC_CARB_PP',frac_carb_pp) 
     1402       CALL getin_p('FRAC_CARB_PA',frac_carb_pa) 
     1403       CALL getin_p('FRAC_CARB_PS',frac_carb_ps) 
     1404       ! 
     1405       CALL getin_p('ACTIVE_TO_PASS_CLAY_FRAC',active_to_pass_clay_frac) 
     1406       CALL getin_p('CARBON_TAU_IACTIVE',carbon_tau_iactive) 
     1407       CALL getin_p('CARBON_TAU_ISLOW',carbon_tau_islow) 
     1408       CALL getin_p('CARBON_TAU_IPASSIVE',carbon_tau_ipassive) 
     1409       CALL getin_p('FLUX_TOT_COEFF',flux_tot_coeff) 
     1410       !- 
     1411       ! turnover parameters 
     1412       CALL getin_p('NEW_TURNOVER_TIME_REF',new_turnover_time_ref) 
     1413       CALL getin_p('DT_TURNOVER_TIME',dt_turnover_time) 
     1414       CALL getin_p('LEAF_AGE_CRIT_TREF',leaf_age_crit_tref) 
     1415       CALL getin_p('LEAF_AGE_CRIT_COEFF',leaf_age_crit_coeff) 
     1416       !- 
     1417       ! vmax parameters 
     1418       CALL getin_p('VMAX_OFFSET',vmax_offset) 
     1419       CALL getin_p('LEAFAGE_FIRSTMAX',leafage_firstmax) 
     1420       CALL getin_p('LEAFAGE_LASTMAX',leafage_lastmax) 
     1421       CALL getin_p('LEAFAGE_OLD',leafage_old) 
     1422       !- 
     1423       ! season parameters 
     1424       CALL getin_p('GPPFRAC_DORMANCE',gppfrac_dormance) 
     1425       CALL getin_p('MIN_GPP_ALLOWED',min_gpp_allowed) 
     1426       CALL getin_p('TAU_CLIMATOLOGY',tau_climatology) 
     1427       CALL getin_p('HVC1',hvc1) 
     1428       CALL getin_p('HVC2',hvc2) 
     1429       CALL getin_p('LEAF_FRAC_HVC',leaf_frac_hvc) 
     1430       ! 
     1431       CALL getin_p('TLONG_REF_MAX',tlong_ref_max) 
     1432       CALL getin_p('TLONG_REF_MIN',tlong_ref_min) 
     1433       ! 
     1434       CALL getin_p('NCD_MAX_YEAR',ncd_max_year) 
     1435       CALL getin_p('GDD_THRESHOLD',gdd_threshold) 
     1436       CALL getin_p('GREEN_AGE_EVER',green_age_ever) 
     1437       CALL getin_p('GREEN_AGE_DEC',green_age_dec) 
     1438        
     1439       first_call = .FALSE. 
     1440        
    10981441    ENDIF 
    1099  
    1100   END SUBROUTINE getin_hydrol_cwrr_parameters 
    1101 !-------------------------------------------- 
    1102  
    1103   ! Subroutine called only if ok_co2 is activated 
    1104   ! only for diffuco_trans_co2 
    1105  
    1106   SUBROUTINE getin_co2_parameters 
    1107  
    1108   IMPLICIT NONE 
    1109  
    1110   LOGICAL, SAVE ::  first_call = .TRUE. 
    1111  
     1442     
     1443  END SUBROUTINE getin_stomate_parameters 
     1444! 
     1445!= 
     1446! 
     1447  SUBROUTINE getin_dgvm_parameters    
     1448     
     1449    IMPLICIT NONE 
     1450     
     1451    LOGICAL, SAVE ::  first_call = .TRUE. 
     1452     
    11121453    IF(first_call) THEN 
    1113  
    1114        CALL getin('LAI_LEVEL_DEPTH',lai_level_depth) 
    1115        CALL getin('X1_COEF',x1_coef) 
    1116        CALL getin('X1_Q10',x1_Q10) 
    1117        CALL getin('QUANTUM_YIELD',quantum_yield) 
    1118        CALL getin('KT_COEF',kt_coef) 
    1119        CALL getin('KC_COEF',kc_coef) 
    1120        CALL getin('KO_Q10',Ko_Q10) 
    1121        CALL getin('OA',Oa) 
    1122        CALL getin('KO_COEF',Ko_coef) 
    1123        CALL getin('CP_0',CP_0) 
    1124        CALL getin('CP_TEMP_COEF',cp_temp_coef) 
    1125        CALL getin('CP_TEMP_REF',cp_temp_ref) 
    1126        CALL getin('RT_COEF',rt_coef) 
    1127        CALL getin('VC_COEF',vc_coef) 
    1128  
    1129        first_call =.FALSE. 
    1130  
    1131    ENDIF 
    1132  
    1133   END SUBROUTINE getin_co2_parameters 
    1134  
    1135 !********************************************************** 
    1136  
    1137   ! Subroutine called only if stomate is activated 
    1138  
    1139   SUBROUTINE getin_stomate_parameters 
    1140  
    1141     IMPLICIT NONE 
    1142  
    1143     LOGICAL, SAVE ::  first_call = .TRUE. 
    1144  
    1145     IF(first_call) THEN 
     1454        
     1455       ! establish parameters 
     1456       CALL getin_p('ESTAB_MAX_TREE',estab_max_tree) 
     1457       CALL getin_p('ESTAB_MAX_GRASS',estab_max_grass) 
     1458       CALL getin_p('ESTABLISH_SCAL_FACT',establish_scal_fact) 
     1459       CALL getin_p('FPC_CRIT_MAX',fpc_crit_max) 
     1460       CALL getin_p('FPC_CRIT_MIN',fpc_crit_min) 
     1461       !- 
     1462       ! light parameters 
     1463       CALL getin_p('GRASS_MERCY',grass_mercy) 
     1464       CALL getin_p('TREE_MERCY',tree_mercy) 
     1465       CALL getin_p('ANNUAL_INCREASE',annual_increase) 
     1466       CALL getin_p('MIN_COVER',min_cover) 
     1467       !- 
     1468       ! pftinout parameters 
     1469       CALL getin_p('IND_0',ind_0) 
     1470       CALL getin_p('MIN_AVAIL',min_avail) 
     1471       CALL getin_p('RIP_TIME_MIN',RIP_time_min) 
     1472       CALL getin_p('NPP_LONGTERM_INIT',npp_longterm_init) 
     1473       CALL getin_p('EVERYWHERE_INIT',everywhere_init) 
     1474        
     1475       first_call = .FALSE. 
     1476        
     1477    ENDIF 
    11461478     
    1147        CALL getin('TOO_LONG',too_long) 
    1148        !- 
    1149        CALL getin('TAU_FIRE',tau_fire) 
    1150        CALL getin('LITTER_CRIT',litter_crit) 
    1151        !- 
    1152        CALL getin('OK_MINRES',ok_minres) 
    1153        CALL getin('TAU_LEAFINIT', tau_leafinit) 
    1154        CALL getin('RESERVE_TIME_TREE',reserve_time_tree) 
    1155        CALL getin('RESERVE_TIME_GRASS',reserve_time_grass) 
    1156        CALL getin('R0',R0) 
    1157        CALL getin('S0',S0) 
    1158        CALL getin('F_FRUIT',f_fruit) 
    1159        CALL getin('ALLOC_SAP_ABOVE_TREE',alloc_sap_above_tree) 
    1160        CALL getin('ALLOC_SAP_ABOVE_GRASS',alloc_sap_above_grass) 
    1161        CALL getin('MIN_LTOLSR',min_LtoLSR) 
    1162        CALL getin('MAX_LTOLSR',max_LtoLSR) 
    1163        CALL getin('Z_NITROGEN',z_nitrogen) 
    1164        !- 
    1165        CALL getin('PIPE_TUNE_EXP_COEFF',pipe_tune_exp_coeff) 
    1166        CALL getin('PIPE_TUNE1',pipe_tune1) 
    1167        CALL getin('PIPE_TUNE2',pipe_tune2)    
    1168        CALL getin('PIPE_TUNE3',pipe_tune3) 
    1169        CALL getin('PIPE_TUNE4',pipe_tune4) 
    1170        CALL getin('PIPE_DENSITY',pipe_density) 
    1171        CALL getin('PIPE_K1',pipe_k1) 
    1172        CALL getin('ESTAB_MAX_TREE',estab_max_tree) 
    1173        CALL getin('ESTAB_MAX_GRASS',estab_max_grass) 
    1174        CALL getin('IND_0',ind_0) 
    1175        CALL getin('MIN_COVER',min_cover) 
    1176        CALL getin('PRECIP_CRIT',precip_crit) 
    1177        CALL getin('GDD_CRIT_ESTAB',gdd_crit_estab)  
    1178        CALL getin('FPC_CRIT',fpc_crit) 
    1179        CALL getin('FRAC_GROWTHRESP',frac_growthresp) 
    1180        CALL getin('ALPHA_GRASS',alpha_grass) 
    1181        CALL getin('ALPHA_TREE',alpha_tree) 
    1182        CALL getin('TLONG_REF_MAX',tlong_ref_max) 
    1183        CALL getin('TLONG_REF_MIN',tlong_ref_min) 
    1184        !- 
    1185        CALL getin('MASS_RATIO_HEART_SAP',mass_ratio_heart_sap) 
    1186        CALL getin('TAU_HUM_MONTH',tau_hum_month) 
    1187        CALL getin('TAU_HUM_WEEK',tau_hum_week) 
    1188        CALL getin('TAU_T2M_MONTH',tau_t2m_month) 
    1189        CALL getin('TAU_T2M_WEEK',tau_t2m_week) 
    1190        CALL getin('TAU_TSOIL_MONTH',tau_tsoil_month) 
    1191        CALL getin('TAU_SOILHUM_MONTH',tau_soilhum_month) 
    1192        CALL getin('TAU_GPP_WEEK',tau_gpp_week) 
    1193        CALL getin('TAU_GDD',tau_gdd) 
    1194        CALL getin('TAU_NGD',tau_ngd) 
    1195        CALL getin('COEFF_TAU_LONGTERM',coeff_tau_longterm) 
    1196        ! 
    1197        CALL getin('FRAC_TURNOVER_DAILY',frac_turnover_daily) 
    1198        !- 
    1199        CALL getin('Z_DECOMP',z_decomp) 
    1200        !- 
    1201        CALL getin('TAX_MAX',tax_max) 
    1202        !- 
    1203        CALL getin('ALWAYS_INIT',always_init) 
    1204        CALL getin('MIN_GROWTHINIT_TIME',min_growthinit_time) 
    1205        CALL getin('MOIAVAIL_ALWAYS_TREE',moiavail_always_tree) 
    1206        CALL getin('MOIAVAIL_ALWAYS_GRASS',moiavail_always_grass) 
    1207        CALL getin('T_ALWAYS_ADD',t_always_add) 
    1208        !- 
    1209        CALL getin('VMAX_OFFSET',vmax_offset) 
    1210        CALL getin('LEAFAGE_FIRSTMAX',leafage_firstmax) 
    1211        CALL getin('LEAFAGE_LASTMAX',leafage_lastmax) 
    1212        CALL getin('LEAFAGE_OLD',leafage_old) 
    1213        !- 
    1214        CALL getin('GPPFRAC_DORMANCE',gppfrac_dormance) 
    1215        CALL getin('MIN_GPP_ALLOWED',min_gpp_allowed) 
    1216        CALL getin('TAU_CLIMATOLOGY',tau_climatology) 
    1217        CALL getin('HVC1',hvc1) 
    1218        CALL getin('HVC2',hvc2) 
    1219        CALL getin('LEAF_FRAC_HVC',leaf_frac_hvc) 
    1220        !- 
    1221        CALL getin('CO2FRAC',co2frac) 
    1222        CALL getin('CN',CN) 
    1223        CALL getin('LC',LC) 
    1224        !- 
    1225        CALL getin('FRAC_SOIL_STRUCT_AA',frac_soil_struct_aa) 
    1226        CALL getin('FRAC_SOIL_STRUCT_AB',frac_soil_struct_ab) 
    1227        CALL getin('FRAC_SOIL_STRUCT_SA',frac_soil_struct_sa) 
    1228        CALL getin('FRAC_SOIL_STRUCT_SB',frac_soil_struct_sb) 
    1229        CALL getin('FRAC_SOIL_METAB_AA',frac_soil_metab_aa) 
    1230        CALL getin('FRAC_SOIL_METAB_AB',frac_soil_metab_ab) 
    1231        !- 
    1232        CALL getin('FRAC_CARB_AA',frac_carb_aa) 
    1233        CALL getin('FRAC_CARB_AP',frac_carb_ap)    
    1234        CALL getin('FRAC_CARB_SS',frac_carb_ss) 
    1235        CALL getin('FRAC_CARB_SA',frac_carb_sa) 
    1236        CALL getin('FRAC_CARB_SP',frac_carb_sp) 
    1237        CALL getin('FRAC_CARB_PP',frac_carb_pp) 
    1238        CALL getin('FRAC_CARB_PA',frac_carb_pa) 
    1239        CALL getin('FRAC_CARB_PS',frac_carb_ps) 
    1240  
    1241        !--------------------------------------- 
    1242        ! COEFFICIENTS OF EQUATIONS 
    1243        !------------------------------------- 
    1244        ! 
    1245        !- 
    1246        CALL getin('BCFRAC_COEFF',bcfrac_coeff) 
    1247        CALL getin('FIREFRAC_COEFF',firefrac_coeff) 
    1248        !- 
    1249        CALL getin('AVAILABILITY_FACT', availability_fact)   
    1250        CALL getin('VIGOUR_REF',vigour_ref) 
    1251        CALL getin('VIGOUR_COEFF',vigour_coeff) 
    1252        !- 
    1253        CALL getin('RIP_TIME_MIN',RIP_time_min) 
    1254        CALL getin('NPP_LONGTERM_INIT',npp_longterm_init) 
    1255        CALL getin('EVERYWHERE_INIT',everywhere_init) 
    1256        ! 
    1257        !- 
    1258        CALL getin('LAI_MAX_TO_HAPPY',lai_max_to_happy) 
    1259        CALL getin('NLIM_TREF',Nlim_tref)    
    1260        !- 
    1261        CALL getin('BM_SAPL_CARBRES',bm_sapl_carbres) 
    1262        CALL getin('BM_SAPL_SAPABOVE',bm_sapl_sapabove) 
    1263        CALL getin('BM_SAPL_HEARTABOVE',bm_sapl_heartabove) 
    1264        CALL getin('BM_SAPL_HEARTBELOW',bm_sapl_heartbelow) 
    1265        CALL getin('INIT_SAPL_MASS_LEAF_NAT',init_sapl_mass_leaf_nat) 
    1266        CALL getin('INIT_SAPL_MASS_LEAF_AGRI',init_sapl_mass_leaf_agri) 
    1267        CALL getin('INIT_SAPL_MASS_CARBRES',init_sapl_mass_carbres) 
    1268        CALL getin('INIT_SAPL_MASS_ROOT',init_sapl_mass_root) 
    1269        CALL getin('INIT_SAPL_MASS_FRUIT',init_sapl_mass_fruit) 
    1270        CALL getin('CN_SAPL_INIT',cn_sapl_init) 
    1271        CALL getin('MIGRATE_TREE',migrate_tree) 
    1272        CALL getin('MIGRATE_GRASS',migrate_grass) 
    1273        CALL getin('MAXDIA_COEFF',maxdia_coeff) 
    1274        CALL getin('LAI_INITMIN_TREE',lai_initmin_tree) 
    1275        CALL getin('LAI_INITMIN_GRASS',lai_initmin_grass) 
    1276        CALL getin('DIA_COEFF',dia_coeff) 
    1277        CALL getin('MAXDIA_COEFF',maxdia_coeff) 
    1278        CALL getin('BM_SAPL_LEAF',bm_sapl_leaf) 
    1279        !- 
    1280        CALL getin('METABOLIC_REF_FRAC',metabolic_ref_frac) 
    1281        CALL getin('METABOLIC_LN_RATIO',metabolic_LN_ratio)    
    1282        CALL getin('TAU_METABOLIC',tau_metabolic) 
    1283        CALL getin('TAU_STRUCT',tau_struct) 
    1284        CALL getin('SOIL_Q10',soil_Q10) 
    1285        CALL getin('TSOIL_REF',tsoil_ref) 
    1286        CALL getin('LITTER_STRUCT_COEF',litter_struct_coef) 
    1287        CALL getin('MOIST_COEFF',moist_coeff) 
    1288        !- 
    1289        CALL getin('GDDNCD_REF',gddncd_ref) 
    1290        CALL getin('GDDNCD_CURVE',gddncd_curve) 
    1291        CALL getin('GDDNCD_OFFSET',gddncd_offset) 
    1292        !- 
    1293        CALL getin('CN_TREE',cn_tree) 
    1294        CALL getin('BM_SAPL_RESCALE',bm_sapl_rescale) 
    1295        !- 
    1296        CALL getin('MAINT_RESP_MIN_VMAX',maint_resp_min_vmax)   
    1297        CALL getin('MAINT_RESP_COEFF',maint_resp_coeff) 
    1298        !- 
    1299        CALL getin('NCD_MAX_YEAR',ncd_max_year) 
    1300        CALL getin('GDD_THRESHOLD',gdd_threshold) 
    1301        CALL getin('GREEN_AGE_EVER',green_age_ever) 
    1302        CALL getin('GREEN_AGE_DEC',green_age_dec) 
    1303        !- 
    1304        CALL getin('ACTIVE_TO_PASS_CLAY_FRAC',active_to_pass_clay_frac) 
    1305        CALL getin('CARBON_TAU_IACTIVE',carbon_tau_iactive) 
    1306        CALL getin('CARBON_TAU_ISLOW',carbon_tau_islow) 
    1307        CALL getin('CARBON_TAU_IPASSIVE',carbon_tau_ipassive) 
    1308        CALL getin('FLUX_TOT_COEFF',flux_tot_coeff) 
    1309        !- 
    1310        CALL getin('NEW_TURNOVER_TIME_REF',new_turnover_time_ref) 
    1311        CALL getin('DT_TURNOVER_TIME',dt_turnover_time) 
    1312        CALL getin('LEAF_AGE_CRIT_TREF',leaf_age_crit_tref) 
    1313        CALL getin('LEAF_AGE_CRIT_COEFF',leaf_age_crit_coeff) 
    1314  
    1315        first_call = .FALSE. 
    1316  
    1317     ENDIF 
    1318  
    1319  END SUBROUTINE getin_stomate_parameters 
    1320  
    1321 !****************************************** 
    1322  
    1323  SUBROUTINE getin_dgvm_parameters    
    1324     
    1325    IMPLICIT NONE 
    1326  
    1327     LOGICAL, SAVE ::  first_call = .TRUE. 
    1328  
    1329     IF(first_call) THEN 
    1330  
    1331           CALL getin('ESTABLISH_SCAL_FACT',establish_scal_fact) 
    1332           CALL getin('FPC_CRIT_MAX',fpc_crit_max) 
    1333           CALL getin('FPC_CRIT_MIN',fpc_crit_min) 
    1334           ! 
    1335           CALL getin('GRASS_MERCY',grass_mercy) 
    1336           CALL getin('TREE_MERCY',tree_mercy) 
    1337           CALL getin('ANNUAL_INCREASE',annual_increase) 
    1338           ! 
    1339           CALL getin('MIN_AVAIL',min_avail) 
    1340           CALL getin('RIP_TIME_MIN',RIP_time_min) 
    1341           CALL getin('NPP_LONGTERM_INIT',npp_longterm_init) 
    1342           CALL getin('EVERYWHERE_INIT',everywhere_init) 
    1343  
    1344           first_call = .FALSE. 
    1345         
    1346      ENDIF 
    1347  
    1348  
    1349    END SUBROUTINE getin_dgvm_parameters 
     1479     
     1480  END SUBROUTINE getin_dgvm_parameters 
     1481 
    13501482 
    13511483!-------------------- 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parameters/constantes_mtc.f90

    r64 r257  
    7575  &    .TRUE.,  .TRUE.,  .TRUE., .TRUE., .FALSE., & 
    7676  &    .FALSE., .FALSE., .FALSE. /) 
    77   !- 
     77  ! used in diffuco 
     78  REAL(r_std), PARAMETER, DIMENSION(nvmc)        :: rveg_mtc = &   
     79  & (/ 1., 1., 1., 1., 1., 1. ,1. ,1. ,1. ,1. ,1. ,1., 1. /) 
     80  ! 
    7881  !- 
    7982  ! 2 .Stomate 
    … …  
    9598  &              .TRUE.,  .TRUE.,  .TRUE.,  .TRUE., .FALSE., .FALSE. /) 
    9699 
     100  !>> DS new for merge in the trunk   ! 15/06/2011  
     101  ! Add for writing history files in stomate_lpj.f90 'treeFracPrimDec' and 'treeFracPrimEver' 
     102  ! is PFT deciduous ? 
     103  LOGICAL, PARAMETER, DIMENSION(nvmc)    :: is_deciduous_mtc  = & 
     104  & (/  .FALSE.,  .FALSE.,  .TRUE.,  .FALSE.,  .FALSE.,  .TRUE.,  .FALSE.,   & 
     105  &              .TRUE.,  .TRUE.,  .FALSE.,  .FALSE., .FALSE., .FALSE. /) 
     106  ! is PFT evergreen ? 
     107  LOGICAL, PARAMETER, DIMENSION(nvmc)    :: is_evergreen_mtc  = & 
     108  & (/  .FALSE.,  .TRUE.,  .FALSE.,  .TRUE.,  .TRUE.,  .FALSE.,  .TRUE.,   & 
     109  &              .FALSE.,  .FALSE.,  .FALSE.,  .FALSE., .FALSE., .FALSE. /)         
     110  ! is PFT C3 ? 
     111  LOGICAL, PARAMETER, DIMENSION(nvmc)    :: is_c3_mtc = &   
     112  & (/.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,         & 
     113  &   .FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE.,.TRUE.,.FALSE. /) 
     114 
     115  !------------------------------- 
     116  ! Evapotranspiration -  sechiba 
     117  !------------------------------- 
     118  ! 
     119  ! Structural resistance. 
     120  ! Value for rstruct_const : one for each vegetation type 
     121  REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: rstruct_const_mtc = & 
     122  & (/ 0.0, 25.0, 25.0, 25.0, 25.0, 25.0, 25.0,   & 
     123  &   25.0, 25.0,  2.5,  2.0,  2.0,  2.0 /) 
     124  !- 
     125  ! A vegetation dependent constant used in the calculation 
     126  ! of the surface resistance. 
     127  ! Value for kzero one for each vegetation type 
     128  REAL(r_std), PARAMETER, DIMENSION(nvmc)     ::  kzero_mtc  =  & 
     129  & (/0.0, 12.E-5, 12.E-5, 12.e-5, 12.e-5, 25.e-5, 12.e-5,& 
     130  &    25.e-5, 25.e-5, 30.e-5, 30.e-5, 30.e-5, 30.e-5     /) 
     131 
     132 
     133  !------------------- 
     134  ! Water - sechiba 
     135  !------------------- 
     136  ! 
     137  ! Maximum field capacity for each of the vegetations (Temporary). 
     138  ! Value of wmax_veg : max quantity of water : 
     139  ! one for each vegetation type en Kg/M3 
     140  REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: wmax_veg_mtc  = & 
     141  & (/ 150., 150., 150., 150., 150., 150., 150., & 
     142  &    150., 150., 150., 150., 150., 150. /) 
     143  !- 
     144  ! Root profile description for the different vegetation types. 
     145  ! These are the factor in the exponential which gets 
     146  ! the root density as a function of depth 
     147  REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: humcste_mtc  = & 
     148  & (/5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 4., 4., 4./) 
     149  ! used in both hydrology modules 
     150   REAL(r_std), PARAMETER, DIMENSION(nvmc)              :: throughfall_by_mtc = & 
     151  & (/ 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30. /) 
     152 
     153  !------------------ 
     154  ! Albedo - sechiba 
     155  !------------------ 
     156  ! 
     157  ! Initial snow albedo value for each vegetation type 
     158  ! as it will be used in condveg_snow 
     159  ! Values are from the Thesis of S. Chalita (1992) 
     160  REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: snowa_ini_mtc = & 
     161  & (/ 0.35, 0.,   0.,   0.14, 0.14, & 
     162  &    0.14, 0.14, 0.14, 0.14, 0.18, & 
     163  &    0.18, 0.18, 0.18 /) 
     164  !- 
     165  ! Decay rate of snow albedo value for each vegetation type 
     166  ! as it will be used in condveg_snow 
     167  ! Values are from the Thesis of S. Chalita (1992) 
     168  REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: snowa_dec_mtc = & 
     169  & (/ 0.45, 0.,   0.,   0.06, 0.06, & 
     170  &    0.11, 0.06, 0.11, 0.11, 0.52, & 
     171  &    0.52, 0.52, 0.52 /) 
     172  !- 
     173  ! leaf albedo of vegetation type, visible albedo 
     174  REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: alb_leaf_vis_mtc = & 
     175  & (/ .00, .04, .06, .06, .06, & 
     176  &    .06, .06, .06, .06, .10, & 
     177  &    .10, .10, .10 /)  
     178  ! leaf albedo of vegetation type, near infrared albedo 
     179  REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: alb_leaf_nir_mtc = & 
     180  & (/   .00, .20, .22, .22, .22, & 
     181  &      .22, .22, .22, .22, .30, & 
     182  &      .30, .30, .30   /) 
     183 
     184 
     185  !------------------------ 
     186  !   Soil - vegetation 
     187  !------------------------ 
     188  ! 
     189  ! Table which contains the correlation between the soil types 
     190  ! and vegetation type. Two modes exist : 
     191  !  1) pref_soil_veg = 0 then we have an equidistribution 
     192  !     of vegetation on soil types 
     193  !  2) Else for each pft the prefered soil type is given : 
     194  !     1=sand, 2=loan, 3=clay 
     195  ! The variable is initialized in slowproc. 
     196  INTEGER(i_std), PARAMETER, DIMENSION(nvmc)     :: pref_soil_veg_sand_mtc = & 
     197  & (/ 1, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 /) 
     198 
     199  INTEGER(i_std), PARAMETER, DIMENSION(nvmc)     :: pref_soil_veg_loan_mtc = & 
     200  & (/ 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 /) 
     201 
     202  INTEGER(i_std), PARAMETER, DIMENSION(nvmc)     :: pref_soil_veg_clay_mtc = & 
     203  & (/ 3, 1, 1, 1, 1, 1 ,1 ,1 ,1 ,1 ,1 ,1, 1 /) 
    97204 
    98205  !---------------- 
    … …  
    104211  ! flag for C4 vegetation types 
    105212  LOGICAL,PARAMETER, DIMENSION(nvmc) ::    is_c4_mtc  =        &   
    106   & (/.false.,.false.,.false.,.false.,.false.,.false.,         & 
    107   &   .false.,.false.,.false.,.false.,.true.,.false.,.true. /) 
     213  & (/.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,         & 
     214  &   .FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE.,.TRUE. /) 
    108215  !- 
    109216  ! Slope of the gs/A relation (Ball & al.) 
    … …  
    409516  & (/ undef,    5.,        5.,       5.,        5.,       5.,      5.,   & 
    410517  &              5.,        5.,    undef,     undef,    undef,   undef   /) 
     518 
     519  !>> DS new for merge in the trunk 
     520  ! 15/06/2011 : add leaflife_mtc for the new formalism used for calculate sla 
     521  REAL(r_std) ,PARAMETER , DIMENSION(nvmc)   ::   leaflife_mtc = & 
     522  & (/  undef,      .5,      2.,     .33,      1.,     2.,      .33,   & 
     523  &            2.,      2.,      2.,      2.,     2.,        2. /) 
     524 
    411525  !- 
    412526  ! 3. Senescence 
    … …  
    493607 
    494608 
    495   !------------------------------- 
    496   ! Evapotranspiration -  sechiba 
    497   !------------------------------- 
    498   ! 
    499   ! Structural resistance. 
    500   ! Value for rstruct_const : one for each vegetation type 
    501   REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: rstruct_const_mtc = & 
    502   & (/ 0.0, 25.0, 25.0, 25.0, 25.0, 25.0, 25.0,   & 
    503   &   25.0, 25.0,  2.5,  2.0,  2.0,  2.0 /) 
    504   !- 
    505   ! A vegetation dependent constant used in the calculation 
    506   ! of the surface resistance. 
    507   ! Value for kzero one for each vegetation type 
    508   REAL(r_std), PARAMETER, DIMENSION(nvmc)     ::  kzero_mtc  =  & 
    509   & (/0.0, 12.E-5, 12.E-5, 12.e-5, 12.e-5, 25.e-5, 12.e-5,& 
    510   &    25.e-5, 25.e-5, 30.e-5, 30.e-5, 30.e-5, 30.e-5     /) 
    511  
    512  
    513   !------------------- 
    514   ! Water - sechiba 
    515   !------------------- 
    516   ! 
    517   ! Maximum field capacity for each of the vegetations (Temporary). 
    518   ! Value of wmax_veg : max quantity of water : 
    519   ! one for each vegetation type en Kg/M3 
    520   REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: wmax_veg_mtc  = & 
    521   & (/ 150., 150., 150., 150., 150., 150., 150., & 
    522   &    150., 150., 150., 150., 150., 150. /) 
    523   !- 
    524   ! Root profile description for the different vegetation types. 
    525   ! These are the factor in the exponential which gets 
    526   ! the root density as a function of depth 
    527   REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: humcste_mtc  = & 
    528   & (/5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 4., 4., 4./) 
    529  
    530  
    531   !------------------ 
    532   ! Albedo - sechiba 
    533   !------------------ 
    534   ! 
    535   ! Initial snow albedo value for each vegetation type 
    536   ! as it will be used in condveg_snow 
    537   ! Values are from the Thesis of S. Chalita (1992) 
    538   REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: snowa_ini_mtc = & 
    539   & (/ 0.35, 0.,   0.,   0.14, 0.14, & 
    540   &    0.14, 0.14, 0.14, 0.14, 0.18, & 
    541   &    0.18, 0.18, 0.18 /) 
    542   !- 
    543   ! Decay rate of snow albedo value for each vegetation type 
    544   ! as it will be used in condveg_snow 
    545   ! Values are from the Thesis of S. Chalita (1992) 
    546   REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: snowa_dec_mtc = & 
    547   & (/ 0.45, 0.,   0.,   0.06, 0.06, & 
    548   &    0.11, 0.06, 0.11, 0.11, 0.52, & 
    549   &    0.52, 0.52, 0.52 /) 
    550   !- 
    551   ! leaf albedo of vegetation type, visible albedo 
    552   REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: alb_leaf_vis_mtc = & 
    553   & (/ .00, .04, .06, .06, .06, & 
    554   &    .06, .06, .06, .06, .10, & 
    555   &    .10, .10, .10 /)  
    556   ! leaf albedo of vegetation type, near infrared albedo 
    557   REAL(r_std), PARAMETER, DIMENSION(nvmc)     :: alb_leaf_nir_mtc = & 
    558   & (/   .00, .20, .22, .22, .22, & 
    559   &      .22, .22, .22, .22, .30, & 
    560   &      .30, .30, .30   /) 
    561  
    562  
    563   ! 
    564   !------------------------ 
    565   !   Soil - vegetation 
    566   !------------------------ 
    567  
    568   ! Table which contains the correlation between the soil types 
    569   ! and vegetation type. Two modes exist : 
    570   !  1) pref_soil_veg = 0 then we have an equidistribution 
    571   !     of vegetation on soil types 
    572   !  2) Else for each pft the prefered soil type is given : 
    573   !     1=sand, 2=loan, 3=clay 
    574   ! The variable is initialized in slowproc. 
    575   INTEGER(i_std), PARAMETER, DIMENSION(nvmc)     :: pref_soil_veg_sand_mtc = & 
    576   & (/ 1, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 /) 
    577  
    578   INTEGER(i_std), PARAMETER, DIMENSION(nvmc)     :: pref_soil_veg_loan_mtc = & 
    579   & (/ 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 /) 
    580  
    581   INTEGER(i_std), PARAMETER, DIMENSION(nvmc)     :: pref_soil_veg_clay_mtc = & 
    582   & (/ 3, 1, 1, 1, 1, 1 ,1 ,1 ,1 ,1 ,1 ,1, 1 /) 
    583  
    584  
    585   ! 
    586   !------------------------------- 
    587   ! Parameters already externalised (from sechiba) 
    588   ! to classify 
    589   !---------------------------------- 
    590   ! 
    591   ! used in hydrolc 
    592    REAL(r_std), PARAMETER, DIMENSION(nvmc)              :: throughfall_by_mtc = & 
    593   & (/ 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30. /) 
    594   ! used in diffuco 
    595    REAL(r_std), PARAMETER, DIMENSION(nvmc)        :: rveg_mtc = &   
    596   & (/ 1., 1., 1., 1., 1., 1. ,1. ,1. ,1. ,1. ,1. ,1., 1. /) 
    597  
    598  
     609!------------------------ 
    599610END MODULE constantes_mtc 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_parameters/pft_parameters.f90

    r115 r257  
    1 !    09/2010 
     1! Version 0:   26/06/2010 
    22! This is the module where we define the number of pfts and the values of the  
    33! parameters 
    … …  
    99USE constantes 
    1010USE ioipsl 
     11USE parallel 
    1112USE defprec 
    1213 
    … …  
    5051  ! Is the vegetation type a tree ? 
    5152  LOGICAL,ALLOCATABLE, SAVE, DIMENSION (:) :: is_tree 
     53  !>> DS new for merge in the trunk   ! 15/06/2011  
     54  ! Add for writing history files in stomate_lpj.f90 'treeFracPrimDec' and 'treeFracPrimEver' 
     55  ! is PFT deciduous ? 
     56  LOGICAL,ALLOCATABLE, SAVE, DIMENSION (:) :: is_deciduous 
     57  LOGICAL,ALLOCATABLE, SAVE, DIMENSION (:) :: is_evergreen 
     58  LOGICAL,ALLOCATABLE, SAVE, DIMENSION (:) :: is_c3 
     59  ! used in diffuco   !! Nathalie le 28 mars 2006 - sur proposition de Fred Hourdin, ajout 
     60  !! d'un potentiometre pour regler la resistance de la vegetation 
     61  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      ::  rveg_pft 
     62 
    5263  !- 
    5364  ! 2 .Stomate 
    … …  
    6172  LOGICAL, ALLOCATABLE, SAVE, DIMENSION (:) :: natural 
    6273 
     74  !------------------------------- 
     75  ! Evapotranspiration -  sechiba 
     76  !------------------------------- 
     77  !- 
     78  ! Structural resistance. 
     79  ! Value for rstruct_const : one for each vegetation type 
     80  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: rstruct_const 
     81  ! 
     82  ! A vegetation dependent constant used in the calculation 
     83  ! of the surface resistance. 
     84  ! Value for kzero one for each vegetation type 
     85  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: kzero   
     86 
     87 
     88  !------------------- 
     89  ! Water - sechiba 
     90  !------------------- 
     91  !- 
     92  ! Maximum field capacity for each of the vegetations (Temporary). 
     93  ! Value of wmax_veg : max quantity of water : 
     94  ! one for each vegetation type en Kg/M3 
     95  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: wmax_veg 
     96  ! Root profile description for the different vegetation types. 
     97  ! These are the factor in the exponential which gets 
     98  ! the root density as a function of depth 
     99  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: humcste 
     100  ! used in hydrolc 
     101  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: throughfall_by_pft 
     102 
     103 
     104  !------------------ 
     105  ! Albedo - sechiba 
     106  !------------------ 
     107  !- 
     108  ! Initial snow albedo value for each vegetation type 
     109  ! as it will be used in condveg_snow 
     110  ! Values are from the Thesis of S. Chalita (1992) 
     111  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snowa_ini 
     112  ! 
     113  ! Decay rate of snow albedo value for each vegetation type 
     114  ! as it will be used in condveg_snow 
     115  ! Values are from the Thesis of S. Chalita (1992) 
     116  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snowa_dec 
     117  ! 
     118  ! leaf albedo of vegetation type, visible albedo 
     119  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: alb_leaf_vis 
     120  ! leaf albedo of vegetation type, near infrared albedo 
     121  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: alb_leaf_nir 
     122  ! leaf albedo of vegetation type, VIS+NIR 
     123  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: alb_leaf 
     124 
     125 
     126  !------------------------ 
     127  !   Soil - vegetation 
     128  !------------------------ 
     129  ! 
     130  ! Table which contains the correlation between the soil types 
     131  ! and vegetation type. Two modes exist : 
     132  !  1) pref_soil_veg = 0 then we have an equidistribution 
     133  !     of vegetation on soil types 
     134  !  2) Else for each pft the prefered soil type is given : 
     135  !     1=sand, 2=loan, 3=clay 
     136  ! The variable is initialized in slowproc. 
     137  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: pref_soil_veg 
     138  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: pref_soil_veg_sand 
     139  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: pref_soil_veg_loan 
     140  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: pref_soil_veg_clay 
    63141 
    64142  !---------------- 
    … …  
    163241  ! for carbohydrate reserve, tabulated 
    164242  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) ::cm_zero_carbres 
     243 
    165244  
    166  
    167  
    168245  !---------------- 
    169246  ! Fire - stomate 
    170247  !---------------- 
    171  
     248  ! 
    172249  ! flamability: critical fraction of water holding capacity 
    173250  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: flam 
    174251  ! fire resistance 
    175252  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: resist 
    176  
    177253 
    178254 
    … …  
    195271  ! 1 .Stomate 
    196272  !- 
    197   ! 
    198273  ! maximum LAI, PFT-specific 
    199274  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: lai_max  
    … …  
    235310  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: alloc_max 
    236311  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: demi_alloc 
     312  !>> DS new for merge in the trunk 
     313  ! 15/06/2011 : add leaflife_mtc for the new formalism used for calculate sla 
     314  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: leaflife_tab 
    237315  !- 
    238316  ! 3. Senescence 
    … …  
    282360 
    283361 
    284   !------------------------------- 
    285   ! Evapotranspiration -  sechiba 
    286   !------------------------------- 
    287   !- 
    288   ! Structural resistance. 
    289   ! Value for rstruct_const : one for each vegetation type 
    290   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: rstruct_const 
    291   ! 
    292   ! A vegetation dependent constant used in the calculation 
    293   ! of the surface resistance. 
    294   ! Value for kzero one for each vegetation type 
    295   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: kzero   
    296  
    297  
    298   !------------------- 
    299   ! Water - sechiba 
    300   !------------------- 
    301   !- 
    302   ! Maximum field capacity for each of the vegetations (Temporary). 
    303   ! Value of wmax_veg : max quantity of water : 
    304   ! one for each vegetation type en Kg/M3 
    305   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: wmax_veg 
    306   ! Root profile description for the different vegetation types. 
    307   ! These are the factor in the exponential which gets 
    308   ! the root density as a function of depth 
    309   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: humcste 
    310  
    311  
    312   !------------------ 
    313   ! Albedo - sechiba 
    314   !------------------ 
    315   !- 
    316   ! Initial snow albedo value for each vegetation type 
    317   ! as it will be used in condveg_snow 
    318   ! Values are from the Thesis of S. Chalita (1992) 
    319   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snowa_ini 
    320   ! 
    321   ! Decay rate of snow albedo value for each vegetation type 
    322   ! as it will be used in condveg_snow 
    323   ! Values are from the Thesis of S. Chalita (1992) 
    324   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snowa_dec 
    325   ! 
    326   ! leaf albedo of vegetation type, visible albedo 
    327   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: alb_leaf_vis 
    328   ! leaf albedo of vegetation type, near infrared albedo 
    329   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: alb_leaf_nir 
    330   ! leaf albedo of vegetation type, VIS+NIR 
    331   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: alb_leaf 
    332  
    333  
    334   ! 
    335   !------------------------ 
    336   !   Soil - vegetation 
    337   !------------------------ 
    338  
    339   ! Table which contains the correlation between the soil types 
    340   ! and vegetation type. Two modes exist : 
    341   !  1) pref_soil_veg = 0 then we have an equidistribution 
    342   !     of vegetation on soil types 
    343   !  2) Else for each pft the prefered soil type is given : 
    344   !     1=sand, 2=loan, 3=clay 
    345   ! The variable is initialized in slowproc. 
    346   INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: pref_soil_veg 
    347   INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: pref_soil_veg_sand 
    348   INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: pref_soil_veg_loan 
    349   INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: pref_soil_veg_clay 
    350  
    351  
    352   ! 
    353362  !-------------------------------------------- 
    354363  ! Internal parameters used in stomate_data 
    … …  
    370379 
    371380 
    372   !------------------------------- 
    373   ! Parameters already externalised (from sechiba) 
    374   ! to classify 
    375   !---------------------------------- 
    376   ! 
    377   ! used in hydrolc and hydrol 
    378   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)   :: throughfall_by_pft 
    379   ! used in diffuco   !! Nathalie le 28 mars 2006 - sur proposition de Fred Hourdin, ajout 
    380   !! d'un potentiometre pour regler la resistance de la vegetation 
    381   REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      ::  rveg_pft 
    382  
    383381 
    384382CONTAINS 
    … …  
    397395   IF(l_first_define_pft) THEN 
    398396 
     397      ! 1. First time step 
    399398      IF(long_print) THEN 
    400399         WRITE(numout,*) 'l_first_define_pft :we read the parameters from the def files' 
    401400      ENDIF 
    402401 
     402      ! 2. Memory allocation 
    403403      ! Allocation of memory for the pfts-parameters 
    404404      CALL pft_parameters_alloc 
    405405 
     406      ! 3. Correspondance table  
     407       
     408      ! 3.1 Initialisation of the correspondance table 
    406409      ! Initialisation of the correspondance table 
    407410      pft_to_mtc (:) = undef_integer 
    408411       
    409       ! Reading of the conrrespondance table in the .def file 
    410       CALL getin('PFT_TO_MTC',pft_to_mtc) 
    411  
    412       ! Add the standard configuration 
     412      ! 3.2 Reading of the conrrespondance table in the .def file 
     413      CALL getin_p('PFT_TO_MTC',pft_to_mtc) 
     414 
     415      ! 3.3 If the user want to use the standard configuration, he needn't to fill the correspondance array 
     416      !     If the configuration is wrong, send a error message to the user. 
    413417      IF(nvm .EQ. 13 ) THEN 
    414418         IF(pft_to_mtc(1) .EQ. undef_integer) THEN 
    … …  
    422426      ENDIF 
    423427 
    424      ! What happened if pft_to_mtc(j) > nvmc (if the mtc doesn't exist)? 
     428      ! 3.4 Some error messages 
     429 
     430      ! 3.4.1 What happened if pft_to_mtc(j) > nvmc (if the mtc doesn't exist)? 
    425431       DO i = 1, nvm 
    426432          IF(pft_to_mtc(i) .GT. nvmc) THEN 
    … …  
    431437 
    432438 
    433       ! Verify if pft_to_mtc(1) = 1  
     439      ! 3.4.2 Check if pft_to_mtc(1) = 1  
    434440       IF(pft_to_mtc(1) .NE. 1) THEN 
    435441          WRITE(numout,*) 'the first pft has to be the bare soil' 
    … …  
    445451       
    446452    
    447       ! Initialisation of the pfts-parameters 
     453      ! 4.Initialisation of the pfts-parameters 
    448454      CALL pft_parameters_init 
    449455 
    450       ! Could be useful : correspondance between the number of the pft 
     456      ! 5. A useful message to the user: correspondance between the number of the pft 
    451457      ! and the name of the associated mtc  
    452458      DO i = 1,nvm 
    … …  
    454460      ENDDO 
    455461 
    456  
    457       !------------------------------------------------------! 
    458       ! Initialisation of tables 2D  which are used in the code ! 
    459       !------------------------------------------------------! 
    460       ! 
     462      ! 6. Initialisation of 2D arrays used in the code 
     463 
     464      !-alb_leaf 
     465      alb_leaf(:) = zero 
     466 
     467      !- pref_soil_veg  
     468      pref_soil_veg(:,:) = zero_int 
     469 
    461470      !- pheno_gdd_crit 
    462471      pheno_gdd_crit(:,:) = zero  
    … …  
    470479      !-coeff_maint_zero 
    471480      coeff_maint_zero(:,:) = zero 
    472       ! 
    473       !-alb_leaf 
    474       alb_leaf(:) = zero 
    475       !- pref_soil_veg (see slowproc) 
     481 
     482      ! 7. End message 
     483      IF(long_print) THEN 
     484         WRITE(numout,*) 'pft_parameters_done' 
     485      ENDIF 
    476486 
    477487   ELSE  
    478488 
    479        l_first_define_pft = .FALSE. 
     489      l_first_define_pft = .FALSE. 
    480490        
    481        RETURN 
     491      RETURN 
    482492 
    483493   ENDIF 
    … …  
    496506   !------------ 
    497507 
    498    ! Initialisation !! not all the parameters are initialized  
    499  
    500    !---------------------- 
     508   ! 
     509   ! 1. Initialisation !! not all the parameters are initialized  
     510   ! 
     511 
     512   !- 
    501513   ! Vegetation structure  
    502    !---------------------- 
    503    !- 
     514   !- 
     515   ! 
    504516   ! 1 .Sechiba 
    505    !- 
     517   ! 
    506518   veget_ori_fixed_test_1(:) = zero 
    507519   llaimax(:) = zero 
    508520   llaimin(:) = zero 
    509521   height_presc(:) = zero 
    510    !- 
     522   rveg_pft(:) = zero 
     523   ! 
    511524   ! 2 .Stomate 
    512525   ! 
    513526   leaf_tab(:) = zero_int 
    514527   sla(:) = zero    
    515    !---------------- 
     528   !- 
     529   ! Evapotranspiration -  sechiba 
     530   !- 
     531   rstruct_const(:) = zero 
     532   kzero(:) = zero 
     533   !- 
     534   ! Water - sechiba 
     535   !- 
     536   wmax_veg(:) = zero 
     537   humcste(:) = zero 
     538   throughfall_by_pft(:) = zero 
     539   !- 
     540   ! Albedo - sechiba 
     541   !- 
     542   snowa_ini(:) = zero 
     543   snowa_dec(:) = zero 
     544   alb_leaf_vis(:) = zero 
     545   alb_leaf_nir(:) = zero 
     546   !- 
     547   ! Soil - vegetation 
     548   !- 
     549   pref_soil_veg_sand(:) = zero_int 
     550   pref_soil_veg_loan(:) = zero_int 
     551   pref_soil_veg_clay(:) = zero_int 
     552   !- 
    516553   ! Photosynthesis 
    517    !---------------- 
    518    !- 
     554   !- 
     555   ! 
    519556   ! 1 .CO2 
    520    !- 
     557   ! 
    521558   gsslope(:) = zero 
    522559   gsoffset(:) = zero 
    … …  
    526563   co2_topt_fix(:) = zero 
    527564   co2_tmax_fix(:) = zero 
    528    !- 
     565   ext_coeff(:) = zero 
     566   ! 
    529567   ! 2 .Stomate 
    530    !- 
    531    ext_coeff(:) = zero 
     568   ! 
    532569   vcmax_opt(:) = zero 
    533570   vjmax_opt(:) = zero 
    … …  
    541578   tphoto_max_b(:) = zero 
    542579   tphoto_max_c(:) = zero 
    543    !---------------------- 
     580   !- 
    544581   ! Respiration - stomate 
    545    !---------------------- 
    546    ! 
     582   !- 
    547583   maint_resp_slope_c(:) = zero 
    548584   maint_resp_slope_b(:) = zero 
    … …  
    556592   cm_zero_fruit(:) = zero 
    557593   cm_zero_carbres(:) = zero 
    558    !---------------- 
     594   !- 
    559595   ! Fire - stomate 
    560    !--------------- 
     596   !- 
    561597   !  
    562598   flam(:) = zero 
    563599   resist(:) = zero 
    564    !---------------- 
     600   !- 
    565601   ! Flux - LUC 
    566    !--------------- 
    567    ! 
     602   !- 
    568603   coeff_lcchange_1(:) = zero 
    569604   coeff_lcchange_10(:) = zero 
    570605   coeff_lcchange_100(:) = zero 
    571    ! 
    572    !----------- 
     606   !- 
    573607   ! Phenology 
    574    !----------- 
    575    !- 
     608   !- 
     609   ! 
    576610   ! 1 .Stomate 
    577    !- 
     611   ! 
    578612   lai_max(:) = zero 
    579613   pheno_type(:) = zero_int 
    580    !- 
     614   ! 
    581615   ! 2. Leaf Onset 
    582    !- 
     616   ! 
    583617   pheno_gdd_crit_c(:) = zero 
    584618   pheno_gdd_crit_b(:) = zero 
    … …  
    595629   alloc_max(:) = zero 
    596630   demi_alloc(:) = zero   
    597    !- 
     631  !>> DS new for merge in the trunk 15/06/2011 
     632   leaflife_tab(:) = zero 
     633   ! 
    598634   ! 3. Senescence 
    599    !- 
     635   ! 
    600636   leaffall(:) = zero 
    601637   leafagecrit(:) = zero 
    … …  
    608644   senescence_temp_b(:) = zero  
    609645   senescence_temp_a(:) = zero  
    610    !----------- 
     646   !- 
    611647   ! DGVM 
    612    !----------- 
    613    ! 
     648   !- 
    614649   residence_time(:) = zero 
    615650   tmin_crit(:) = zero 
    616651   tcm_crit(:) = zero 
    617    !------------------------------- 
    618    ! Evapotranspiration -  sechiba 
    619    !------------------------------- 
    620    !- 
    621    rstruct_const(:) = zero 
    622    kzero(:) = zero 
    623    !------------------- 
    624    ! Water - sechiba 
    625    !------------------- 
    626    !- 
    627    wmax_veg(:) = zero 
    628    humcste(:) = zero 
    629    !------------------ 
    630    ! Albedo - sechiba 
    631    !------------------ 
    632    !- 
    633    snowa_ini(:) = zero 
    634    snowa_dec(:) = zero 
    635    alb_leaf_vis(:) = zero 
    636    alb_leaf_nir(:) = zero 
    637    !------------------------ 
    638    !   Soil - vegetation 
    639    !------------------------ 
    640    pref_soil_veg(:,:) = zero_int 
    641  
    642    !------------------------ 
     652   !- 
    643653   !  Internal_parameters 
    644    !------------------------ 
     654   !- 
    645655   lai_initmin(:) = zero 
    646656   bm_sapl(:,:) = zero 
    … …  
    649659   cn_sapl(:) = zero 
    650660   leaf_timecst(:) = zero   
    651    !------------------------------- 
    652    ! Parameters already externalised (from sechiba) 
    653    ! to classify 
    654    !---------------------------------- 
    655    throughfall_by_pft(:) = zero 
    656    rveg_pft(:) = zero 
    657  
    658  
    659    !-------------------------------------------------------------! 
    660    ! Correspondance between the PFTs values and thes MTCs values ! 
    661    !-------------------------------------------------------------!   
     661 
     662 
     663   ! 
     664   ! 2. Correspondance between the PFTs values and thes MTCs values  
     665   ! 
    662666  
    663667   DO j= 1, nvm 
    … …  
    666670      PFT_name(j) = MTC_name(pft_to_mtc(j)) 
    667671 
    668       !---------------------- 
     672      !- 
    669673      ! Vegetation structure  
    670       !---------------------- 
    671       !- 
     674      !- 
     675      ! 
    672676      ! 1 .Sechiba 
    673       !- 
     677      ! 
    674678      veget_ori_fixed_test_1(j) = veget_ori_fixed_mtc(pft_to_mtc(j)) 
    675679      llaimax(j) = llaimax_mtc(pft_to_mtc(j)) 
    … …  
    678682      type_of_lai(j) = type_of_lai_mtc(pft_to_mtc(j)) 
    679683      is_tree(j) = is_tree_mtc(pft_to_mtc(j)) 
    680       !- 
     684      rveg_pft(j) = rveg_mtc(pft_to_mtc(j)) 
     685 
     686      !>> DS new for merge in the trunk   ! 15/06/2011  
     687      ! Add for writing history files in stomate_lpj.f90 'treeFracPrimDec' and 'treeFracPrimEver' 
     688      is_deciduous(j) = is_deciduous_mtc(pft_to_mtc(j)) 
     689      is_evergreen(j) = is_evergreen_mtc(pft_to_mtc(j)) 
     690      is_c3(j) = is_c3(pft_to_mtc(j)) 
     691 
     692      ! 
    681693      ! 2 .Stomate 
    682       !-  
     694      ! 
    683695      leaf_tab(j) = leaf_tab_mtc(pft_to_mtc(j)) 
    684696      sla(j) = sla_mtc(pft_to_mtc(j)) 
    685697      natural(j) = natural_mtc(pft_to_mtc(j)) 
    686       !---------------- 
     698 
     699      !- 
     700      ! Evapotranspiration -  sechiba 
     701      !- 
     702      rstruct_const(j) = rstruct_const_mtc(pft_to_mtc(j)) 
     703      kzero(j) = kzero_mtc(pft_to_mtc(j)) 
     704      !- 
     705      ! Water - sechiba 
     706      !- 
     707      wmax_veg(j) = wmax_veg_mtc(pft_to_mtc(j)) 
     708      humcste(j) = humcste_mtc(pft_to_mtc(j)) 
     709      throughfall_by_pft(j) = throughfall_by_mtc(pft_to_mtc(j)) 
     710      !- 
     711      ! Albedo - sechiba 
     712      !- 
     713      snowa_ini(j) = snowa_ini_mtc(pft_to_mtc(j)) 
     714      snowa_dec(j) = snowa_dec_mtc(pft_to_mtc(j))  
     715      alb_leaf_vis(j) = alb_leaf_vis_mtc(pft_to_mtc(j))   
     716      alb_leaf_nir(j) = alb_leaf_nir_mtc(pft_to_mtc(j)) 
     717      !- 
     718      !   Soil - vegetation 
     719      !- 
     720      pref_soil_veg_sand(j) = pref_soil_veg_sand_mtc(pft_to_mtc(j)) 
     721      pref_soil_veg_loan(j) = pref_soil_veg_loan_mtc(pft_to_mtc(j)) 
     722      pref_soil_veg_clay(j) = pref_soil_veg_clay_mtc(pft_to_mtc(j)) 
     723 
     724      !- 
    687725      ! Photosynthesis 
    688       !---------------- 
    689       !- 
     726      !- 
     727      ! 
    690728      ! 1 .CO2 
    691       !- 
     729      ! 
    692730      is_c4(j) = is_c4_mtc(pft_to_mtc(j)) 
    693731      gsslope(j) = gsslope_mtc(pft_to_mtc(j)) 
    … …  
    698736      co2_topt_fix(j) = co2_topt_fix_mtc(pft_to_mtc(j)) 
    699737      co2_tmax_fix(j) = co2_tmax_fix_mtc(pft_to_mtc(j)) 
    700       !- 
     738      ! 
    701739      ! 2 .Stomate 
    702       !- 
     740      ! 
    703741      ext_coeff(j) = ext_coeff_mtc(pft_to_mtc(j)) 
    704742      vcmax_opt(j) = vcmax_opt_mtc(pft_to_mtc(j)) 
    … …  
    713751      tphoto_max_b(j) = tphoto_max_b_mtc(pft_to_mtc(j)) 
    714752      tphoto_max_c(j) = tphoto_max_c_mtc(pft_to_mtc(j)) 
    715       !---------------------- 
     753      !- 
    716754      ! Respiration - stomate 
    717       !---------------------- 
     755      !- 
    718756      maint_resp_slope_c(j) = maint_resp_slope_c_mtc(pft_to_mtc(j))                
    719757      maint_resp_slope_b(j) = maint_resp_slope_b_mtc(pft_to_mtc(j)) 
    … …  
    727765      cm_zero_fruit(j) = cm_zero_fruit_mtc(pft_to_mtc(j)) 
    728766      cm_zero_carbres(j) = cm_zero_carbres_mtc(pft_to_mtc(j)) 
    729       !---------------- 
     767      !- 
    730768      ! Fire - stomate 
    731       !--------------- 
     769      !- 
    732770      flam(j) = flam_mtc(pft_to_mtc(j)) 
    733771      resist(j) = resist_mtc(pft_to_mtc(j)) 
    734       !---------------- 
     772      !- 
    735773      ! Flux - LUC 
    736       !--------------- 
     774      !- 
    737775      coeff_lcchange_1(j) = coeff_lcchange_1_mtc(pft_to_mtc(j)) 
    738776      coeff_lcchange_10(j) = coeff_lcchange_10_mtc(pft_to_mtc(j)) 
    739777      coeff_lcchange_100(j) = coeff_lcchange_100_mtc(pft_to_mtc(j)) 
    740       !----------- 
     778      !- 
    741779      ! Phenology 
    742       !----------- 
    743       !- 
     780      !- 
     781      ! 
    744782      ! 1 .Stomate 
    745       !- 
     783      ! 
    746784      lai_max(j) = lai_max_mtc(pft_to_mtc(j)) 
    747785      pheno_model(j) = pheno_model_mtc(pft_to_mtc(j)) 
    748786      pheno_type(j) = pheno_type_mtc(pft_to_mtc(j)) 
    749       !- 
     787      ! 
    750788      ! 2. Leaf Onset 
    751       !- 
     789      ! 
    752790      pheno_gdd_crit_c(j) = pheno_gdd_crit_c_mtc(pft_to_mtc(j)) 
    753791      pheno_gdd_crit_b(j) = pheno_gdd_crit_b_mtc(pft_to_mtc(j))          
    … …  
    764802      alloc_max(j) = alloc_max_mtc(pft_to_mtc(j)) 
    765803      demi_alloc(j) = demi_alloc_mtc(pft_to_mtc(j)) 
    766       !- 
     804  !>> DS new for merge in the trunk   ! 15/06/2011  
     805      leaflife_tab(j) = leaflife_mtc(pft_to_mtc(j)) 
     806      ! 
    767807      ! 3. Senescence 
    768       !- 
     808      ! 
    769809      leaffall(j) = leaffall_mtc(pft_to_mtc(j)) 
    770810      leafagecrit(j) = leafagecrit_mtc(pft_to_mtc(j)) 
    … …  
    778818      senescence_temp_b(j) = senescence_temp_b_mtc(pft_to_mtc(j)) 
    779819      senescence_temp_a(j) = senescence_temp_a_mtc(pft_to_mtc(j)) 
    780       !----------- 
     820      !- 
    781821      ! DGVM 
    782       !----------- 
    783822      residence_time(j) = residence_time_mtc(pft_to_mtc(j)) 
    784823      tmin_crit(j) = tmin_crit_mtc(pft_to_mtc(j)) 
    785824      tcm_crit(j) =  tcm_crit_mtc(pft_to_mtc(j)) 
    786825       
    787       !------------------------------- 
    788       ! Evapotranspiration -  sechiba 
    789       !------------------------------- 
    790       !- 
    791       rstruct_const(j) = rstruct_const_mtc(pft_to_mtc(j)) 
    792       kzero(j) = kzero_mtc(pft_to_mtc(j)) 
    793       !------------------- 
    794       ! Water - sechiba 
    795       !------------------- 
    796       !- 
    797       wmax_veg(j) = wmax_veg_mtc(pft_to_mtc(j)) 
    798       humcste(j) = humcste_mtc(pft_to_mtc(j)) 
    799       !------------------ 
    800       ! Albedo - sechiba 
    801       !------------------ 
    802       !- 
    803       snowa_ini(j) = snowa_ini_mtc(pft_to_mtc(j)) 
    804       snowa_dec(j) = snowa_dec_mtc(pft_to_mtc(j))  
    805       alb_leaf_vis(j) = alb_leaf_vis_mtc(pft_to_mtc(j))   
    806       alb_leaf_nir(j) = alb_leaf_nir_mtc(pft_to_mtc(j)) 
    807       !------------------------ 
    808       !   Soil - vegetation 
    809       !------------------------ 
    810       pref_soil_veg_sand(j) = pref_soil_veg_sand_mtc(pft_to_mtc(j)) 
    811       pref_soil_veg_loan(j) = pref_soil_veg_loan_mtc(pft_to_mtc(j)) 
    812       pref_soil_veg_clay(j) = pref_soil_veg_clay_mtc(pft_to_mtc(j)) 
    813       !------------------------------- 
    814       ! Parameters already externalised (from sechiba) 
    815       ! to classify 
    816       !----------------------------------  
    817       throughfall_by_pft(j) = throughfall_by_mtc(pft_to_mtc(j)) 
    818       rveg_pft(j) = rveg_mtc(pft_to_mtc(j)) 
    819  
    820   ! end loop over nvm     
    821    ENDDO 
     826   ENDDO ! end loop over nvm  
    822827 
    823828 END SUBROUTINE pft_parameters_init 
    … …  
    840845   l_error = l_error .OR. (ier .NE. 0) 
    841846   !- 
     847   !>> DS new for merge in the trunk   ! 15/06/2011  
     848   ! Add for writing history files in stomate_lpj.f90 'treeFracPrimDec' and 'treeFracPrimEver' 
     849   ALLOCATE(is_deciduous(nvm),stat=ier)    
     850   l_error = l_error .OR. (ier .NE. 0) 
     851   ALLOCATE(is_evergreen(nvm),stat=ier)   
     852   l_error = l_error .OR. (ier .NE. 0) 
     853   ALLOCATE(is_c3(nvm),stat=ier)   
     854   l_error = l_error .OR. (ier .NE. 0) 
     855   ALLOCATE(leaflife_tab(nvm),stat=ier)    
     856   l_error = l_error .OR. (ier .NE. 0) 
     857   ! >> END 
     858 
    842859   ALLOCATE(veget_ori_fixed_test_1(nvm),stat=ier) 
    843860   l_error = l_error .OR. (ier .NE. 0) 
    … …  
    10661083 
    10671084 END SUBROUTINE pft_parameters_alloc 
     1085! 
     1086!= 
     1087! 
     1088 SUBROUTINE getin_sechiba_pft_parameters 
     1089 
     1090   IMPLICIT NONE 
     1091   
     1092   LOGICAL, SAVE ::  first_call = .TRUE. 
     1093 
     1094  IF(first_call) THEN 
     1095 
     1096     ! No calling to getin for veget_ori_fixed_test_1, llaimax and height_presc 
     1097     ! use of setvar in slowproc.f90 
     1098 
     1099     !- 
     1100     ! Vegetation structure 
     1101     !- 
     1102     CALL getin_p('LLAIMIN',llaimin) 
     1103     CALL getin('TYPE_OF_LAI',type_of_lai) 
     1104     CALL getin_p('IS_TREE',is_tree) 
     1105     CALL getin_p('NATURAL',natural) 
     1106 
     1107     !>> DS new for merge in the trunk   ! 15/06/2011  
     1108     ! Add for writing history files in stomate_lpj.f90 'treeFracPrimDec' and 'treeFracPrimEver' 
     1109     CALL getin('IS_DECIDUOUS',is_deciduous) 
     1110     CALL getin('IS_EVERGREEN',is_evergreen)   
     1111     CALL getin_p('IS_C3',is_c3)    
     1112 
     1113     !- 
     1114     ! Photosynthesis 
     1115     !- 
     1116     CALL getin_p('IS_C4',is_c4) 
     1117     CALL getin_p('GSSLOPE',gsslope) 
     1118     CALL getin_p('GSOFFSET',gsoffset) 
     1119     CALL getin_p('VCMAX_FIX',vcmax_fix) 
     1120     CALL getin_p('VJMAX_FIX',vjmax_fix) 
     1121     CALL getin_p('CO2_TMIN_FIX',co2_tmin_fix) 
     1122     CALL getin_p('CO2_TOPT_FIX',co2_topt_fix) 
     1123     CALL getin_p('CO2_TMAX_FIX',co2_tmax_fix) 
     1124     CALL getin_p('EXT_COEFF',ext_coeff) 
     1125     !- 
     1126     ! Evapotranspiration -  sechiba 
     1127     !- 
     1128     CALL getin_p('RSTRUCT_CONST',rstruct_const) 
     1129     CALL getin_p('KZERO',kzero) 
     1130     CALL getin_p('RVEG_PFT', rveg_pft)     
     1131     !- 
     1132     ! Water-hydrology - sechiba 
     1133     !- 
     1134     CALL getin_p('WMAX_VEG',wmax_veg) 
     1135     CALL getin_p('HYDROL_HUMCSTE', humcste) 
     1136     CALL getin_p('PERCENT_TROUGHFALL_PFT',throughfall_by_pft) 
     1137     !- 
     1138     ! Albedo - sechiba 
     1139     !- 
     1140     CALL getin_p('SNOWA_INI',snowa_ini) 
     1141     CALL getin_p('SNOWA_DEC',snowa_dec) 
     1142     CALL getin_p('ALB_LEAF_VIS',alb_leaf_vis) 
     1143     CALL getin_p('ALB_LEAF_NIR',alb_leaf_nir) 
     1144     !- 
     1145     ! Soil - vegetation 
     1146     !- 
     1147     CALL getin_p('PREF_SOIL_VEG_SAND',pref_soil_veg_sand) 
     1148     CALL getin_p('PREF_SOIL_VEG_LOAN',pref_soil_veg_loan)          
     1149     CALL getin_p('PREF_SOIL_VEG_CLAY',pref_soil_veg_clay) 
     1150 
     1151     first_call = .FALSE. 
     1152 
     1153  ENDIF 
     1154 
     1155END SUBROUTINE getin_sechiba_pft_parameters 
     1156! 
     1157!= 
     1158! 
     1159SUBROUTINE getin_stomate_pft_parameters 
     1160 
     1161  IMPLICIT NONE 
     1162 
     1163  LOGICAL, SAVE ::  first_call = .TRUE. 
     1164 
     1165  IF(first_call) THEN 
     1166 
     1167      !- 
     1168      ! Vegetation structure 
     1169      !- 
     1170      CALL getin_p('LEAF_TAB',leaf_tab) 
     1171      CALL getin_p('SLA',sla) 
     1172      !- 
     1173      ! Photosynthesis 
     1174      !- 
     1175      CALL getin_p('VCMAX_OPT',vcmax_opt) 
     1176      CALL getin_p('VJMAX_OPT',vjmax_opt) 
     1177      CALL getin_p('TPHOTO_MIN_A',tphoto_min_a) 
     1178      CALL getin_p('TPHOTO_MIN_B',tphoto_min_b) 
     1179      CALL getin_p('TPHOTO_MIN_C',tphoto_min_c) 
     1180      CALL getin_p('TPHOTO_OPT_A',tphoto_opt_a) 
     1181      CALL getin_p('TPHOTO_OPT_B',tphoto_opt_b) 
     1182      CALL getin_p('TPHOTO_OPT_C',tphoto_opt_c) 
     1183      CALL getin_p('TPHOTO_MAX_A',tphoto_max_a) 
     1184      CALL getin_p('TPHOTO_MAX_B',tphoto_max_b) 
     1185      CALL getin_p('TPHOTO_MAX_C',tphoto_max_c) 
     1186      !- 
     1187      ! Respiration - stomate 
     1188      !- 
     1189      CALL getin_p('MAINT_RESP_SLOPE_C',maint_resp_slope_c)  
     1190      CALL getin_p('MAINT_RESP_SLOPE_B',maint_resp_slope_b) 
     1191      CALL getin_p('MAINT_RESP_SLOPE_A',maint_resp_slope_a) 
     1192      CALL getin_p('CM_ZERO_LEAF',cm_zero_leaf) 
     1193      CALL getin_p('CM_ZERO_SAPABOVE',cm_zero_sapabove) 
     1194      CALL getin_p('CM_ZERO_SAPBELOW',cm_zero_sapbelow) 
     1195      CALL getin_p('CM_ZERO_HEARTABOVE',cm_zero_heartabove) 
     1196      CALL getin_p('CM_ZERO_HEARTBELOW',cm_zero_heartbelow) 
     1197      CALL getin_p('CM_ZERO_ROOT',cm_zero_root) 
     1198      CALL getin_p('CM_ZERO_FRUIT',cm_zero_fruit) 
     1199      CALL getin_p('CM_ZERO_CARBRES',cm_zero_carbres) 
     1200      !- 
     1201      ! Fire - stomate 
     1202      !- 
     1203      CALL getin_p('FLAM',flam) 
     1204      CALL getin_p('RESIST',resist) 
     1205      !- 
     1206      ! Flux - LUC 
     1207      !- 
     1208      CALL getin_p('COEFF_LCCHANGE_1',coeff_lcchange_1) 
     1209      CALL getin_p('COEFF_LCCHANGE_10',coeff_lcchange_10) 
     1210      CALL getin_p('COEFF_LCCHANGE_100',coeff_lcchange_100) 
     1211      !- 
     1212      ! Phenology 
     1213      !- 
     1214      CALL getin_p('LAI_MAX',lai_max) 
     1215      CALL getin('PHENO_MODEL',pheno_model) 
     1216      CALL getin_p('PHENO_TYPE',pheno_type) 
     1217      !- 
     1218      ! Phenology : Leaf Onset 
     1219      !- 
     1220      CALL getin_p('PHENO_GDD_CRIT_C',pheno_gdd_crit_c) 
     1221      CALL getin_p('PHENO_GDD_CRIT_B',pheno_gdd_crit_b) 
     1222      CALL getin_p('PHENO_GDD_CRIT_A',pheno_gdd_crit_a) 
     1223      CALL getin_p('NGD_CRIT',ngd_crit) 
     1224      CALL getin_p('NCDGDD_TEMP', ncdgdd_temp) 
     1225      CALL getin_p('HUM_FRAC', hum_frac) 
     1226      CALL getin_p('LOWGPP_TIME', lowgpp_time) 
     1227      CALL getin_p('HUM_MIN_TIME', hum_min_time) 
     1228      CALL getin_p('TAU_SAP',tau_sap) 
     1229      CALL getin_p('TAU_FRUIT',tau_fruit) 
     1230      CALL getin_p('ECUREUIL',ecureuil) 
     1231      CALL getin_p('ALLOC_MIN',alloc_min) 
     1232      CALL getin_p('ALLOC_MAX',alloc_max) 
     1233      CALL getin_p('DEMI_ALLOC',demi_alloc) 
     1234 
     1235      !>> DS new for merge in the trunk 
     1236      ! 15/06/2011 : add leaflife_mtc for the new formalism used for calculate sla 
     1237      CALL getin_p('LEAFLIFE_TAB',leaflife_tab) 
     1238 
     1239      !- 
     1240      ! Phenology : Senescence 
     1241      !- 
     1242      CALL getin_p('LEAFFALL',leaffall) 
     1243      CALL getin_p('LEAFAGECRIT',leafagecrit)   
     1244      CALL getin('SENESCENCE_TYPE', senescence_type)  
     1245      CALL getin_p('SENESCENCE_HUM', senescence_hum) 
     1246      CALL getin_p('NOSENESCENCE_HUM', nosenescence_hum)  
     1247      CALL getin_p('MAX_TURNOVER_TIME',max_turnover_time) 
     1248      CALL getin_p('MIN_TURNOVER_TIME',min_turnover_time) 
     1249      CALL getin_p('MIN_LEAF_AGE_FOR_SENESCENCE', min_leaf_age_for_senescence) 
     1250      CALL getin_p('SENESCENCE_TEMP_C',senescence_temp_c) 
     1251      CALL getin_p('SENESCENCE_TEMP_B',senescence_temp_b) 
     1252      CALL getin_p('SENESCENCE_TEMP_A',senescence_temp_a) 
     1253      !- 
     1254      ! DGVM 
     1255      !- 
     1256      CALL getin_p('RESIDENCE_TIME',residence_time) 
     1257      CALL getin_p('TMIN_CRIT',tmin_crit) 
     1258      CALL getin_p('TCM_CRIT',tcm_crit) 
     1259       
     1260     first_call = .FALSE. 
     1261        
     1262  ENDIF 
     1263   
     1264END SUBROUTINE getin_stomate_pft_parameters 
    10681265 ! 
    10691266 != 
    10701267 ! 
    10711268 SUBROUTINE pft_parameters_clear 
    1072  
     1269    
    10731270   l_first_define_pft = .TRUE. 
    1074  
     1271    
    10751272   IF(ALLOCATED(pft_to_mtc))DEALLOCATE(pft_to_mtc) 
    10761273   IF(ALLOCATED(PFT_name))DEALLOCATE(PFT_name) 
     1274   !- 
     1275   !>> DS new for merge in the trunk   ! 15/06/2011  
     1276   ! Add for writing history files in stomate_lpj.f90 'treeFracPrimDec' and 'treeFracPrimEver' 
     1277   IF(ALLOCATED(is_deciduous))DEALLOCATE(is_deciduous) 
     1278   IF(ALLOCATED(is_evergreen))DEALLOCATE(is_evergreen) 
     1279   IF(ALLOCATED(leaflife_tab))DEALLOCATE(leaflife_tab) 
     1280   IF(ALLOCATED(is_c3))DEALLOCATE(is_c3)   
    10771281   !- 
    10781282   IF(ALLOCATED(veget_ori_fixed_test_1))DEALLOCATE(veget_ori_fixed_test_1)    
    … …  
    11941398   !- 
    11951399   IF(ALLOCATED(throughfall_by_pft))DEALLOCATE(throughfall_by_pft) 
    1196    IF (ALLOCATED(rveg_pft))DEALLOCATE(rveg_pft) 
    1197  
     1400   IF(ALLOCATED(rveg_pft))DEALLOCATE(rveg_pft) 
     1401    
    11981402 END SUBROUTINE pft_parameters_clear 
    1199 ! 
    1200 != 
    1201 ! 
    1202  SUBROUTINE getin_sechiba_pft_parameters 
    1203  
    1204    IMPLICIT NONE 
    1205    
    1206    LOGICAL, SAVE ::  first_call = .TRUE. 
    1207  
    1208   IF(first_call) THEN 
    1209  
    1210      !---------------------- 
    1211      ! Vegetation structure 
    1212      !--------------------- 
    1213      !       
    1214      CALL getin('LLAIMIN',llaimin) 
    1215      CALL getin('TYPE_OF_LAI',type_of_lai) 
    1216      CALL getin('IS_TREE',is_tree) 
    1217      ! No calling to getin for 
    1218      ! veget_ori_fixed_test_1, llaimax and height_presc 
    1219      ! use of setvar in slowproc.f90 
    1220       
    1221      !----------------- 
    1222      ! Photosynthesis 
    1223      !----------------- 
    1224      !- 
    1225      CALL getin('IS_C4',is_c4) 
    1226      CALL getin('GSSLOPE',gsslope) 
    1227      CALL getin('GSOFFSET',gsoffset) 
    1228      CALL getin('VCMAX_FIX',vcmax_fix) 
    1229      CALL getin('VJMAX_FIX',vjmax_fix) 
    1230      CALL getin('CO2_TMIN_FIX',co2_tmin_fix) 
    1231      CALL getin('CO2_TOPT_FIX',co2_topt_fix) 
    1232      CALL getin('CO2_TMAX_FIX',co2_tmax_fix) 
    1233      CALL getin('EXT_COEFF',ext_coeff) 
    1234      !------------------------------- 
    1235      ! Evapotranspiration -  sechiba 
    1236      !------------------------------- 
    1237      ! 
    1238      CALL getin('RSTRUCT_CONST',rstruct_const) 
    1239      CALL getin('KZERO',kzero) 
    1240      CALL getin('RVEG_PFT', rveg_pft)     
    1241      !--------------------------- 
    1242      ! Water-hydrology - sechiba 
    1243      !--------------------------- 
    1244      ! 
    1245      CALL getin('WMAX_VEG',wmax_veg) 
    1246      CALL getin('HYDROL_HUMCSTE', humcste) 
    1247      CALL getin('PERCENT_TROUGHFALL_PFT',throughfall_by_pft) 
    1248      !------------------ 
    1249      ! Albedo - sechiba 
    1250      !------------------ 
    1251      ! 
    1252      CALL getin('SNOWA_INI',snowa_ini) 
    1253      CALL getin('SNOWA_DEC',snowa_dec) 
    1254      CALL getin('ALB_LEAF_VIS',alb_leaf_vis) 
    1255      CALL getin('ALB_LEAF_NIR',alb_leaf_nir) 
    1256  
    1257      !------------------------ 
    1258      !   Soil - vegetation 
    1259      !------------------------  
    1260      ! 
    1261      CALL getin('PREF_SOIL_VEG_SAND',pref_soil_veg_sand) 
    1262      CALL getin('PREF_SOIL_VEG_LOAN',pref_soil_veg_loan)          
    1263      CALL getin('PREF_SOIL_VEG_CLAY',pref_soil_veg_clay) 
    1264  
    1265      first_call = .FALSE. 
    1266  
    1267   ENDIF 
    1268  
    1269 END SUBROUTINE getin_sechiba_pft_parameters 
    1270 ! 
    1271 != 
    1272 ! 
    1273 SUBROUTINE getin_stomate_pft_parameters 
    1274  
    1275   IMPLICIT NONE 
    1276  
    1277   LOGICAL, SAVE ::  first_call = .TRUE. 
    1278  
    1279   IF(first_call) THEN 
    1280  
    1281      !---------------------- 
    1282      ! Vegetation structure 
    1283      !--------------------- 
    1284      ! 
    1285      CALL getin('LEAF_TAB',leaf_tab) 
    1286      CALL getin('SLA',sla) 
    1287      CALL getin('NATURAL',natural) 
    1288      !----------------- 
    1289      ! Photosynthesis 
    1290      !----------------- 
    1291      ! 
    1292      CALL getin('VCMAX_OPT',vcmax_opt) 
    1293      CALL getin('VJMAX_OPT',vjmax_opt) 
    1294      CALL getin('TPHOTO_MIN_A',tphoto_min_a) 
    1295      CALL getin('TPHOTO_MIN_B',tphoto_min_b) 
    1296      CALL getin('TPHOTO_MIN_C',tphoto_min_c) 
    1297      CALL getin('TPHOTO_OPT_A',tphoto_opt_a) 
    1298      CALL getin('TPHOTO_OPT_B',tphoto_opt_b) 
    1299      CALL getin('TPHOTO_OPT_C',tphoto_opt_c) 
    1300      CALL getin('TPHOTO_MAX_A',tphoto_max_a) 
    1301      CALL getin('TPHOTO_MAX_B',tphoto_max_b) 
    1302      CALL getin('TPHOTO_MAX_C',tphoto_max_c) 
    1303      !---------------------- 
    1304      ! Respiration - stomate 
    1305      !---------------------- 
    1306      ! 
    1307      CALL getin('MAINT_RESP_SLOPE_C',maint_resp_slope_c)  
    1308      CALL getin('MAINT_RESP_SLOPE_B',maint_resp_slope_b) 
    1309      CALL getin('MAINT_RESP_SLOPE_A',maint_resp_slope_a) 
    1310      CALL getin('CM_ZERO_LEAF',cm_zero_leaf) 
    1311      CALL getin('CM_ZERO_SAPABOVE',cm_zero_sapabove) 
    1312      CALL getin('CM_ZERO_SAPBELOW',cm_zero_sapbelow) 
    1313      CALL getin('CM_ZERO_HEARTABOVE',cm_zero_heartabove) 
    1314      CALL getin('CM_ZERO_HEARTBELOW',cm_zero_heartbelow) 
    1315      CALL getin('CM_ZERO_ROOT',cm_zero_root) 
    1316      CALL getin('CM_ZERO_FRUIT',cm_zero_fruit) 
    1317      CALL getin('CM_ZERO_CARBRES',cm_zero_carbres) 
    1318       
    1319      !---------------- 
    1320      ! Fire - stomate 
    1321      !--------------- 
    1322      ! 
    1323      CALL getin('FLAM',flam) 
    1324      CALL getin('RESIST',resist) 
    1325      !---------------- 
    1326      ! Flux - LUC 
    1327      !--------------- 
    1328      ! 
    1329      CALL getin('COEFF_LCCHANGE_1',coeff_lcchange_1) 
    1330      CALL getin('COEFF_LCCHANGE_10',coeff_lcchange_10) 
    1331      CALL getin('COEFF_LCCHANGE_100',coeff_lcchange_100) 
    1332  
    1333      !----------- 
    1334      ! Phenology 
    1335      !----------- 
    1336      !- 
    1337      ! 1 .Stomate 
    1338      !- 
    1339      CALL getin('LAI_MAX',lai_max) 
    1340      CALL getin('PHENO_MODEL',pheno_model) 
    1341      CALL getin('PHENO_TYPE',pheno_type) 
    1342      !- 
    1343      ! 2. Leaf Onset 
    1344      !- 
    1345      CALL getin('PHENO_GDD_CRIT_C',pheno_gdd_crit_c) 
    1346      CALL getin('PHENO_GDD_CRIT_B',pheno_gdd_crit_b) 
    1347      CALL getin('PHENO_GDD_CRIT_A',pheno_gdd_crit_a) 
    1348      CALL getin('NGD_CRIT',ngd_crit) 
    1349      CALL getin('NCDGDD_TEMP', ncdgdd_temp) 
    1350      CALL getin('HUM_FRAC', hum_frac) 
    1351      CALL getin('LOWGPP_TIME', lowgpp_time) 
    1352      CALL getin('HUM_MIN_TIME', hum_min_time) 
    1353      CALL getin('TAU_SAP',tau_sap) 
    1354      CALL getin('TAU_FRUIT',tau_fruit) 
    1355      CALL getin('ECUREUIL',ecureuil) 
    1356      CALL getin('ALLOC_MIN',alloc_min) 
    1357      CALL getin('ALLOC_MAX',alloc_max) 
    1358      CALL getin('DEMI_ALLOC',demi_alloc) 
    1359      !- 
    1360      ! 3. Senescence 
    1361      !- 
    1362      CALL getin('LEAFFALL',leaffall) 
    1363      CALL getin('LEAFAGECRIT',leafagecrit)   
    1364      CALL getin('SENESCENCE_TYPE', senescence_type)  
    1365      CALL getin('SENESCENCE_HUM', senescence_hum) 
    1366      CALL getin('NOSENESCENCE_HUM', nosenescence_hum)  
    1367      CALL getin('MAX_TURNOVER_TIME',max_turnover_time) 
    1368      CALL getin('MIN_TURNOVER_TIME',min_turnover_time) 
    1369      CALL getin('MIN_LEAF_AGE_FOR_SENESCENCE', min_leaf_age_for_senescence) 
    1370      CALL getin('SENESCENCE_TEMP_C',senescence_temp_c) 
    1371      CALL getin('SENESCENCE_TEMP_B',senescence_temp_b) 
    1372      CALL getin('SENESCENCE_TEMP_A',senescence_temp_a) 
    1373      !----------- 
    1374      ! DGVM 
    1375      !----------- 
    1376      CALL getin('RESIDENCE_TIME',residence_time) 
    1377      CALL getin('TMIN_CRIT',tmin_crit) 
    1378      CALL getin('TCM_CRIT',tcm_crit) 
    1379  
    1380      first_call = .FALSE. 
    1381         
    1382   ENDIF 
    1383    
    1384 END SUBROUTINE getin_stomate_pft_parameters 
    13851403 
    13861404END MODULE pft_parameters 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/AA_make

    r64 r257  
    11#- 
    2 #- $Id: AA_make,v 1.22 2010/04/20 13:59:56 ssipsl Exp $ 
     2#- $Id: AA_make 41 2011-01-01 19:56:53Z mmaipsl $ 
     3#- 
     4PARALLEL_LIB = $(LIBDIR)/libparallel.a 
     5SXPARALLEL_LIB = $(PARALLEL_LIB) 
     6#-Q- sxnec  SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     7#-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     8#-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     9#-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    310#- 
    411PARAM_LIB = $(LIBDIR)/libparameters.a 
    … …  
    815#-Q- eshpux SXPARAM_LIB = $(LIBDIR)/libsxparameters.a 
    916#-Q- sx8brodie SXPARAM_LIB = $(LIBDIR)/libsxparameters.a 
    10 #- 
    11 PARALLEL_LIB = $(LIBDIR)/libparallel.a 
    12 SXPARALLEL_LIB = $(PARALLEL_LIB) 
    13 #-Q- sxnec  SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    14 #-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    15 #-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    16 #-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    1717#- 
    1818ORGLOB_LIB = $(LIBDIR)/liborglob.a 
    … …  
    5454#- 
    5555all: 
     56        $(M_K) libparallel 
    5657        $(M_K) libparameters 
    57         $(M_K) libparallel 
     58        $(M_K) liborglob 
    5859        $(M_K) libstomate 
    5960        $(M_K) m_all 
    … …  
    6364#-Q- intel m_all: WORK_MOD $(MODEL_LIB)($(OBJSMODS1)) 
    6465 
     66libparallel: 
     67        (cd ../src_parallel; $(M_K) -f Makefile) 
     68 
    6569libparameters: 
    6670        (cd ../src_parameters; $(M_K) -f Makefile) 
    67  
    68 libparallel: 
    69         (cd ../src_parallel; $(M_K) -f Makefile) 
    7071 
    7172liborglob: 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/AA_make.ldef

    r64 r257  
    11#- 
    2 #- $Id: AA_make.ldef,v 1.7 2008/01/08 11:49:07 ssipsl Exp $ 
     2#- $Id: AA_make.ldef 12 2010-11-05 15:42:13Z mmaipsl $ 
    33#- 
    44#--------------------------------------------------------------------- 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/condveg.f90

    r104 r257  
    66!! 
    77!! @author Marie-Alice Foujols and Jan Polcher 
    8 !! @Version : $Revision: 1.30 $, $Date: 2009/01/07 13:39:45 $ 
     8!! @Version : $Revision: 45 $, $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
    99!!  
    10 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/condveg.f90,v 1.30 2009/01/07 13:39:45 ssipsl Exp $ 
     10!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/condveg.f90 $ 
     11!< $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
     12!< $Author: mmaipsl $ 
     13!< $Revision: 45 $ 
    1114!! IPSL (2006) 
    1215!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 
    … …  
    210213    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in):: veget            !! Vegetation distribution 
    211214    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)  :: lalo             !! Geographical coordinates 
    212     INTEGER(i_std),DIMENSION (kjpindex,4), INTENT(in):: neighbours       !! neighoring grid points if land 
     215    INTEGER(i_std),DIMENSION (kjpindex,8), INTENT(in):: neighbours       !! neighoring grid points if land 
    213216    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)  :: resolution       !! size in x an y of the grid (m) 
    214217    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: contfrac         ! Fraction of land in each grid box. 
    … …  
    663666      ! snow albedo on vegetated surfaces 
    664667      ! 
    665       fraction_veg(:) = 1. - totfrac_nobio(:) 
    666       snowa_veg(:) = 0. 
     668      fraction_veg(:) = un - totfrac_nobio(:) 
     669      snowa_veg(:) = zero 
    667670      DO jv = 1, nvm 
    668671        DO ji = 1, kjpindex 
    … …  
    11121115    ENDDO 
    11131116    ! 
    1114     WHERE ( sumveg(:) .GT. 0.0 ) z0(:) = z0(:) / sumveg(:) 
     1117    WHERE ( sumveg(:) .GT. zero ) z0(:) = z0(:) / sumveg(:) 
    11151118    ! 
    11161119    z0(:) = (un - totfrac_nobio(:)) * z0(:) 
    … …  
    11661169    ! 
    11671170!!$    DS :Correction 11/02/2011 : update 2D parameters  
    1168 !!$      before the components were updated but not the  parameter itself! 
    11691171    alb_leaf(1:nvm) = alb_leaf_vis(:) 
    11701172    alb_leaf(nvm+1:2*nvm) = alb_leaf_nir(:) 
    1171 !!$ maybe we could use directly alb_leaf_vis and alb_leaf_nir in alb_leaf_temp 
    1172     ! 
    1173 !!$    alb_leaf_tmp(:,1) = alb_leaf_vis(:) 
    1174 !!$    alb_leaf_tmp(:,2) = alb_leaf_nir(:) 
    11751173    ! 
    11761174    alb_leaf_tmp(:,1) = alb_leaf(1:nvm) 
    … …  
    11881186       ! 
    11891187       ! Correction Nathalie le 12 Avril 2006 - suppression de la dependance en deadleaf_cover 
    1190        !albedo(:,ks) = veget(:,1) * ( (1.-deadleaf_cover(:))*alb_bare(:) + & 
     1188       !albedo(:,ks) = veget(:,1) * ( (un-deadleaf_cover(:))*alb_bare(:) + & 
    11911189       !                              deadleaf_cover(:)*alb_deadleaf(ks)    ) 
    11921190       albedo(:,ks) = veget(:,1) * alb_bare(:,ks) 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/diffuco.f90

    r105 r257  
    33!! 
    44!! @author Marie-Alice Foujols and Jan Polcher 
    5 !! @Version : $Revision: 1.35 $, $Date: 2010/04/07 09:16:40 $ 
     5!! @Version : $Revision: 42 $, $Date: 2011-01-01 21:15:03 +0100 (Sat, 01 Jan 2011) $ 
    66!!  
    7 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/diffuco.f90,v 1.35 2010/04/07 09:16:40 ssipsl Exp $ 
     7!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/diffuco.f90 $ 
     8!< $Date: 2011-01-01 21:15:03 +0100 (Sat, 01 Jan 2011) $ 
     9!< $Author: mmaipsl $ 
     10!< $Revision: 42 $ 
    811!! IPSL (2006) 
    912!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 
    … …  
    3841  !! Nathalie le 28 mars 2006 - sur proposition de Fred Hourdin, ajout 
    3942  !! d'un potentiometre pour regler la resistance de la vegetation ( rveg is now in pft_parameters) 
    40  
    4143  ! MM 
    4244  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: wind                     !! Wind norm 
    … …  
    242244    ! beta coefficient for bare soil 
    243245    ! 
    244  
    245246    CALL diffuco_bare (kjpindex, dtradia, u, v, q_cdrag, rsol, evap_bare_lim, evapot, humrel, veget, vbeta4)  
    246247 
    … …  
    744745                IF ( zrapp .LT. un ) THEN 
    745746                   ! Ajout Nathalie - Juin 2006 
    746                     vbeta23(ji,jv) = MAX(vbeta2(ji,jv) - vbeta2(ji,jv) * zrapp, 0.) 
     747                    vbeta23(ji,jv) = MAX(vbeta2(ji,jv) - vbeta2(ji,jv) * zrapp, zero) 
    747748                    ! Fin ajout Nathalie 
    748749                    vbeta2(ji,jv) = vbeta2(ji,jv) * zrapp 
    … …  
    10041005    ! 
    10051006    DO jl = 1, nlai+1 
    1006       laitab(jl) = laimax*(EXP(lai_level_depth*REAL(jl-1,r_std))-1.)/(EXP(lai_level_depth*REAL(nlai,r_std))-1.) 
     1007      laitab(jl) = laimax*(EXP(lai_level_depth*REAL(jl-1,r_std))-1.)/(EXP(lai_level_depth*REAL(nlai,r_std))-un) 
    10071008    ENDDO 
    10081009    ! 
    … …  
    11001101      ! 
    11011102      WHERE ( assimilate(:) ) 
    1102         water_lim(:) = MIN( 2.*humrel(:,jv), 1. ) 
     1103        water_lim(:) = MIN( 2.*humrel(:,jv), un ) 
    11031104      ENDWHERE 
    11041105      ! give a default value of ci for all pixel that do not assimilate 
    … …  
    12551256          DO ji = 1, kjpindex 
    12561257            ! 
    1257             assimi(ji) = 0. 
     1258            assimi(ji) = zero 
    12581259            ! 
    12591260          ENDDO 
    … …  
    12881289          DO ji = 1, kjpindex 
    12891290            ! 
    1290             assimi(ji) = 0. 
     1291            assimi(ji) = zero 
    12911292            ! 
    12921293          ENDDO 
    … …  
    13831384        IF ( jl .EQ. 1 ) THEN 
    13841385          ! 
    1385           leaf_gs_top(:) = 0. 
     1386          leaf_gs_top(:) = zero 
    13861387          ! 
    13871388          IF ( nic .GT. 0 ) then 
    … …  
    14371438              laitab(ilai(iainia)+1) 
    14381439          ! 
    1439           rveget(iainia,jv) = 1./gstop(iainia) 
     1440          rveget(iainia,jv) = un/gstop(iainia) 
    14401441          ! 
    14411442        ENDDO 
    … …  
    14481449          ! 
    14491450          ! Correction Nathalie - le 27 Mars 2006 - Interdire a rstruct d'etre negatif 
    1450           !rstruct(iainia,jv) = 1./gstot(iainia) - & 
     1451          !rstruct(iainia,jv) = un/gstot(iainia) - & 
    14511452          !     rveget(iainia,jv) 
    1452           rstruct(iainia,jv) = MAX( 1./gstot(iainia) - & 
     1453          rstruct(iainia,jv) = MAX( un/gstot(iainia) - & 
    14531454               rveget(iainia,jv), min_sechiba) 
    14541455          ! 
    … …  
    15561557    REAL(r_std)                                    :: coeff_dew_veg 
    15571558 
    1558     vbeta2sum(:) = 0. 
    1559     vbeta3sum(:) = 0. 
     1559    vbeta2sum(:) = zero 
     1560    vbeta3sum(:) = zero 
    15601561    DO jv = 1, nvm 
    15611562      vbeta2sum(:) = vbeta2sum(:) + vbeta2(:,jv) 
    … …  
    15931594 
    15941595    ! for vectorization: some arrays 
    1595     vegetsum(:) = 0. 
     1596    vegetsum(:) = zero 
    15961597    DO jv = 1, nvm 
    15971598      vegetsum(:) = vegetsum(:) + veget(:,jv) 
    15981599    ENDDO 
    1599     vegetsum2(:) = 0. 
     1600    vegetsum2(:) = zero 
    16001601    DO jv = 2, nvm 
    16011602      vegetsum2(:) = vegetsum2(:) + veget(:,jv) 
    … …  
    16671668                         & + dew_veg_poly_coeff(2)*lai(ji,jv) & 
    16681669                         & + dew_veg_poly_coeff(1) 
    1669  
    1670  
    16711670                 ELSE 
    1672                     coeff_dew_veg=1. 
     1671                    coeff_dew_veg=un 
    16731672                 ENDIF 
    16741673              ELSE 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/enerbil.f90

    r113 r257  
    33!! 
    44!! @author Marie-Alice Foujols and Jan Polcher 
    5 !! @Version : $Revision: 1.24 $, $Date: 2009/01/07 13:39:45 $ 
     5!! @Version : $Revision: 47 $, $Date: 2011-01-01 21:34:45 +0100 (Sat, 01 Jan 2011) $ 
    66!!  
    7 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/enerbil.f90,v 1.24 2009/01/07 13:39:45 ssipsl Exp $ 
     7!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/enerbil.f90 $ 
     8!< $Date: 2011-01-01 21:34:45 +0100 (Sat, 01 Jan 2011) $ 
     9!< $Author: mmaipsl $ 
     10!< $Revision: 47 $ 
    811!! IPSL (2006) 
    912!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 
    … …  
    121124    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: evapot           !! Soil Potential Evaporation 
    122125    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: evapot_corr !! Soil Potential Evaporation Correction 
     126    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: temp_sol         !! Soil temperature 
     127    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: qsurf            !! Surface specific humidity 
     128    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: fluxsens         !! Sensible chaleur flux 
     129    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: fluxlat          !! Latent chaleur flux 
     130    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: tsol_rad         !! Tsol_rad 
     131    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: vevapp           !! Total of evaporation 
     132    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: gpp              !! Assimilation, gC/m**2 total area. 
     133    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: temp_sol_new     !! New soil temperature 
    123134    ! output fields 
    124     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: fluxsens         !! Sensible chaleur flux 
    125     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: fluxlat          !! Latent chaleur flux 
    126     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: vevapp           !! Total of evaporation 
    127135    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: vevapnu          !! Bare soil evaporation 
    128136    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: vevapsno         !! Snow evaporation 
    129     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: tsol_rad         !! Tsol_rad 
    130     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: temp_sol_new     !! New soil temperature 
    131     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: temp_sol         !! Soil temperature 
    132     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: qsurf            !! Surface specific humidity 
    133137    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: transpir         !! Transpiration 
    134     REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: gpp              !! Assimilation, gC/m**2 total area. 
    135138    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vevapwet         !! Interception  
    136139    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: t2mdiag          !! 2-meter temperature 
    … …  
    281284    ! output fields, they need to initialized somehow for the model forcing ORCHIDEE. 
    282285    ! 
    283     REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: temp_sol           !! Soil temperature 
     286    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: temp_sol           !! Soil temperature 
    284287    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: temp_sol_new       !! New soil temperature 
    285288    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsurf              !! near surface specific humidity 
    … …  
    423426        !Config        the model is started without a restart file.  
    424427        ! 
    425         CALL setvar_p (evapot, val_exp, 'ENERBIL_EVAPOT', 0.0_r_std) 
     428        CALL setvar_p (evapot, val_exp, 'ENERBIL_EVAPOT', zero) 
    426429        IF ( ok_var("evapot_corr") ) THEN 
    427            CALL setvar_p (evapot_corr, val_exp, 'ENERBIL_EVAPOT', 0.0_r_std) 
     430           CALL setvar_p (evapot_corr, val_exp, 'ENERBIL_EVAPOT', zero) 
    428431        ENDIF 
    429432        ! 
    … …  
    778781    REAL(r_std)                                     :: correction 
    779782    REAL(r_std)                                     :: speed, qc 
     783    LOGICAL,DIMENSION (kjpindex)                   :: warning_correction 
    780784    ! initialisation 
    781785 
    … …  
    840844!    grad_qsat(:)= (qsol_sat_new(:)- qsat_air(:)) / ((psnew(:) - epot_air(:)) / cp_air) ! * dtradia 
    841845    !- Penser a sortir evapot en meme temps qu'evapot_corr tdo. 
     846    warning_correction(:)=.FALSE. 
    842847    DO ji=1,kjpindex 
    843848 
    … …  
    852857             correction = chalev0 * rau(ji) * qc * grad_qsat(ji) * (un - vevapp(ji)/evapot(ji)) / correction 
    853858          ELSE 
    854              WRITE(numout,*) "Denominateur de la correction de milly nul! Aucune correction appliquee" 
     859             warning_correction(ji)=.TRUE. 
    855860          ENDIF 
    856861       ELSE 
    … …  
    862867        
    863868    ENDDO 
    864  
     869    IF ( ANY(warning_correction) ) THEN 
     870       DO ji=1,kjpindex 
     871          IF ( warning_correction(ji) ) THEN 
     872             WRITE(numout,*) ji,"Denominateur de la correction de milly nul! Aucune correction appliquee" 
     873          ENDIF 
     874       ENDDO 
     875    ENDIF 
    865876    IF (long_print) WRITE (numout,*) ' enerbil_flux done ' 
    866877 
    … …  
    886897    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: evapot           !! Soil Potential Evaporation 
    887898    REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (in)       :: humrel           !! Relative humidity 
    888 !!$ DS 15022011 humrel was used in a previuos version of Orchidee, developped by Nathalie. Need to be discussed if it should be introduces again 
     899!!$ DS 15022011 humrel was used in a previous version of Orchidee, developped by Nathalie. Need to be discussed if it should be introduces again 
    889900    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vbeta2           !! Interception resistance 
    890901    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vbeta3           !! Vegetation resistance 
    … …  
    969980    ELSEIF ( control%stomate_watchout ) THEN 
    970981 
    971       gpp(:,:) = 0.0 
     982      gpp(:,:) = zero 
    972983 
    973984    ENDIF 
    … …  
    10011012 
    10021013    ! initialisation 
    1003    IF (long_print) WRITE (numout,*) ' enerbil_fusion start ', MINVAL(soilcap), MINLOC(soilcap),& 
     1014    IF (long_print) WRITE (numout,*) ' enerbil_fusion start ', MINVAL(soilcap), MINLOC(soilcap),& 
    10041015         & MAXVAL(soilcap), MAXLOC(soilcap) 
    10051016    ! 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/hydrol.f90

    r112 r257  
    33!! 
    44!! @author Marie-Alice Foujols and Jan Polcher 
    5 !! @Version : $Revision: 1.36 $, $Date: 2009/01/07 13:39:45 $ 
     5!! @Version : $Revision: 45 $, $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
    66!! 
    7 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/hydrol.f90,v 1.36 2009/01/07 13:39:45 ssipsl Exp $ 
     7!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/hydrol.f90 $ 
     8!< $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
     9!< $Author: mmaipsl $ 
     10!< $Revision: 45 $ 
    811!! IPSL (2006) 
    912!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 
    … …  
    224227    !! We consider that any water on the ice is snow and we only peforme a water balance to have consistency. 
    225228    !! The water balance is limite to + or - 10^6 so that accumulation is not endless 
     229    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: runoff           !! Complete runoff 
     230    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: drainage         !! Drainage 
     231    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (inout):: shumdiag         !! relative soil moisture 
    226232    ! output fields 
    227     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: runoff           !! Complete runoff 
    228     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: drainage         !! Drainage 
    229233    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: humrel           !! Relative humidity 
    230234    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vegstress        !! Veg. moisture stress (only for vegetation growth) 
    231235    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: drysoil_frac     !! function of litter wetness 
    232     REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: shumdiag         !! relative soil moisture 
    233236    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: litterhumdiag    !! litter humidity 
    234237    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: tot_melt         !! Total melt     
    … …  
    10821085       ! 
    10831086       DO jsl=1,nslm 
    1084           CALL setvar_p (us(:,:,:,jsl), val_exp, 'US_INIT', 0.0_r_std) 
     1087          CALL setvar_p (us(:,:,:,jsl), val_exp, 'US_INIT', zero) 
    10851088       ENDDO 
    10861089       ! 
    … …  
    11011104       !Config        started without a restart file. 
    11021105       ! 
    1103        CALL setvar_p (ae_ns, val_exp, 'EVAPNU_SOIL', 0.0_r_std) 
     1106       CALL setvar_p (ae_ns, val_exp, 'EVAPNU_SOIL', zero) 
    11041107       ! 
    11051108       !Config Key  = HYDROL_SNOW 
    … …  
    11101113       !Config        started without a restart file. 
    11111114       ! 
    1112        CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', 0.0_r_std) 
     1115       CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', zero) 
    11131116       ! 
    11141117       !Config Key  = HYDROL_SNOWAGE 
    … …  
    11191122       !Config        started without a restart file. 
    11201123       ! 
    1121        CALL setvar_p (snow_age, val_exp, 'HYDROL_SNOWAGE', 0.0_r_std) 
     1124       CALL setvar_p (snow_age, val_exp, 'HYDROL_SNOWAGE', zero) 
    11221125       ! 
    11231126       !Config Key  = HYDROL_SNOW_NOBIO 
    … …  
    11281131       !Config        started without a restart file. 
    11291132       ! 
    1130        CALL setvar_p (snow_nobio, val_exp, 'HYDROL_SNOW_NOBIO', 0.0_r_std) 
     1133       CALL setvar_p (snow_nobio, val_exp, 'HYDROL_SNOW_NOBIO', zero) 
    11311134       ! 
    11321135       !Config Key  = HYDROL_SNOW_NOBIO_AGE 
    … …  
    11371140       !Config        started without a restart file. 
    11381141       ! 
    1139        CALL setvar_p (snow_nobio_age, val_exp, 'HYDROL_SNOW_NOBIO_AGE', 0.0_r_std) 
     1142       CALL setvar_p (snow_nobio_age, val_exp, 'HYDROL_SNOW_NOBIO_AGE', zero) 
    11401143       ! 
    11411144       ! 
    … …  
    11481151       !Config        the model is started without a restart file.  
    11491152       ! 
    1150        CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', 0.0_r_std) 
     1153       CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', zero) 
    11511154       ! 
    11521155       ! There is no need to configure the initialisation of resdist. If not available it is the vegetation map 
    … …  
    17171720          IF (snow(ji).GT.sneige) THEN 
    17181721             ! 
    1719              snowmelt(ji) = (1. - frac_nobio(ji,iice))*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0 
     1722             snowmelt(ji) = (un - frac_nobio(ji,iice))*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0 
    17201723             ! 
    17211724             ! 1.3.1.1 enough snow for melting or not 
    … …  
    18901893    REAL(r_std), DIMENSION (kjpindex,nvm)          :: zqsintvegnew 
    18911894    LOGICAL, SAVE                                  :: firstcall=.TRUE. 
    1892 !    REAL(r_std), SAVE, DIMENSION(nvm)              :: throughfall_by_pft 
    18931895 
    18941896    IF ( firstcall ) THEN 
    … …  
    20782080    DO jv = 1, nvm 
    20792081      DO ji = 1, kjpindex 
    2080          IF ( ABS(qsintveg(ji,jv)) > 0. .AND. ABS(qsintveg(ji,jv)) < EPS1 ) THEN 
     2082         IF ( ABS(qsintveg(ji,jv)) > zero .AND. ABS(qsintveg(ji,jv)) < EPS1 ) THEN 
    20812083            qsintveg(ji,jv) = EPS1 
    20822084         ENDIF 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/hydrolc.f90

    r134 r257  
    33!! 
    44!! @author Marie-Alice Foujols and Jan Polcher 
    5 !! @Version : $Revision: 1.21 $, $Date: 2010/05/07 08:28:13 $ 
     5!! @Version : $Revision: 45 $, $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
    66!!  
    7 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/hydrolc.f90,v 1.21 2010/05/07 08:28:13 ssipsl Exp $ 
     7!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/hydrolc.f90 $ 
     8!< $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
     9!< $Author: mmaipsl $ 
     10!< $Revision: 45 $ 
    811!! IPSL (2006) 
    912!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 
    … …  
    145148    !! We consider that any water on the ice is snow and we only peforme a water balance to have consistency. 
    146149    !! The water balance is limite to + or - 10^6 so that accumulation is not endless 
     150    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: humrel        !! Relative humidity 
     151    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: vegstress     !! Veg. moisture stress (only for vegetation growth) 
     152    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: qsintveg      !! Water on vegetation due to interception 
    147153    ! output fields 
    148     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: run_off_tot   !! Complete runoff 
    149     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: drainage      !! Drainage 
    150     REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: humrel        !! Relative humidity 
    151     REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vegstress     !! Veg. moisture stress (only for vegetation growth) 
     154    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: run_off_tot   !! Complete runoff 
     155    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: drainage      !! Drainage 
     156    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (inout):: shumdiag      !! relative soil moisture 
     157 
    152158    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: rsol          !! Resistence to bare soil evaporation 
    153159    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: drysoil_frac  !! Fraction of visibly dry soil (between 0 and 1) 
    154     REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: shumdiag      !! relative soil moisture 
    155160    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: litterhumdiag !! litter humidity 
    156161    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: tot_melt      !! Total melt     
    157     REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: qsintveg      !! Water on vegetation due to interception 
    158162 
    159163    ! 
    … …  
    293297       CALL hydrolc_alma(kjpindex, index, .FALSE., qsintveg, snow, snow_nobio, soilwet) 
    294298    ENDIF 
    295  
    296299 
    297300    ! 
    … …  
    313316          DO ji = 1, kjpindex 
    314317             IF ( vegtot(ji) .GT. zero ) THEN 
    315                 histvar(ji)=histvar(ji)+veget(ji,jv)/vegtot(ji)*MAX((0.1-dss(ji,jv))*mx_eau_eau, 0.0) 
     318                histvar(ji)=histvar(ji)+veget(ji,jv)/vegtot(ji)*MAX((0.1-dss(ji,jv))*mx_eau_eau, zero) 
    316319             ENDIF 
    317320          ENDDO 
    … …  
    322325       CALL histwrite(hist_id, 'mrso', kjit, histvar, kjpindex, index) 
    323326 
    324        histvar(:)=run_off_tot(:)/86400. 
     327       histvar(:)=run_off_tot(:)/one_day 
    325328       CALL histwrite(hist_id, 'mrros', kjit, histvar, kjpindex, index) 
    326329 
    327        histvar(:)=(run_off_tot(:)+drainage(:))/86400. 
     330       histvar(:)=(run_off_tot(:)+drainage(:))/one_day 
    328331       CALL histwrite(hist_id, 'mrro', kjit, histvar, kjpindex, index) 
    329332 
    330        histvar(:)=(precip_rain(:)-SUM(precisol(:,:),dim=2))/86400. 
     333       histvar(:)=(precip_rain(:)-SUM(precisol(:,:),dim=2))/one_day 
    331334       CALL histwrite(hist_id, 'prveg', kjit, histvar, kjpindex, index) 
    332335 
    … …  
    369372             DO ji = 1, kjpindex 
    370373                IF ( vegtot(ji) .GT. zero ) THEN 
    371                    histvar(ji)=histvar(ji)+veget(ji,jv)/vegtot(ji)*MAX((0.1-dss(ji,jv))*mx_eau_eau, 0.0) 
     374                   histvar(ji)=histvar(ji)+veget(ji,jv)/vegtot(ji)*MAX((0.1-dss(ji,jv))*mx_eau_eau, zero) 
    372375                ENDIF 
    373376             ENDDO 
    … …  
    375378          CALL histwrite(hist2_id, 'mrsos', kjit, histvar, kjpindex, index) 
    376379 
    377           histvar(:)=(run_off_tot(:)+drainage(:))/86400. 
     380          histvar(:)=(run_off_tot(:)+drainage(:))/one_day 
    378381          CALL histwrite(hist2_id, 'mrro', kjit, histvar, kjpindex, index) 
    379382 
    … …  
    772775        !Config        started without a restart file. 
    773776        ! 
    774         CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', 0.0_r_std) 
     777        CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', zero) 
    775778        ! 
    776779        !Config Key  = HYDROL_SNOWAGE 
    … …  
    781784        !Config        started without a restart file. 
    782785        ! 
    783         CALL setvar_p (snow_age, val_exp, 'HYDROL_SNOWAGE', 0.0_r_std) 
     786        CALL setvar_p (snow_age, val_exp, 'HYDROL_SNOWAGE', zero) 
    784787        ! 
    785788        !Config Key  = HYDROL_SNOW_NOBIO 
    … …  
    790793        !Config        started without a restart file. 
    791794        ! 
    792         CALL setvar_p (snow_nobio, val_exp, 'HYDROL_SNOW_NOBIO', 0.0_r_std) 
     795        CALL setvar_p (snow_nobio, val_exp, 'HYDROL_SNOW_NOBIO', zero) 
    793796        ! 
    794797        !Config Key  = HYDROL_SNOW_NOBIO_AGE 
    … …  
    799802        !Config        started without a restart file. 
    800803        ! 
    801         CALL setvar_p (snow_nobio_age, val_exp, 'HYDROL_SNOW_NOBIO_AGE', 0.0_r_std) 
     804        CALL setvar_p (snow_nobio_age, val_exp, 'HYDROL_SNOW_NOBIO_AGE', zero) 
    802805        ! 
    803806        !Config Key  = HYDROL_HUMR 
    … …  
    808811        !Config        started without a restart file. 
    809812        ! 
    810         CALL setvar_p (humrel, val_exp,'HYDROL_HUMR', 1.0_r_std) 
    811         CALL setvar_p (vegstress, val_exp,'HYDROL_HUMR', 1.0_r_std) 
     813        CALL setvar_p (humrel, val_exp,'HYDROL_HUMR', un) 
     814        CALL setvar_p (vegstress, val_exp,'HYDROL_HUMR', un) 
    812815        ! 
    813816        !Config Key  = HYDROL_BQSB 
    … …  
    827830        !Config        started without a restart file. 
    828831        ! 
    829         CALL setvar_p (gqsb, val_exp, 'HYDROL_GQSB', 0.0_r_std) 
     832        CALL setvar_p (gqsb, val_exp, 'HYDROL_GQSB', zero) 
    830833        ! 
    831834        !Config Key  = HYDROL_DSG 
    … …  
    836839        !Config        started without a restart file. 
    837840        ! 
    838         CALL setvar_p (dsg, val_exp, 'HYDROL_DSG', 0.0_r_std) 
     841        CALL setvar_p (dsg, val_exp, 'HYDROL_DSG', zero) 
    839842 
    840843        ! set inital value for dsp if needed 
    … …  
    872875        !Config        the model is started without a restart file.  
    873876        ! 
    874         CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', 0.0_r_std) 
     877        CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', zero) 
    875878        ! 
    876879        tmpdss = dsg - gqsb / mx_eau_eau 
    … …  
    889892                    IF (.NOT. (dsg(ji,1).EQ. zero .OR. gqsb(ji,1).EQ.zero)) THEN 
    890893                       ! Ajouts Nathalie - Fred - le 28 Mars 2006 
    891                        a_subgrd(ji)=MIN(MAX(dsg(ji,1)-dss(ji,1),0.)/dsg_min,1.) 
     894                       a_subgrd(ji)=MIN(MAX(dsg(ji,1)-dss(ji,1),zero)/dsg_min,un) 
    892895                       ! 
    893896                    ENDIF 
    … …  
    906909                 IF (.NOT. (dsg(ji,1).EQ. zero .OR. gqsb(ji,1).EQ.zero)) THEN 
    907910                    ! Ajouts Nathalie - Fred - le 28 Mars 2006 
    908                     a_subgrd(ji)=MIN(MAX(dsg(ji,1)-dss(ji,1),0.)/dsg_min,1.) 
     911                    a_subgrd(ji)=MIN(MAX(dsg(ji,1)-dss(ji,1),zero)/dsg_min,un) 
    909912                    ! 
    910913                 ENDIF 
    … …  
    915918           ! Correction Nathalie - le 28 Mars 2006 - re-ecriture drysoil_frac/hdry - Fred Hourdin 
    916919           ! revu 22 novembre 2007 
    917            hdry(:) = a_subgrd(:)*dss(:,1) + (1.-a_subgrd(:))*dsp(:,1) 
     920           hdry(:) = a_subgrd(:)*dss(:,1) + (un-a_subgrd(:))*dsp(:,1) 
    918921        ENDIF 
    919922        ! 
    … …  
    10901093 
    10911094    ! The fraction of soil which is visibly dry (dry when dss = 0.1 m) 
    1092     drysoil_frac(:) = MIN(MAX(dss(:,1),0.)*10._r_std, un) 
     1095    drysoil_frac(:) = MIN(MAX(dss(:,1),zero)*10._r_std, un) 
    10931096    ! 
    10941097    ! Compute the resistance to bare soil evaporation 
    … …  
    11021105          ! du fond. En gros, rsol=hdry*rsol_cste pour hdry < 1m70 
    11031106          !rsol(ji) = dss(ji,1) * rsol_cste 
    1104           !rsol(ji) =  ( drysoil_frac(ji) + 1./(10.*(dpu_cste - drysoil_frac(ji))+1.e-10)**2 ) * rsol_cste 
    1105           rsol(ji) =  ( hdry(ji) + 1./(10.*(dpu_cste - hdry(ji))+1.e-10)**2 ) * rsol_cste 
     1107          !rsol(ji) =  ( drysoil_frac(ji) + un/(10.*(dpu_cste - drysoil_frac(ji))+1.e-10)**2 ) * rsol_cste 
     1108          rsol(ji) =  ( hdry(ji) + un/(10.*(dpu_cste - hdry(ji))+1.e-10)**2 ) * rsol_cste 
    11061109       ENDIF 
    11071110    ENDDO 
    … …  
    11241127!!$            ( mean_dsg(ji) .GT. min_sechiba ) .AND. & 
    11251128!!$            ( mean_dsg(ji) .LT. 5.E-4 ) ) THEN 
    1126 !!$        litterhumdiag(ji) = 0.0 
     1129!!$        litterhumdiag(ji) = zero 
    11271130!!$      ENDIF 
    11281131!!$    ENDDO 
    … …  
    12731276         IF (snow(ji).GT.sneige) THEN  
    12741277            ! 
    1275             snowmelt(ji) = (1. - frac_nobio(ji,iice))*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0  
     1278            snowmelt(ji) = (un - frac_nobio(ji,iice))*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0  
    12761279            ! 
    12771280            ! 1.3.1.1 enough snow for melting or not 
    … …  
    14091412                    &  (un - snow_nobio_age(ji,iice)/max_snow_age) * dtradia/one_day ) * & 
    14101413                    &  EXP(-precip_snow(ji) / snow_trans) - snow_nobio_age(ji,iice) 
    1411         IF (d_age(ji) .GT. 0. ) THEN 
     1414        IF (d_age(ji) .GT. zero ) THEN 
    14121415          xx(ji) = MAX( tp_00 - temp_sol_new(ji), zero ) 
    14131416          xx(ji) = ( xx(ji) / 7._r_std ) ** 4._r_std 
    … …  
    14561459    REAL(r_std), DIMENSION (kjpindex,nvm)          :: zqsintvegnew 
    14571460    LOGICAL, SAVE                                  :: firstcall=.TRUE. 
    1458 !    REAL(r_std), SAVE, DIMENSION(nvm)              :: throughfall_by_pft 
    14591461 
    14601462    IF ( firstcall ) THEN 
    … …  
    15781580        ENDIF 
    15791581    ! 
    1580         IF (resdist(ji,jv) .GT. 0.) THEN 
     1582        IF (resdist(ji,jv) .GT. zero) THEN 
    15811583         qsintveg2(ji,jv) = qsintveg(ji,jv)/resdist(ji,jv) 
    15821584        ELSE 
    … …  
    15861588    ENDDO 
    15871589    ! 
    1588     vegchtot(:) = 0. 
     1590    vegchtot(:) = zero 
    15891591    DO jv = 1, nvm 
    15901592      DO ji = 1, kjpindex 
    … …  
    15951597    DO jv = 1, nvm 
    15961598      DO ji = 1, kjpindex 
    1597         IF ( vegchtot(ji) .GT. 0. ) THEN 
     1599        IF ( vegchtot(ji) .GT. zero ) THEN 
    15981600          gdq(ji,jv) = ABS(vmr(ji,jv)) * gqsb(ji,jv) 
    15991601          bdq(ji,jv) = ABS(vmr(ji,jv)) * bqsb(ji,jv) 
    … …  
    16131615    DO jv = 1, nvm 
    16141616      DO ji = 1, kjpindex 
    1615         IF ( ( vegchtot(ji) .GT. 0. ) .AND. ( vmr(ji,jv) .LT. 0. ) ) THEN 
     1617        IF ( ( vegchtot(ji) .GT. zero ) .AND. ( vmr(ji,jv) .LT. zero ) ) THEN 
    16161618          gtr(ji) = gtr(ji) + gdq(ji,jv) 
    16171619          btr(ji) = btr(ji) + bdq(ji,jv) 
    … …  
    16251627    DO jv = 1, nvm 
    16261628      DO ji = 1, kjpindex 
    1627         IF ( vegchtot(ji) .GT. 0. .AND. ABS(vtr(ji)) .GT. EPS1) THEN 
     1629        IF ( vegchtot(ji) .GT. zero .AND. ABS(vtr(ji)) .GT. EPS1) THEN 
    16281630            fra(ji) = vmr(ji,jv) / vtr(ji) 
    1629              IF ( vmr(ji,jv) .GT. 0.)  THEN 
    1630               IF (veget(ji,jv) .GT. 0.) THEN 
     1631             IF ( vmr(ji,jv) .GT. zero)  THEN 
     1632              IF (veget(ji,jv) .GT. zero) THEN 
    16311633               gqsb(ji,jv) = (resdist(ji,jv)*gqsb(ji,jv) + fra(ji)*gtr(ji))/veget(ji,jv) 
    16321634               bqsb(ji,jv) = (resdist(ji,jv)*bqsb(ji,jv) + fra(ji)*btr(ji))/veget(ji,jv) 
    … …  
    20032005    IF (long_print) WRITE(numout,*)  'hydrolc_soil 3.0 : Vertical diffusion' 
    20042006 
    2005     mean_bqsb(:) = 0. 
    2006     mean_gqsb(:) = 0. 
     2007    mean_bqsb(:) = zero 
     2008    mean_gqsb(:) = zero 
    20072009    DO jv = 1, nvm 
    20082010      DO ji = 1, kjpindex 
    … …  
    20302032        DO ji = 1, kjpindex 
    20312033           IF (lbad_ij(ji)) THEN 
    2032               IF ( veget(ji,jv) .GT. 0. ) THEN 
     2034              IF ( veget(ji,jv) .GT. zero ) THEN 
    20332035                 ! 
    20342036                 bqsb(ji,jv) = mean_bqsb(ji) 
    … …  
    20562058!        ! 
    20572059!        DO ji = 1, kjpindex 
    2058 !          IF ( veget(ji,jv) .GT. 0. ) THEN 
     2060!          IF ( veget(ji,jv) .GT. zero ) THEN 
    20592061!            ! 
    20602062!            bqsb(ji,jv) = mean_bqsb(ji) 
    … …  
    20822084      ENDDO 
    20832085      ! 
    2084       mean_bqsb(:) = 0. 
    2085       mean_gqsb(:) = 0. 
     2086      mean_bqsb(:) = zero 
     2087      mean_gqsb(:) = zero 
    20862088      DO jv = 1, nvm 
    20872089        DO ji = 1, kjpindex 
    … …  
    21802182               zhumrel_up(ji) = EXP( - humcste(jv) * dss(ji,jv)) 
    21812183               ! Ajouts Nathalie - Fred - le 28 Mars 2006 
    2182                a_subgrd(ji,jv)=MIN(MAX(dsg(ji,jv)-dss(ji,jv),0.)/dsg_min,1.) 
    2183                humrel(ji,jv)=a_subgrd(ji,jv)*zhumrel_up(ji)+(1.-a_subgrd(ji,jv))*zhumrel_lo(ji) 
     2184               a_subgrd(ji,jv)=MIN(MAX(dsg(ji,jv)-dss(ji,jv),zero)/dsg_min,un) 
     2185               humrel(ji,jv)=a_subgrd(ji,jv)*zhumrel_up(ji)+(un-a_subgrd(ji,jv))*zhumrel_lo(ji) 
    21842186               ! 
    21852187               vegstress(ji,jv) = zhumrel_lo(ji) + zhumrel_up(ji) - EXP( - humcste(jv) * dsg(ji,jv) )  
    … …  
    22212223 
    22222224    ! The fraction of visibly dry soil (dry when dss(:,1) = 0.1 m) 
    2223     drysoil_frac(:) = MIN(MAX(dss(:,1),0.)*10._r_std, un) 
     2225    drysoil_frac(:) = MIN(MAX(dss(:,1),zero)*10._r_std, un) 
    22242226 
    22252227    ! Correction Nathalie - le 28 Mars 2006 - re-ecriture drysoil_frac/hdry - Fred Hourdin 
    22262228    ! revu 22 novembre 2007 
    2227     hdry(:) = a_subgrd(:,1)*dss(:,1) + (1.-a_subgrd(:,1))*dsp(:,1) 
     2229    hdry(:) = a_subgrd(:,1)*dss(:,1) + (un-a_subgrd(:,1))*dsp(:,1) 
    22282230    ! 
    22292231    ! Compute the resistance to bare soil evaporation. 
    … …  
    22372239          ! du fond. En gros, rsol=hdry*rsol_cste pour hdry < 1m70 
    22382240          !rsol(ji) = dss(ji,1) * rsol_cste 
    2239           rsol(ji) =  ( hdry(ji) + 1./(10.*(dpu_cste - hdry(ji))+1.e-10)**2 ) * rsol_cste 
     2241          rsol(ji) =  ( hdry(ji) + un/(10.*(dpu_cste - hdry(ji))+1.e-10)**2 ) * rsol_cste 
    22402242       ENDIF 
    22412243    ENDDO 
    … …  
    23892391       IF ( ABS(delta_water(ji)-tot_flux(ji)) .GT. allowed_err ) THEN 
    23902392          WRITE(numout,*) 'HYDROL does not conserve water. The erroneous point is : ', ji 
    2391           WRITE(numout,*) 'The error in mm/d is :', (delta_water(ji)-tot_flux(ji))/dtradia, & 
     2393          WRITE(numout,*) 'The error in mm/d is :', (delta_water(ji)-tot_flux(ji))/dtradia*one_day, & 
    23922394               & ' and in mm/dt : ', delta_water(ji)-tot_flux(ji) 
    23932395          WRITE(numout,*) 'delta_water : ', delta_water(ji), ' tot_flux : ', tot_flux(ji) 
    … …  
    25202522      !Config  Key  = HYDROL_TAU_HDIFF 
    25212523      !Config  Desc = time scale (s) for horizontal diffusion of water 
    2522       !Config  Def  = 86400. 
     2524      !Config  Def  = one_day 
    25232525      !Config  If   = HYDROL_OK_HDIFF 
    25242526      !Config  Help = Defines how fast diffusion occurs horizontally between 
    … …  
    25262528      !Config         diffusion. 
    25272529 
    2528       tau_hdiff = 86400. 
     2530      tau_hdiff = one_day 
    25292531      CALL getin_p('HYDROL_TAU_HDIFF',tau_hdiff) 
    25302532 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/intersurf.f90

    r116 r257  
    77!! 
    88!! @call sechiba_main 
    9 !! @Version : $Revision: 1.85 $, $Date: 2010/07/29 15:58:19 $ 
     9!! @Version : $Revision: 221 $, $Date: 2011-05-16 17:26:17 +0200 (Mon, 16 May 2011) $ 
    1010!! 
    1111!! @author Marie-Alice Foujols and Jan Polcher 
    1212!!  
    13 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/intersurf.f90,v 1.85 2010/07/29 15:58:19 ssipsl Exp $ 
     13!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/intersurf.f90 $ 
     14!< $Date: 2011-05-16 17:26:17 +0200 (Mon, 16 May 2011) $ 
     15!< $Author: martial.mancip $ 
     16!< $Revision: 221 $ 
    1417!! IPSL (2006) 
    1518!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 
    … …  
    181184    ! 
    182185    CALL ipslnlf(new_number=numout,old_number=old_fileout) 
    183  
    184186    ! 
    185187    IF (l_first_intersurf) THEN 
    … …  
    225227       IF ( ok_watchout ) THEN 
    226228          IF (is_root_prc) THEN 
    227              zlev_mean = 0. 
     229             zlev_mean = zero 
    228230             DO ik=1, nbp_glo 
    229231                j = ((index_g(ik)-1)/iim_g) + 1 
    … …  
    391393!!$               dt_split_watch,dt_watch,one_day 
    392394!!$          CALL solarang (julian_watch, julian0, iim, jjm, lon, lat, sinang) 
    393 !!$          WHERE ( sinang(:,:) .LT. EPSILON(1.) )  
     395!!$          WHERE ( sinang(:,:) .LT. EPSILON(un) )  
    394396!!$             isinang(:,:) = isinang(:,:) - 1 
    395397!!$          ENDWHERE 
    … …  
    529531          CALL histwrite (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex) 
    530532       !  
    531           CALL histwrite (hist_id, 'temp_sol', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
    532           CALL histwrite (hist_id, 'tsol_max', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
    533           CALL histwrite (hist_id, 'tsol_min', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
    534           CALL histwrite (hist_id, 'fluxsens', itau_sechiba, fluxsens, iim*jjm, kindex) 
    535           CALL histwrite (hist_id, 'fluxlat',  itau_sechiba, fluxlat, iim*jjm, kindex) 
    536           CALL histwrite (hist_id, 'swnet',    itau_sechiba, dswnet, iim*jjm, kindex) 
    537           CALL histwrite (hist_id, 'swdown',   itau_sechiba, dswdown, iim*jjm, kindex) 
    538           CALL histwrite (hist_id, 'alb_vis',  itau_sechiba, albedo(:,:,1), iim*jjm, kindex) 
    539           CALL histwrite (hist_id, 'alb_nir',  itau_sechiba, albedo(:,:,2), iim*jjm, kindex) 
    540           CALL histwrite (hist_id, 'tair',     itau_sechiba, temp_air, iim*jjm, kindex) 
    541           CALL histwrite (hist_id, 'qair',     itau_sechiba, qair, iim*jjm, kindex) 
     533          CALL histwrite (hist_id, 'temp_sol', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
     534          CALL histwrite (hist_id, 'tsol_max', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
     535          CALL histwrite (hist_id, 'tsol_min', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
     536          CALL histwrite (hist_id, 'fluxsens', itau_sechiba, fluxsens, kjpindex, kindex) 
     537          CALL histwrite (hist_id, 'fluxlat',  itau_sechiba, fluxlat, kjpindex, kindex) 
     538          CALL histwrite (hist_id, 'swnet',    itau_sechiba, dswnet, kjpindex, kindex) 
     539          CALL histwrite (hist_id, 'swdown',   itau_sechiba, dswdown, kjpindex, kindex) 
     540          CALL histwrite (hist_id, 'alb_vis',  itau_sechiba, albedo(:,:,1), kjpindex, kindex) 
     541          CALL histwrite (hist_id, 'alb_nir',  itau_sechiba, albedo(:,:,2), kjpindex, kindex) 
     542          CALL histwrite (hist_id, 'tair',     itau_sechiba, temp_air, kjpindex, kindex) 
     543          CALL histwrite (hist_id, 'qair',     itau_sechiba, qair, kjpindex, kindex) 
    542544          ! Ajout Nathalie - Juin 2006 - on conserve q2m/t2m 
    543           CALL histwrite (hist_id, 'q2m',     itau_sechiba, qair, iim*jjm, kindex) 
    544           CALL histwrite (hist_id, 't2m',     itau_sechiba, temp_air, iim*jjm, kindex) 
     545          CALL histwrite (hist_id, 'q2m',     itau_sechiba, qair, kjpindex, kindex) 
     546          CALL histwrite (hist_id, 't2m',     itau_sechiba, temp_air, kjpindex, kindex) 
    545547          IF ( hist2_id > 0 ) THEN 
    546548             CALL histwrite (hist2_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex) 
    … …  
    548550             CALL histwrite (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex) 
    549551             !  
    550              CALL histwrite (hist2_id, 'temp_sol', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
    551              CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
    552              CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
    553              CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, fluxsens, iim*jjm, kindex) 
    554              CALL histwrite (hist2_id, 'fluxlat',  itau_sechiba, fluxlat, iim*jjm, kindex) 
    555              CALL histwrite (hist2_id, 'swnet',    itau_sechiba, dswnet, iim*jjm, kindex) 
    556              CALL histwrite (hist2_id, 'swdown',   itau_sechiba, dswdown, iim*jjm, kindex) 
    557              CALL histwrite (hist2_id, 'alb_vis',  itau_sechiba, albedo(:,:,1), iim*jjm, kindex) 
    558              CALL histwrite (hist2_id, 'alb_nir',  itau_sechiba, albedo(:,:,2), iim*jjm, kindex) 
    559              CALL histwrite (hist2_id, 'tair',     itau_sechiba, temp_air, iim*jjm, kindex) 
    560              CALL histwrite (hist2_id, 'qair',     itau_sechiba, qair, iim*jjm, kindex) 
    561              CALL histwrite (hist2_id, 'q2m',     itau_sechiba, qair, iim*jjm, kindex) 
    562              CALL histwrite (hist2_id, 't2m',     itau_sechiba, temp_air, iim*jjm, kindex) 
     552             CALL histwrite (hist2_id, 'temp_sol', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
     553             CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
     554             CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
     555             CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, fluxsens, kjpindex, kindex) 
     556             CALL histwrite (hist2_id, 'fluxlat',  itau_sechiba, fluxlat, kjpindex, kindex) 
     557             CALL histwrite (hist2_id, 'swnet',    itau_sechiba, dswnet, kjpindex, kindex) 
     558             CALL histwrite (hist2_id, 'swdown',   itau_sechiba, dswdown, kjpindex, kindex) 
     559             CALL histwrite (hist2_id, 'alb_vis',  itau_sechiba, albedo(:,:,1), kjpindex, kindex) 
     560             CALL histwrite (hist2_id, 'alb_nir',  itau_sechiba, albedo(:,:,2), kjpindex, kindex) 
     561             CALL histwrite (hist2_id, 'tair',     itau_sechiba, temp_air, kjpindex, kindex) 
     562             CALL histwrite (hist2_id, 'qair',     itau_sechiba, qair, kjpindex, kindex) 
     563             CALL histwrite (hist2_id, 'q2m',     itau_sechiba, qair, kjpindex, kindex) 
     564             CALL histwrite (hist2_id, 't2m',     itau_sechiba, temp_air, kjpindex, kindex) 
    563565          ENDIF 
    564566       ELSE 
    565567          CALL histwrite (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex) 
    566           CALL histwrite (hist_id, 'SWnet',    itau_sechiba, dswnet, iim*jjm, kindex) 
    567           CALL histwrite (hist_id, 'Qh', itau_sechiba, fluxsens, iim*jjm, kindex) 
    568           CALL histwrite (hist_id, 'Qle',  itau_sechiba, fluxlat, iim*jjm, kindex) 
    569           CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
    570           CALL histwrite (hist_id, 'RadT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
     568          CALL histwrite (hist_id, 'SWnet',    itau_sechiba, dswnet, kjpindex, kindex) 
     569          CALL histwrite (hist_id, 'Qh', itau_sechiba, fluxsens, kjpindex, kindex) 
     570          CALL histwrite (hist_id, 'Qle',  itau_sechiba, fluxlat, kjpindex, kindex) 
     571          CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
     572          CALL histwrite (hist_id, 'RadT', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
    571573          IF ( hist2_id > 0 ) THEN 
    572574             CALL histwrite (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex) 
    573              CALL histwrite (hist2_id, 'SWnet',    itau_sechiba, dswnet, iim*jjm, kindex) 
    574              CALL histwrite (hist2_id, 'Qh', itau_sechiba, fluxsens, iim*jjm, kindex) 
    575              CALL histwrite (hist2_id, 'Qle',  itau_sechiba, fluxlat, iim*jjm, kindex) 
    576              CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
    577              CALL histwrite (hist2_id, 'RadT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex) 
     575             CALL histwrite (hist2_id, 'SWnet',    itau_sechiba, dswnet, kjpindex, kindex) 
     576             CALL histwrite (hist2_id, 'Qh', itau_sechiba, fluxsens, kjpindex, kindex) 
     577             CALL histwrite (hist2_id, 'Qle',  itau_sechiba, fluxlat, kjpindex, kindex) 
     578             CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
     579             CALL histwrite (hist2_id, 'RadT', itau_sechiba, temp_sol_NEW, kjpindex, kindex) 
    578580          ENDIF 
    579581       ENDIF 
    … …  
    780782       ! 
    781783       IF ( ok_watchout ) THEN 
    782           zlev_mean = 0. 
     784          zlev_mean = zero 
    783785          DO ik=1, kjpindex 
    784786 
    … …  
    905907!!$          julian_watch = date0_shifted+((itau_sechiba-0.5)/dt_split_watch)*dt_watch/one_day 
    906908!!$          CALL solarang (julian_watch, julian0, iim, jjm, lon, lat, sinang) 
    907 !!$          WHERE ( sinang(:,:) .LT. EPSILON(1.) )  
     909!!$          WHERE ( sinang(:,:) .LT. EPSILON(un) )  
    908910!!$             isinang(:,:) = isinang(:,:) - 1 
    909911!!$          ENDWHERE 
    … …  
    14481450       IF ( ok_watchout ) THEN 
    14491451          IF (is_root_prc) THEN 
    1450              zlev_mean = 0. 
     1452             zlev_mean = zero 
    14511453             DO ik=1, nbp_glo 
    14521454                j = ((index_g(ik)-1)/iim_g) + 1 
    … …  
    16021604!!$          julian_watch = date0_shifted+((itau_sechiba-0.5)/dt_split_watch)*dt_watch/one_day 
    16031605!!$          CALL solarang (julian_watch, julian0, iim, jjm, tmp_lon, tmp_lat, sinang) 
    1604 !!$          WHERE ( sinang(:,:) .LT. EPSILON(1.) )  
     1606!!$          WHERE ( sinang(:,:) .LT. EPSILON(un) )  
    16051607!!$             isinang(:,:) = isinang(:,:) - 1 
    16061608!!$          ENDWHERE 
    … …  
    21782180       IF ( ok_watchout ) THEN 
    21792181          IF (is_root_prc) THEN 
    2180              zlev_mean = 0. 
     2182             zlev_mean = zero 
    21812183             DO ik=1, nbp_glo 
    21822184                j = ((index_g(ik)-1)/iim_g) + 1 
    … …  
    23322334!!$          julian_watch = date0_shifted+((itau_sechiba-0.5)/dt_split_watch)*dt_watch/one_day 
    23332335!!$          CALL solarang (julian_watch, julian0, iim, jjm, tmp_lon, tmp_lat, sinang) 
    2334 !!$          WHERE ( sinang(:,:) .LT. EPSILON(1.) ) 
     2336!!$          WHERE ( sinang(:,:) .LT. EPSILON(un) ) 
    23352337!!$             isinang(:,:) = isinang(:,:) - 1 
    23362338!!$          ENDWHERE 
    … …  
    25862588       CALL tlen2itau('1Y',dt,date0,year_length) 
    25872589       IF ( TRIM(calendar_str) .EQ. 'gregorian' ) THEN   
    2588           year_spread=1.0 
     2590          year_spread=un 
    25892591       ELSE 
    25902592          year_spread = one_year/365.2425 
    … …  
    26102612       ! Real date 
    26112613       CALL ju2ymds (in_julian, year, month, day, sec) 
    2612 !!$       jur=0. 
     2614!!$       jur=zero 
    26132615!!$       julian_diff = in_julian 
    26142616!!$       month_len = ioget_mon_len (year,month) 
    … …  
    26302632       ENDIF 
    26312633    ELSE  
    2632 !!$       in_julian = itau2date(istp-1, 0., dt) 
     2634!!$       in_julian = itau2date(istp-1, zero, dt) 
    26332635!!$       CALL ju2ymds (in_julian, year, month, day, sec) 
    2634 !!$       jur=0. 
     2636!!$       jur=zero 
    26352637!!$       julian_diff = in_julian 
    26362638!!$       month_len = ioget_mon_len (year,month) 
    … …  
    26932695    CALL getin_p('NVM',nvm) 
    26942696    WRITE(numout,*)'the number of pfts is : ', nvm 
    2695 !!$DS Debug 28/01/2011 
    26962697    ! 
    26972698    !Config Key  = LONGPRINT 
    … …  
    27232724       ! 
    27242725       dt_watch = dt 
    2725        CALL getin('DT_WATCHOUT',dt_watch) 
     2726       CALL getin_p('DT_WATCHOUT',dt_watch) 
    27262727       dt_split_watch = dt_watch / dt 
    27272728       ! 
    … …  
    27402741    ENDIF 
    27412742 
    2742  
    27432743!!$    DS : reading of IMPOSE_PARAM 
    27442744    ! Option : do you want to change the values of the parameters 
    27452745    CALL getin_p('IMPOSE_PARAM',impose_param) 
    2746     ! Calling pft_parameters 
    27472746    CALL pft_parameters_main   
    27482747    ! 
    … …  
    27842783    IF ( control_flags%hydrol_cwrr ) THEN 
    27852784       CALL getin_hydrol_cwrr_parameters 
     2785    ELSE 
     2786       CALL getin_hydrolc_parameters 
     2787       ! we read the parameters for the choisnel hydrology 
    27862788    ENDIF 
    27872789 
    … …  
    28002802       CALL getin_co2_parameters 
    28012803    ENDIF 
    2802  
    2803  
    2804  
    2805 !!$    DS : reading of IMPOSE_PARAM 
    2806 !!$    ! Option : do you want to change the values of the parameters 
    2807 !!$    CALL getin_p('IMPOS_PARAM',impos_param) 
    2808 !!$    ! Calling pft_parameters 
    2809 !!$    CALL pft_main   
    28102804 
    28112805    ! 
    … …  
    28442838       WRITE(numout,*) 'It is not possible because it has to be modified ', & 
    28452839            ' to give correct values.' 
    2846        CALL ipslerr (3,'intsurf_config', & 
    2847          &          'Use of STOMATE_OK_DGVM not allowed with this version.',& 
    2848          &          'ORCHIDEE will stop.', & 
     2840       CALL ipslerr (2,'intsurf_config', & 
     2841         &          'Use of STOMATE_OK_DGVM is not stable for this version.',& 
     2842         &          'ORCHIDEE should not give correct results with this option activated.', & 
    28492843         &          'Please disable DGVM to use this version of ORCHIDEE.') 
    28502844    ENDIF 
    … …  
    29652959    CALL getin_p('SECHIBA_reset_time', overwrite_time) 
    29662960    ! 
    2967     lev(:) = 0. 
     2961    lev(:) = zero 
    29682962    itau_dep = istp 
    29692963    in_julian = itau2date(istp, date0, dt) 
    … …  
    31863180    !Config  Key  = WRITE_STEP 
    31873181    !Config  Desc = Frequency in seconds at which to WRITE output 
    3188     !Config  Def  = 86400.0 
     3182    !Config  Def  = one_day 
    31893183    !Config  Help = This variables gives the frequency the output of 
    31903184    !Config         the model should be written into the netCDF file. 
    … …  
    31983192    ! 
    31993193    veg(1:nvm)   = (/ (REAL(i,r_std),i=1,nvm) /) 
    3200 !$$ DS DEBUG 
    3201     WRITE(numout,*)'nvm : = ', nvm 
    3202     WRITE(numout,*)'veg : =', veg 
    3203 !$$ nvm =13 (put the calling to getin before) 
    32043194    sol(1:ngrnd) = (/ (REAL(i,r_std),i=1,ngrnd) /)    
    32053195    soltyp(1:nstm) = (/ (REAL(i,r_std),i=1,nstm) /) 
    … …  
    32163206    WRITE(flux_sc,'("ave(X*",F8.1,")")') one_day/dt 
    32173207    !WRITE(flux_sc,'("(ave(X)*",F8.1,")")') one_day/dt 
    3218     WRITE(flux_insec,'("ave(X*",F8.6,")")') 1.0/dt 
    3219     WRITE(flux_scinsec,'("ave(scatter(X*",F8.6,"))")') 1.0/dt 
     3208    WRITE(flux_insec,'("ave(X*",F8.6,")")') un/dt 
     3209    WRITE(flux_scinsec,'("ave(scatter(X*",F8.6,"))")') un/dt 
    32203210    WRITE(numout,*) flux_op, one_day/dt, dt, dw 
    32213211    !- 
    … …  
    33713361               & iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)   
    33723362       ENDIF 
    3373        IF ( control_flags%ok_stomate .OR. control_flags%stomate_watchout ) THEN 
    3374           CALL histdef (hist_id,'CO2FLUX','Total output CO2 flux', 'gC/day/(m^2 tot)', & 
    3375                & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(1), dt, dw) 
    3376        ENDIF 
    33773363       !- 
    33783364       !- SECHIBA_HISTLEVEL = 2 
    … …  
    36923678       CALL histdef(hist_id, 'nobiofrac', 'Fraction of other surface types', '1', & 
    36933679            & iim,jjm, hori_id, nnobio, 1, nnobio, nobioax_id, 32, avescatter(3), dt,dw) 
    3694        IF ( control_flags%ok_stomate .OR. control_flags%stomate_watchout ) THEN 
    3695           ! Total output CO2 flux                              
    3696           CALL histdef (hist_id,'CO2FLUX','Total output CO2 flux', 'gC/day/(m^2 tot)', & 
    3697                & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(1), dt, dw) 
    3698        ENDIF 
    36993680     !-  
    37003681     !-  General energy balance 
    … …  
    40334014          CALL histdef(hist2_id, 'emis', 'Surface emissivity', '?', & 
    40344015               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(2), dt, dw2) 
    4035           IF ( control_flags%ok_stomate .OR. control_flags%stomate_watchout ) THEN 
    4036              CALL histdef (hist2_id,'CO2FLUX','Total output CO2 flux', 'gC/day/(m^2 tot)', & 
    4037                   & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(2), dt, dw2) 
    4038           ENDIF 
    40394016          !- 
    40404017          !- SECHIBA_HISTLEVEL2 = 3 
    … …  
    42984275          CALL histdef(hist2_id, 'nobiofrac', 'Fraction of other surface types', '1', & 
    42994276               & iim,jjm, hori_id2, nnobio, 1, nnobio, nobioax_id2, 32, avescatter2(3), dt, dw2) 
    4300           IF ( control_flags%ok_stomate .OR. control_flags%stomate_watchout ) THEN 
    4301              CALL histdef (hist2_id,'CO2FLUX','Total output CO2 flux', 'gC/day/(m^2 tot)', & 
    4302                   & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(1), dt, dw2) 
    4303           ENDIF 
    43044277          !-  
    43054278          !-  General energy balance 
    … …  
    44654438       hist_days_stom = 10. 
    44664439       CALL getin_p('STOMATE_HIST_DT', hist_days_stom)        
    4467        IF ( hist_days_stom == -1. ) THEN 
    4468           hist_dt_stom = -1. 
     4440       IF ( hist_days_stom == moins_un ) THEN 
     4441          hist_dt_stom = moins_un 
    44694442          WRITE(numout,*) 'output frequency for STOMATE history file (d): one month.' 
    44704443       ELSE 
    … …  
    44774450       dt_slow_ = one_day 
    44784451       CALL getin_p('DT_SLOW', dt_slow_) 
    4479        IF ( hist_days_stom /= -1. ) THEN 
     4452       IF ( hist_days_stom /= moins_un ) THEN 
    44804453          IF (dt_slow_ > hist_dt_stom) THEN 
    44814454             WRITE(numout,*) "DT_SLOW = ",dt_slow_,"  , STOMATE_HIST_DT = ",hist_dt_stom 
    … …  
    45674540       !Config  Help = Time step of the STOMATE IPCC history file 
    45684541       !- 
    4569        hist_days_stom_ipcc = 0. 
     4542       hist_days_stom_ipcc = zero 
    45704543       CALL getin_p('STOMATE_IPCC_HIST_DT', hist_days_stom_ipcc)        
    4571        IF ( hist_days_stom_ipcc == -1. ) THEN 
    4572           hist_dt_stom_ipcc = -1. 
     4544       IF ( hist_days_stom_ipcc == moins_un ) THEN 
     4545          hist_dt_stom_ipcc = moins_un 
    45734546          WRITE(numout,*) 'output frequency for STOMATE IPCC history file (d): one month.' 
    45744547       ELSE 
    … …  
    45814554       dt_slow_ = one_day 
    45824555       CALL getin_p('DT_SLOW', dt_slow_) 
    4583        IF ( hist_days_stom_ipcc > 0. ) THEN 
     4556       IF ( hist_days_stom_ipcc > zero ) THEN 
    45844557          IF (dt_slow_ > hist_dt_stom_ipcc) THEN 
    45854558             WRITE(numout,*) "DT_SLOW = ",dt_slow_,"  , STOMATE_IPCC_HIST_DT = ",hist_dt_stom_ipcc 
    … …  
    48224795         &               1,1,1, -99,32, ave(5), dt, hist_dt) 
    48234796 
    4824     ! Monthly CO2 flux                                   
    4825     CALL histdef (hist_id_stom, & 
    4826          &               TRIM("CO2FLUX_MONTHLY     "), & 
    4827          &               TRIM("Monthly CO2 flux                                  "), & 
     4797    ! CO2 flux                                   
     4798    CALL histdef (hist_id_stom, & 
     4799         &               TRIM("CO2FLUX             "), & 
     4800         &               TRIM("CO2 flux                                          "), & 
    48284801         &               TRIM("gC/m^2/pft/mth      "), iim,jjm, hist_hori_id, & 
    48294802         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt) 
    48304803 
    4831     CALL histdef(hist_id_stom, & 
    4832          &               TRIM("CO2FLUX_MONTHLY_SUM "), & 
    4833          &               TRIM("Monthly CO2 flux                                  "), & 
    4834          &               TRIM("PgC/m^2/mth          "), 1,1, hist_hori_id, & 
    4835          &               1,1,1, -99, 32, ave(1), dt, hist_dt) 
     4804!!$    CALL histdef(hist_id_stom, & 
     4805!!$         &               TRIM("CO2FLUX_MONTHLY_SUM "), & 
     4806!!$         &               TRIM("Monthly CO2 flux Sum                              "), & 
     4807!!$         &               TRIM("PgC/m^2/mth         "), iim,jjm, hist_hori_id, & 
     4808!!$         &               1,1,1, -99, 32, 'inst(scatter(X))', dt, hist_dt) 
    48364809 
    48374810    ! Output CO2 flux from fire                          
    … …  
    51215094         &               TRIM("1/day               "), iim,jjm, hist_hori_id, & 
    51225095         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(6), dt, hist_dt) 
     5096 
     5097    ! Establish tree 
     5098    CALL histdef (hist_id_stom, & 
     5099         &               TRIM("ESTABTREE           "), & 
     5100         &               TRIM("Rate of tree establishement                       "), & 
     5101         &               TRIM("1/day               "), iim,jjm, hist_hori_id, & 
     5102         &               1,1,1, -99,32, ave(6), dt, hist_dt) 
     5103 
     5104    ! Establish grass 
     5105    CALL histdef (hist_id_stom, & 
     5106         &               TRIM("ESTABGRASS          "), & 
     5107         &               TRIM("Rate of grass establishement                      "), & 
     5108         &               TRIM("1/day               "), iim,jjm, hist_hori_id, & 
     5109         &               1,1,1, -99,32, ave(6), dt, hist_dt) 
    51235110 
    51245111    ! Fraction of plants that dies (light competition)   

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/sechiba.f90

    r142 r257  
    44!! 
    55!! @author Marie-Alice Foujols and Jan Polcher 
    6 !! @Version : $Revision: 1.46 $, $Date: 2010/05/07 08:28:13 $ 
     6!! @Version : $Revision: 45 $, $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
    77!!  
    8 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/sechiba.f90,v 1.46 2010/05/07 08:28:13 ssipsl Exp $ 
     8!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/sechiba.f90 $ 
     9!< $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
     10!< $Author: mmaipsl $ 
     11!< $Revision: 45 $ 
    912!! IPSL (2006) 
    1013!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 
    … …  
    239242    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: tsol_rad         !! Radiative surface temperature 
    240243    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapp           !! Total of evaporation 
    241     REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: temp_sol_new     !! New soil temperature 
     244    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)           :: temp_sol_new     !! New soil temperature 
    242245    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsurf_out        !! Surface specific humidity 
    243246    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: z0_out           !! Surface roughness (output diagnostic) 
    … …  
    256259    REAL(r_std), DIMENSION(kjpindex) :: sum_treefrac, sum_grassfrac, sum_cropfrac 
    257260    INTEGER(i_std) :: jv 
    258  
    259  
    260  
    261261 
    262262    IF (long_print) WRITE(numout,*) ' kjpindex =',kjpindex 
    … …  
    636636       ENDIF 
    637637 
    638        histvar(:)=SUM(vevapwet(:,:),dim=2)/86400 
     638       histvar(:)=SUM(vevapwet(:,:),dim=2)/one_day 
    639639       CALL histwrite(hist_id, 'evspsblveg', kjit, histvar, kjpindex, index) 
    640640 
    641        histvar(:)=(vevapnu(:)+vevapsno(:))/86400 
     641       histvar(:)=(vevapnu(:)+vevapsno(:))/one_day 
    642642       CALL histwrite(hist_id, 'evspsblsoi', kjit, histvar, kjpindex, index) 
    643643 
    644        histvar(:)=SUM(transpir(:,:),dim=2)/86400 
     644       histvar(:)=SUM(transpir(:,:),dim=2)/one_day 
    645645       CALL histwrite(hist_id, 'tran', kjit, histvar, kjpindex, index) 
    646  
    647 !------------------------------------ 
    648  
    649 !       histvar(:)=SUM(veget_max(:,2:9),dim=2)*100*contfrac(:) 
    650 !       CALL histwrite(hist_id, 'treeFrac', kjit, histvar, kjpindex, index) 
    651  
    652 !       histvar(:)=SUM(veget_max(:,10:11),dim=2)*100*contfrac(:) 
    653 !       CALL histwrite(hist_id, 'grassFrac', kjit, histvar, kjpindex, index) 
    654  
    655 !       histvar(:)=SUM(veget_max(:,12:13),dim=2)*100*contfrac(:) 
    656 !       CALL histwrite(hist_id, 'cropFrac', kjit, histvar, kjpindex, index) 
    657646 
    658647!$$ 25/10/10 Modif DS & NViovy 
    … …  
    666655       histvar(:)= sum_cropfrac(:)*100*contfrac(:) 
    667656       CALL histwrite(hist_id, 'cropFrac', kjit, histvar, kjpindex, index) 
    668  
    669657 
    670658       histvar(:)=veget_max(:,1)*100*contfrac(:) 
    … …  
    13471335    ENDDO 
    13481336 
    1349  
    13501337    ! 
    13511338    ! 2. restart value 
    … …  
    13721359    ! 
    13731360 
     1361    control%river_routing = control_in%river_routing 
     1362    control%hydrol_cwrr = control_in%hydrol_cwrr 
    13741363    control%ok_co2 = control_in%ok_co2 
    13751364    control%ok_sechiba = control_in%ok_sechiba 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/sechiba_io.f90

    r64 r257  
    1010!! 
    1111!! @author Marie-Alice Foujols and Jan Polcher 
    12 !! @Version : $Revision: 1.8 $, $Date: 2008/03/21 13:56:12 $ 
     12!! @Version : $Revision: 12 $, $Date: 2010-11-05 16:42:13 +0100 (Fri, 05 Nov 2010) $ 
    1313!!  
    14 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/sechiba_io.f90,v 1.8 2008/03/21 13:56:12 ssipsl Exp $ 
     14!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/sechiba_io.f90 $ 
     15!< $Date: 2010-11-05 16:42:13 +0100 (Fri, 05 Nov 2010) $ 
     16!< $Author: mmaipsl $ 
     17!< $Revision: 12 $ 
    1518!! IPSL (2006) 
    1619!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/sechiba_io_p.f90

    r64 r257  
    1010!! 
    1111!! @author Marie-Alice Foujols and Jan Polcher 
    12 !! @Version : $Revision: 1.4 $, $Date: 2008/03/21 13:56:12 $ 
     12!! @Version : $Revision: 12 $, $Date: 2010-11-05 16:42:13 +0100 (Fri, 05 Nov 2010) $ 
    1313!!  
    14 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/sechiba_io_p.f90,v 1.4 2008/03/21 13:56:12 ssipsl Exp $ 
     14!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/sechiba_io_p.f90 $ 
     15!< $Date: 2010-11-05 16:42:13 +0100 (Fri, 05 Nov 2010) $ 
     16!< $Author: mmaipsl $ 
     17!< $Revision: 12 $ 
    1518!! IPSL (2006) 
    1619!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/slowproc.f90

    r143 r257  
    22! Daily update of leaf area index etc. 
    33! 
    4 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/slowproc.f90,v 1.48 2010/04/20 14:12:04 ssipsl Exp $ 
     4!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/slowproc.f90 $ 
     5!< $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
     6!< $Author: mmaipsl $ 
     7!< $Revision: 45 $ 
    58!! IPSL (2006) 
    69!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 
    … …  
    5457  LOGICAL, SAVE                                   :: old_lai = .FALSE.         ! Old Lai Map interpolation 
    5558  LOGICAL, SAVE                                   :: impveg = .FALSE. 
     59  LOGICAL, SAVE                                   :: impsoilt = .FALSE. 
    5660  LOGICAL, SAVE                                   :: old_veget = .FALSE.         ! Old veget Map interpolation 
    5761  ! 
    … …  
    143147    LOGICAL, PARAMETER                                 :: check = .FALSE. 
    144148 
    145     REAL(r_std), SAVE                                       :: sec_old = 0. 
     149    REAL(r_std), SAVE                                       :: sec_old = zero 
    146150    ! 
    147151    ! do initialisation 
    … …  
    299303    ! Test each day and assert all slow processes (days and years) 
    300304    ! 
    301     IF ( sec_old >= one_day - dtradia .AND.  sec >= 0. ) THEN 
     305    IF ( sec_old >= one_day - dtradia .AND.  sec >= zero ) THEN 
    302306       ! 
    303307       ! reset counter 
    … …  
    510514    LOGICAL, PARAMETER                                 :: check = .FALSE. 
    511515    ! 
    512     ! DS 15032011 add for replacing SUM(veget_max(ji,nvm-1:nvm  
     516    ! DS 15032011 add for replacing SUM(veget_max(ji,nvm-1:nvm))  
    513517    REAL(r_std)    :: sum_veget_max 
    514     ! 
    515  
    516518 
    517519    ! 
    … …  
    582584    !Config        only done once a day. 
    583585    ! 
    584     CALL setvar_p (day_counter, val_exp, 'SECHIBA_DAY', 0.0_r_std) 
     586    CALL setvar_p (day_counter, val_exp, 'SECHIBA_DAY', zero) 
    585587    ! 
    586588    !Config Key  = LAI_MAP 
    … …  
    733735       CALL restget_p (rest_id, var_name, nbp_glo, nvm, 12, kjit, .TRUE., laimap) 
    734736       ! 
     737    ELSE 
     738       ! 
     739       ALLOCATE (laimap(1,1,1)) 
    735740    ENDIF 
    736741    ! 
    … …  
    806811    !Config  Key  = DT_SLOW 
    807812    !Config  Desc = Time step of STOMATE and other slow processes 
    808     !Config  Def  = 86400. 
     813    !Config  Def  = one_day 
    809814    !Config  Help = Time step (s) of regular update of vegetation 
    810815    !Config         cover, LAI etc. This is also the time step 
    … …  
    905910       CALL setvar_p (lai, val_exp, 'SECHIBA_LAI', llaimax) 
    906911 
    907   
    908        !Config Key  = SOIL_FRACTIONS 
    909        !Config Desc = Fraction of the 3 soil types (0-dim mode) 
    910        !Config Def  = 0.28, 0.52, 0.20 
     912       ! 
     913       !Config Key  = IMPOSE_SOILT 
     914       !Config Desc = Should the soil typ be prescribed 
     915       !Config Def  = n 
    911916       !Config If   = IMPOSE_VEG 
    912        !Config Help = Determines the fraction for the 3 soil types 
    913        !Config        in the mesh in the following order : sand loam and clay. 
    914        ! 
    915        CALL setvar_p (soiltype, val_exp, 'SOIL_FRACTIONS', soiltype_default) 
    916  
    917  
    918        !Config Key  = CLAY_FRACTION 
    919        !Config Desc = Fraction of the clay fraction (0-dim mode) 
    920        !Config Def  = 0.2 
    921        !Config If   = IMPOSE_VEG 
    922        !Config Help = Determines the fraction of clay in the grid box. 
    923        ! 
    924        CALL setvar_p (clayfraction, val_exp, 'CLAY_FRACTION', clayfraction_default) 
    925  
     917       !Config Help = This flag allows the user to impose a soil type distribution. 
     918       !Config        It is espacially interesting for 0D 
     919       !Config        simulations. On the globe it does not make too much sense as 
     920       !Config        it imposes the same soil everywhere 
     921       ! 
     922       impsoilt = .FALSE. 
     923       CALL getin_p('IMPOSE_SOILT', impsoilt) 
     924       IF (impsoilt) THEN 
     925          !Config Key  = SOIL_FRACTIONS 
     926          !Config Desc = Fraction of the 3 soil types (0-dim mode) 
     927          !Config Def  = 0.28, 0.52, 0.20 
     928          !Config If   = IMPOSE_VEG 
     929          !Config If   = IMPOSE_SOILT 
     930          !Config Help = Determines the fraction for the 3 soil types 
     931          !Config        in the mesh in the following order : sand loam and clay. 
     932          ! 
     933          CALL setvar_p (soiltype, val_exp, 'SOIL_FRACTIONS', soiltype_default) 
     934 
     935          !Config Key  = CLAY_FRACTION 
     936          !Config Desc = Fraction of the clay fraction (0-dim mode) 
     937          !Config Def  = 0.2 
     938          !Config If   = IMPOSE_VEG 
     939          !Config If   = IMPOSE_SOILT 
     940          !Config Help = Determines the fraction of clay in the grid box. 
     941          ! 
     942          CALL setvar_p (clayfraction, val_exp, 'CLAY_FRACTION', clayfraction_default) 
     943       ELSE 
     944          IF ( MINVAL(soiltype) .EQ. MAXVAL(soiltype) .AND. MAXVAL(soiltype) .EQ. val_exp .OR.& 
     945               & MINVAL(clayfraction) .EQ. MAXVAL(clayfraction) .AND. MAXVAL(clayfraction) .EQ. val_exp) THEN 
     946 
     947             CALL slowproc_soilt(kjpindex, lalo, neighbours, resolution, contfrac, soiltype, clayfraction) 
     948          ENDIF 
     949       ENDIF 
    926950       ! 
    927951       !Config Key  = SLOWPROC_HEIGHT 
    … …  
    10051029             ! If restart doesn't contain veget, then it is the first computation 
    10061030             CALL slowproc_update(kjpindex, lalo, neighbours, resolution, contfrac, & 
    1007                   &               veget_max, frac_nobio, veget_max, frac_nobio, veget_year, init=.TRUE.) 
     1031               &               veget_nextyear, frac_nobio_nextyear, veget_max, frac_nobio, veget_year, init=.TRUE.) 
    10081032             ! 
    10091033             IF ( control%ok_dgvm  ) THEN 
    … …  
    11721196       ! 
    11731197    CASE('MAXR') 
    1174        pref_soil_veg(:,1) = pref_soil_veg_sand 
    1175        pref_soil_veg(:,2) = pref_soil_veg_loan       
    1176        pref_soil_veg(:,3) = pref_soil_veg_clay 
     1198       pref_soil_veg(:,1) = pref_soil_veg_sand(:) 
     1199       pref_soil_veg(:,2) = pref_soil_veg_loan(:)       
     1200       pref_soil_veg(:,3) = pref_soil_veg_clay(:) 
    11771201       ! 
    11781202       ! Current default : equidistribution. 
    … …  
    13651389    ! 
    13661390 
    1367     IF ( ( tau .LT. dt ) .OR. ( dt .LE. 0. ) .OR. ( tau .LE. 0. ) ) THEN 
     1391    IF ( ( tau .LT. dt ) .OR. ( dt .LE. zero ) .OR. ( tau .LE. zero ) ) THEN 
    13681392       WRITE(numout,*) 'slowproc_long: Problem with time steps' 
    13691393       WRITE(numout,*) 'dt=',dt 
    … …  
    14111435    ! 1.1 Sum up 
    14121436    ! 
    1413     fracsum(:) = 0. 
     1437    fracsum(:) = zero 
    14141438    DO jv = 1, nnobio 
    14151439       DO ji = 1, kjpindex 
    … …  
    14771501       ENDDO 
    14781502    ENDDO 
    1479      
    14801503    ! 
    14811504    ! 3. if lai of a vegetation type (jv > 1) is small, increase soil part 
    … …  
    15011524    ! Ajout Nouveau calcul (stomate-like)  
    15021525    DO ji = 1, kjpindex 
    1503        SUMveg = 0.0 
     1526       SUMveg = zero 
    15041527       veget(ji,1) = veget_max(ji,1) 
    15051528       DO jv = 2, nvm 
    1506           veget(ji,jv) = veget_max(ji,jv) * ( 1. - exp( - lai(ji,jv) * ext_coeff(jv) ) ) 
     1529          veget(ji,jv) = veget_max(ji,jv) * ( un - exp( - lai(ji,jv) * ext_coeff(jv) ) ) 
    15071530          veget(ji,1) = veget(ji,1) + (veget_max(ji,jv) - veget(ji,jv)) 
    15081531          SUMveg = SUMveg + veget(ji,jv) 
    … …  
    15151538       ENDIF 
    15161539    ENDDO 
    1517  
    15181540    ! 
    15191541    ! 4. Sum up surface fractions and test if the sum is equal to 1 
    … …  
    15231545    ! 4.1 Sum up 
    15241546    ! 
    1525     fracsum(:) = 0. 
     1547    fracsum(:) = zero 
    15261548    DO jv = 1, nnobio 
    15271549       DO ji = 1, kjpindex 
    … …  
    15991621    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)     :: resolution !! size in x an y of the grid (m) 
    16001622 
    1601     REAL(r_std), DIMENSION(kjpindex,nvm,12), INTENT(in) :: laimap     !! LAI lue 
     1623    REAL(r_std), DIMENSION(:,:,:), INTENT(in)          :: laimap     !! LAI lue 
    16021624    LOGICAL, INTENT(in)                                :: read_lai 
    16031625    ! 0.2 Output 
    … …  
    16101632    ! Test Nathalie. On impose LAI PFT 1 a 0 
    16111633    ! On boucle sur 2,nvm au lieu de 1,nvm 
    1612     lai(: ,1) = 0.0 
     1634    lai(: ,1) = zero 
    16131635    DO jv = 2,nvm 
    16141636!!$    DO jv = 1,nvm 
    … …  
    17711793    ! 
    17721794    WHERE  ( laimaporig(:,:,:) .LT. 0 ) 
    1773        laimaporig(:,:,:) = 0. 
     1795       laimaporig(:,:,:) = zero 
    17741796    ENDWHERE 
    17751797    ! 
    … …  
    18311853    ilast = 1 
    18321854    n_origlai(:) = 0 
    1833     laimap(:,:,:) = 0.     
     1855    laimap(:,:,:) = zero    
    18341856    ! 
    18351857    DO ip=1,ijml 
    … …  
    19431965             ! Antartica 
    19441966             DO jv =1,nvm 
    1945                 laimap(ip,jv,:) = 0. 
     1967                laimap(ip,jv,:) = zero 
    19461968             ENDDO 
    19471969             ! 
    … …  
    19491971             ! Artica 
    19501972             DO jv =1,nvm 
    1951                 laimap(ip,jv,:) = 0. 
     1973                laimap(ip,jv,:) = zero 
    19521974             ENDDO 
    19531975             ! 
    … …  
    19551977             ! Greenland 
    19561978             DO jv =1,nvm 
    1957                 laimap(ip,jv,:) = 0. 
     1979                laimap(ip,jv,:) = zero 
    19581980             ENDDO 
    19591981             ! 
    … …  
    25902612       DO ib = 1, nbpt 
    25912613          idi=1 
    2592           sumf=0. 
     2614          sumf=zero 
    25932615          DO WHILE ( sub_area(ib,idi) > zero )  
    25942616             ip = sub_index(ib,idi,1) 
    … …  
    26222644             IF (PRESENT(init)) THEN 
    26232645                IF (init) THEN 
    2624 !                   veget_next(ib,:) = (/ 1., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0. /) 
    2625                     veget_next(ib,1) = 1. 
     2646                    veget_next(ib,1) = un 
    26262647                    veget_next(ib,2:nvm) = zero 
    26272648                ELSE 
    … …  
    26582679          ! 
    26592680          idi=1 
    2660           sumf=0. 
     2681          sumf=zero 
    26612682          DO WHILE ( sub_area(ib,idi) > zero )  
    26622683             ip = sub_index(ib,idi,1) 
    … …  
    27632784          err=norm-un 
    27642785          IF (debug) & 
    2765              WRITE(numout,*) "ib ",ib," SUM(veget_next(ib,:)+frac_nobio_next(ib,:))-1., sumf",err,sumf 
    2766           IF (abs(err) > -EPSILON(1._r_std)) THEN 
     2786             WRITE(numout,*) "ib ",ib," SUM(veget_next(ib,:)+frac_nobio_next(ib,:))-un, sumf",err,sumf 
     2787          IF (abs(err) > -EPSILON(un)) THEN 
    27672788!MM 1.9.3 
    27682789!          IF (abs(err) > 0.) THEN 
    … …  
    27752796             err=norm-un 
    27762797             IF (debug) & 
    2777                   WRITE(numout,*) "ib ",ib," SUM(veget_next(ib,:)+frac_nobio_next(ib,:))-1.",err 
    2778              IF (abs(err) > EPSILON(1._r_std)) THEN 
     2798                  WRITE(numout,*) "ib ",ib," SUM(veget_next(ib,:)+frac_nobio_next(ib,:))-un",err 
     2799             IF (abs(err) > EPSILON(un)) THEN 
    27792800!MM 1.9.3 
    27802801!             IF (abs(err) > 0.) THEN 
    … …  
    29272948       ! 
    29282949       ! 
    2929        veget(ib,:) = 0.0 
    2930        frac_nobio (ib,:) = 0.0 
     2950       veget(ib,:) = zero 
     2951       frac_nobio (ib,:) = zero 
    29312952       ! 
    29322953    ENDDO 
    … …  
    30633084        frac_origveg(:,vid) =  REAL(n_origveg(:,vid),r_std) /  REAL(n_found(:),r_std) 
    30643085      ELSEWHERE 
    3065          frac_origveg(:,vid) = 0. 
     3086         frac_origveg(:,vid) = zero 
    30663087      ENDWHERE 
    30673088    ENDDO 
    … …  
    30993120          IF ( lalo(ib,1) .LT. -56.0) THEN 
    31003121             ! Antartica 
    3101              frac_nobio(ib,:) = 0.0 
    3102              frac_nobio(ib,iice) = 1.0 
    3103              veget(ib,:) = 0.0 
     3122             frac_nobio(ib,:) = zero 
     3123             frac_nobio(ib,iice) = un 
     3124             veget(ib,:) = zero 
    31043125             ! 
    31053126          ELSE IF ( lalo(ib,1) .GT. 70.0) THEN 
    31063127             ! Artica 
    3107              frac_nobio(ib,:) = 0.0 
    3108              frac_nobio(ib,iice) = 1.0 
    3109              veget(ib,:) = 0.0 
     3128             frac_nobio(ib,:) = zero 
     3129             frac_nobio(ib,iice) = un 
     3130             veget(ib,:) = zero 
    31103131             ! 
    31113132          ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN 
    31123133             ! Greenland 
    3113              frac_nobio(ib,:) = 0.0 
    3114              frac_nobio(ib,iice) = 1.0 
    3115              veget(ib,:) = 0.0 
     3134             frac_nobio(ib,:) = zero 
     3135             frac_nobio(ib,iice) = un 
     3136             veget(ib,:) = zero 
    31163137             ! 
    31173138          ELSE 
    … …  
    31443165       DO vid = 1, nvm 
    31453166          IF ( veget(ib,vid) .LT. min_vegfrac ) THEN 
    3146              veget(ib,vid) = 0.0 
     3167             veget(ib,vid) = zero 
    31473168          ENDIF 
    31483169       ENDDO 
    … …  
    33463367          frac_origveg(:,vid) = n_origveg(:,vid) / n_found(:) 
    33473368       ELSEWHERE 
    3348           frac_origveg(:,vid) = 0. 
     3369          frac_origveg(:,vid) = zero 
    33493370       ENDWHERE 
    33503371    ENDDO 
    … …  
    33823403          IF ( lalo(ib,1) .LT. -56.0) THEN 
    33833404             ! Antartica 
    3384              frac_nobio(ib,:) = 0.0 
    3385              frac_nobio(ib,iice) = 1.0 
    3386              veget(ib,:) = 0.0 
     3405             frac_nobio(ib,:) = zero 
     3406             frac_nobio(ib,iice) = un 
     3407             veget(ib,:) = zero 
    33873408             ! 
    33883409          ELSE IF ( lalo(ib,1) .GT. 70.0) THEN 
    33893410             ! Artica 
    3390              frac_nobio(ib,:) = 0.0 
    3391              frac_nobio(ib,iice) = 1.0 
    3392              veget(ib,:) = 0.0 
     3411             frac_nobio(ib,:) = zero 
     3412             frac_nobio(ib,iice) = un 
     3413             veget(ib,:) = zero 
    33933414             ! 
    33943415          ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN 
    33953416             ! Greenland 
    3396              frac_nobio(ib,:) = 0.0 
    3397              frac_nobio(ib,iice) = 1.0 
    3398              veget(ib,:) = 0.0 
     3417             frac_nobio(ib,:) = zero 
     3418             frac_nobio(ib,iice) = un 
     3419             veget(ib,:) = zero 
    33993420             ! 
    34003421          ELSE 
    … …  
    34273448       DO vid = 1, nvm 
    34283449          IF ( veget(ib,vid) .LT. min_vegfrac ) THEN 
    3429              veget(ib,vid) = 0.0 
     3450             veget(ib,vid) = zero 
    34303451          ENDIF 
    34313452       ENDDO 
    … …  
    35543575       ! 
    35553576       ! 
    3556        veget(ib,:) = 0.0 
    3557        frac_nobio (ib,:) = 0.0 
     3577       veget(ib,:) = zero 
     3578       frac_nobio (ib,:) = zero 
    35583579       ! 
    35593580    ENDDO 
    … …  
    36903711        frac_origveg(:,vid) =  REAL(n_origveg(:,vid),r_std) /  REAL(n_found(:),r_std) 
    36913712      ELSEWHERE 
    3692          frac_origveg(:,vid) = 0. 
     3713         frac_origveg(:,vid) = zero 
    36933714      ENDWHERE 
    36943715    ENDDO 
    … …  
    37263747          IF ( lalo(ib,1) .LT. -56.0) THEN 
    37273748             ! Antartica 
    3728              frac_nobio(ib,:) = 0.0 
    3729              frac_nobio(ib,iice) = 1.0 
    3730              veget(ib,:) = 0.0 
     3749             frac_nobio(ib,:) = zero 
     3750             frac_nobio(ib,iice) = un 
     3751             veget(ib,:) = zero 
    37313752             ! 
    37323753          ELSE IF ( lalo(ib,1) .GT. 70.0) THEN 
    37333754             ! Artica 
    3734              frac_nobio(ib,:) = 0.0 
    3735              frac_nobio(ib,iice) = 1.0 
    3736              veget(ib,:) = 0.0 
     3755             frac_nobio(ib,:) = zero 
     3756             frac_nobio(ib,iice) = un 
     3757             veget(ib,:) = zero 
    37373758             ! 
    37383759          ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN 
    37393760             ! Greenland 
    3740              frac_nobio(ib,:) = 0.0 
    3741              frac_nobio(ib,iice) = 1.0 
    3742              veget(ib,:) = 0.0 
     3761             frac_nobio(ib,:) = zero 
     3762             frac_nobio(ib,iice) = un 
     3763             veget(ib,:) = zero 
    37433764             ! 
    37443765          ELSE 
    … …  
    37713792       DO vid = 1, nvm 
    37723793          IF ( veget(ib,vid) .LT. min_vegfrac ) THEN 
    3773              veget(ib,vid) = 0.0 
     3794             veget(ib,vid) = zero 
    37743795          ENDIF 
    37753796       ENDDO 
    … …  
    39623983          frac_origveg(:,vid) = n_origveg(:,vid) / n_found(:) 
    39633984       ELSEWHERE 
    3964           frac_origveg(:,vid) = 0. 
     3985          frac_origveg(:,vid) = zero 
    39653986       ENDWHERE 
    39663987    ENDDO 
    … …  
    39984019          IF ( lalo(ib,1) .LT. -56.0) THEN 
    39994020             ! Antartica 
    4000              frac_nobio(ib,:) = 0.0 
    4001              frac_nobio(ib,iice) = 1.0 
    4002              veget(ib,:) = 0.0 
     4021             frac_nobio(ib,:) = zero 
     4022             frac_nobio(ib,iice) = un 
     4023             veget(ib,:) = zero 
    40034024             ! 
    40044025          ELSE IF ( lalo(ib,1) .GT. 70.0) THEN 
    40054026             ! Artica 
    4006              frac_nobio(ib,:) = 0.0 
    4007              frac_nobio(ib,iice) = 1.0 
    4008              veget(ib,:) = 0.0 
     4027             frac_nobio(ib,:) = zero 
     4028             frac_nobio(ib,iice) = un 
     4029             veget(ib,:) = zero 
    40094030             ! 
    40104031          ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN 
    40114032             ! Greenland 
    4012              frac_nobio(ib,:) = 0.0 
    4013              frac_nobio(ib,iice) = 1.0 
    4014              veget(ib,:) = 0.0 
     4033             frac_nobio(ib,:) = zero 
     4034             frac_nobio(ib,iice) = un 
     4035             veget(ib,:) = zero 
    40154036             ! 
    40164037          ELSE 
    … …  
    40434064       DO vid = 1, nvm 
    40444065          IF ( veget(ib,vid) .LT. min_vegfrac ) THEN 
    4045              veget(ib,vid) = 0.0 
     4066             veget(ib,vid) = zero 
    40464067          ENDIF 
    40474068       ENDDO 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/thermosoil.f90

    r64 r257  
    33!! 
    44!! @author Marie-Alice Foujols and Jan Polcher 
    5 !! @Version : $Revision: 1.15 $, $Date: 2009/01/07 13:39:45 $ 
     5!! @Version : $Revision: 45 $, $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
    66!!  
    7 !! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/thermosoil.f90,v 1.15 2009/01/07 13:39:45 ssipsl Exp $ 
     7!< $HeadURL: http://forge.ipsl.jussieu.fr/orchidee/svn/trunk/ORCHIDEE/src_sechiba/thermosoil.f90 $ 
     8!< $Date: 2011-01-01 21:30:44 +0100 (Sat, 01 Jan 2011) $ 
     9!< $Author: mmaipsl $ 
     10!< $Revision: 45 $ 
    811!! IPSL (2006) 
    912!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC 
    … …  
    98101    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_sol_new     !! New soil temperature 
    99102    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: snow             !! Snow quantity 
     103    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in) :: shumdiag         !! Diagnostic of relative humidity 
    100104    ! output fields 
    101     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: soilcap          !! Soil capacity 
    102     REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: soilflx           
    103     REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in) :: shumdiag         !! Diagnostic of relative humidity 
    104     REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: stempdiag        !! diagnostic temp profile 
     105    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: soilcap        !! Soil capacity 
     106    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: soilflx           
     107    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (inout):: stempdiag        !! diagnostic temp profile 
    105108 
    106109    REAL(r_std),DIMENSION (kjpindex,ngrnd) :: temp 
    … …  
    645648    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: soilflx           !! 
    646649    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: z1                !! 
    647     REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: pcapa             !! 
    648     REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: pcapa_en          !! 
    649     REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: pkappa            !! 
     650    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(inout)     :: pcapa             !! 
     651    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(inout)     :: pcapa_en          !! 
     652    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(inout)     :: pkappa            !! 
    650653    REAL(r_std), DIMENSION (kjpindex,ngrnd-1), INTENT(out)     :: cgrnd             !! 
    651654    REAL(r_std), DIMENSION (kjpindex,ngrnd-1), INTENT(out)     :: dgrnd             !! 
    … …  
    837840                lev_prog = prev_prog + dz2(jg) 
    838841             ENDIF 
    839             intfact(jd,jg) = MAX(MIN(lev_diag,lev_prog)-MAX(prev_diag, prev_prog), 0.0)/(lev_diag-prev_diag) 
     842            intfact(jd,jg) = MAX(MIN(lev_diag,lev_prog)-MAX(prev_diag, prev_prog), zero)/(lev_diag-prev_diag) 
    840843            prev_prog = lev_prog 
    841844          ENDDO 
    … …  
    857860    ENDIF 
    858861 
    859     stempdiag(:,:) = 0. 
     862    stempdiag(:,:) = zero 
    860863    DO jg = 1, ngrnd 
    861864      DO jd = 1, nbdl 
    … …  
    907910                lev_prog = diaglev(jg) 
    908911             ENDIF 
    909              intfactw(jd,jg) = MAX(MIN(lev_diag,lev_prog)-MAX(prev_diag, prev_prog), 0.0)/(lev_diag-prev_diag) 
     912             intfactw(jd,jg) = MAX(MIN(lev_diag,lev_prog)-MAX(prev_diag, prev_prog), zero)/(lev_diag-prev_diag) 
    910913             prev_prog = lev_prog 
    911914          ENDDO 
    … …  
    927930    ENDIF 
    928931 
    929     wetdiag(:,:) = 0. 
     932    wetdiag(:,:) = zero 
    930933    DO jg = 1, nbdl 
    931934      DO jd = 1, ngrnd 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_sechiba/watchout.f90

    r64 r257  
    33  USE defprec 
    44  USE parallel 
     5  USE constantes 
    56  USE netcdf 
    67 
    … …  
    1011 
    1112  LOGICAL,SAVE,PUBLIC             :: ok_watchout = .FALSE. 
    12   REAL, SAVE,PUBLIC               :: dt_watch = 0. 
     13  REAL, SAVE,PUBLIC               :: dt_watch = zero 
    1314  INTEGER, SAVE,PUBLIC            :: last_action_watch = 0, & 
    1415       & last_check_watch = 0 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/AA_make

    r66 r257  
    11#- 
    2 #- $Id: AA_make,v 1.27 2010/04/06 14:34:32 ssipsl Exp $ 
     2#- $Id: AA_make 41 2011-01-01 19:56:53Z mmaipsl $ 
     3#- 
     4PARALLEL_LIB = $(LIBDIR)/libparallel.a 
     5SXPARALLEL_LIB = $(PARALLEL_LIB) 
     6#-Q- sxnec  SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     7#-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     8#-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     9#-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    310#- 
    411PARAM_LIB = $(LIBDIR)/libparameters.a 
    … …  
    916#-Q- sx8brodie SXPARAM_LIB = $(LIBDIR)/libsxparameters.a 
    1017#- 
    11 PARALLEL_LIB = $(LIBDIR)/libparallel.a 
    12 SXPARALLEL_LIB = $(PARALLEL_LIB) 
    13 #-Q- sxnec  SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    14 #-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    15 #-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
    16 #-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a 
     18ORGLOB_LIB = $(LIBDIR)/liborglob.a 
     19SXORGLOB_LIB = $(ORGLOB_LIB) 
     20#-Q- sxnec  SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a 
     21#-Q- sx6nec SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a 
     22#-Q- eshpux SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a 
     23#-Q- sx8brodie SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a 
    1724#- 
    1825MODS1 = stomate_data.f90      \ 
    … …  
    5259#- 
    5360all: 
     61        $(M_K) libparallel 
    5462        $(M_K) libparameters 
    55         $(M_K) libparallel 
     63        $(M_K) liborglob 
    5664        $(M_K) m_all 
    5765        @echo stomate is OK 
    … …  
    6775#-Q- sxnec      -limit vmemoryuse unlimited 
    6876 
     77libparallel: 
     78        (cd ../src_parallel; $(M_K) -f Makefile) 
     79 
    6980libparameters: 
    7081        (cd ../src_parameters; $(M_K) -f Makefile) 
    7182 
    72 libparallel: 
    73         (cd ../src_parallel; $(M_K) -f Makefile) 
     83liborglob: 
     84        (cd ../src_global; $(M_K) -f Makefile) 
    7485 
    7586$(MODEL_LIB)(%.o): %.f90 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/AA_make.ldef

    r64 r257  
    11#- 
    2 #- $Id: AA_make.ldef,v 1.9 2008/01/08 11:49:08 ssipsl Exp $ 
     2#- $Id: AA_make.ldef 12 2010-11-05 15:42:13Z mmaipsl $ 
    33#- 
    44#--------------------------------------------------------------------- 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/lpj_constraints.f90

    r114 r257  
    129129 
    130130             WHERE ( t2m_min_daily(:) .LT. tmin_crit(j) ) 
    131                 adapted(:,j) = 0. 
     131                adapted(:,j) = zero 
    132132             ENDWHERE 
    133133 
    … …  
    135135             !  ( adapted will approach 1) 
    136136 
    137              adapted(:,j) = 1. - ( 1. - adapted(:,j) ) * (tau_adapt- dt)/tau_adapt 
     137             adapted(:,j) = un - ( un - adapted(:,j) ) * (tau_adapt- dt)/tau_adapt 
    138138 
    139139          ENDIF 
    … …  
    147147 
    148148             WHERE ( when_growthinit(:,j) .GT. too_long*one_year ) 
    149                 adapted(:,j) = 0. 
     149                adapted(:,j) = zero 
    150150             ENDWHERE 
    151151 
    … …  
    160160             ! 2.1.3.1 several PFTs (ex: evergreen) don't need vernalization 
    161161 
    162              regenerate(:,j) = 1. 
     162             regenerate(:,j) = un 
    163163 
    164164          ELSE 
    … …  
    167167 
    168168             WHERE ( t2m_month(:) .LE. tcm_crit(j) ) 
    169                 regenerate(:,j) = 1. 
     169                regenerate(:,j) = un 
    170170             ENDWHERE 
    171171 
    … …  
    181181 
    182182          WHERE ( regenerate(:,j) .LE. regenerate_min ) 
    183              adapted(:,j) = 0. 
     183             adapted(:,j) = zero 
    184184          ENDWHERE 
    185185 
    … …  
    190190          ! 
    191191 
    192           adapted(:,j) = 0. 
    193  
    194           regenerate(:,j) = 0. 
     192          adapted(:,j) = zero 
     193 
     194          regenerate(:,j) = zero 
    195195 
    196196       ENDIF 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/lpj_cover.f90

    r64 r257  
    2323 
    2424  SUBROUTINE cover (npts, cn_ind, ind, biomass, & 
    25        veget_max, veget_max_old, veget, lai, litter, carbon) 
     25       veget_max, veget_max_old, veget, lai, litter, carbon, turnover_daily, bm_to_litter) 
    2626 
    2727    ! 
    … …  
    3737    ! density of individuals (1/(m**2 of ground)) 
    3838    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)          :: ind 
     39    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground at beginning of time step 
    3940    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)          :: veget_max_old 
    4041 
    … …  
    4445    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground 
    4546    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)       :: veget_max 
     47    ! Turnover rates (gC/(m**2 of ground)/day) 
     48    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)          :: turnover_daily 
     49    ! conversion of biomass to litter (g/m**2 / day 
     50    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)          :: bm_to_litter 
    4651 
    4752    ! 0.3 output 
    … …  
    5055    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)       :: veget 
    5156    ! leaf area index OF AN INDIVIDUAL PLANT 
    52     REAL(r_std), DIMENSION(npts,nvm), INTENT(in)         :: lai 
     57    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)         :: lai 
    5358 
    5459    ! metabolic and structural litter, above and below ground (gC/(m**2 of ground)) 
    … …  
    6065 
    6166    ! index 
    62     INTEGER(i_std)                                         :: i,j 
     67    INTEGER(i_std)                                         :: i,j,k,m 
    6368 
    6469    ! Litter dilution (gC/m²) 
    … …  
    6873 
    6974    ! conversion vectors 
    70     REAL(r_std),DIMENSION(nvm)                                         :: delta_veg 
     75    REAL(r_std),DIMENSION(nvm)                                         :: delta_veg,reduct 
    7176    ! vecteur de conversion 
    72     REAL(r_std)                                                        :: delta_veg_sum 
     77    REAL(r_std)                                                        :: delta_veg_sum,diff,sr 
     78    REAL(r_std), DIMENSION(npts)                                       :: frac_nat,sum_vegettree,sum_vegetgrass 
     79    REAL(r_std), DIMENSION(npts)                                       :: sum_veget_natveg 
    7380 
    7481    ! ========================================================================= 
    … …  
    8188    IF ( control%ok_dgvm ) THEN 
    8289 
    83        veget_max(:,ibare_sechiba) = 1. 
     90       ! some initialisations 
     91       frac_nat(:) = un 
     92       sum_veget_natveg(:) = zero 
     93       sum_vegettree(:) = zero 
     94       sum_vegetgrass(:) = zero 
     95 
     96       veget_max(:,ibare_sechiba) = un 
    8497 
    8598       DO j = 2,nvm 
    … …  
    88101 
    89102             veget_max(:,j) = ind(:,j) * cn_ind(:,j) 
    90  
    91           ENDIF 
    92  
     103             sum_veget_natveg(:) = sum_veget_natveg(:) + veget_max(:,j) 
     104 
     105          ELSE 
     106             !fraction occupied by agriculture needs to be substracted for the DGVM 
     107             !this is used below to constrain veget for natural vegetation, see below 
     108             frac_nat(:) = frac_nat(:) - veget_max(:,j) 
     109 
     110          ENDIF 
     111 
     112       ENDDO 
     113 
     114       DO i = 1, npts  
     115 
     116          IF (sum_veget_natveg(i) .GT. frac_nat(i) .AND. frac_nat(i) .GT. min_stomate) THEN 
     117 
     118             DO j = 2,nvm 
     119                IF( natural(j) ) THEN 
     120                   veget_max(i,j) =  veget_max(i,j) * frac_nat(i) / sum_veget_natveg(i) 
     121                ENDIF 
     122             ENDDO 
     123 
     124          ENDIF 
     125       ENDDO 
     126 
     127       DO j = 2,nvm 
    93128          veget_max(:,ibare_sechiba) = veget_max(:,ibare_sechiba) - veget_max(:,j) 
    94  
    95        ENDDO 
    96  
     129       ENDDO 
    97130       veget_max(:,ibare_sechiba) = MAX( veget_max(:,ibare_sechiba), zero ) 
    98131 
     132       ! 1.3 calculate carbon fluxes between PFTs to maintain mass balance 
     133       ! 
     134 
     135       DO i = 1, npts          
     136          ! Generation of the conversion vector 
     137 
     138          delta_veg(:) = veget_max(i,:)-veget_max_old(i,:) 
     139          delta_veg_sum = SUM(delta_veg,MASK=delta_veg.LT.zero) 
     140 
     141          dilu_lit(i,:,:) = zero 
     142          dilu_soil_carbon(i,:) = zero 
     143          DO j=1, nvm 
     144             IF ( delta_veg(j) < -min_stomate ) THEN  
     145                dilu_lit(i,:,:)=  dilu_lit(i,:,:) + delta_veg(j)*litter(i,:,j,:) / delta_veg_sum 
     146                dilu_soil_carbon(i,:)=  dilu_soil_carbon(i,:) + delta_veg(j) * carbon(i,:,j) / delta_veg_sum 
     147             ENDIF 
     148          ENDDO 
     149 
     150          DO j=1, nvm 
     151             IF ( delta_veg(j) > min_stomate) THEN 
     152 
     153                ! Dilution of reservoirs 
     154 
     155                ! Litter 
     156                litter(i,:,j,:)=(litter(i,:,j,:) * veget_max_old(i,j) + dilu_lit(i,:,:) * delta_veg(j)) / veget_max(i,j) 
     157 
     158                ! Soil carbon 
     159                carbon(i,:,j)=(carbon(i,:,j) * veget_max_old(i,j) + dilu_soil_carbon(i,:) * delta_veg(j)) / veget_max(i,j) 
     160 
     161             ENDIF 
     162 
     163             IF(j.GE.2.AND.veget_max_old(i,j).GT.min_stomate.AND.veget_max(i,j).GT.min_stomate) THEN 
     164 
     165                ! Correct biomass densities (i.e. also litter fall) to conserve mass  
     166                ! since it's defined on veget_max 
     167 
     168                biomass(i,j,:)=biomass(i,j,:)*veget_max_old(i,j)/veget_max(i,j) 
     169                turnover_daily(i,j,:)=turnover_daily(i,j,:)*veget_max_old(i,j)/veget_max(i,j) 
     170                bm_to_litter(i,j,:)=bm_to_litter(i,j,:)*veget_max_old(i,j)/veget_max(i,j) 
     171 
     172             ENDIF 
     173 
     174          ENDDO 
     175       ENDDO 
    99176    ENDIF 
    100  
    101     DO i = 1, npts          
    102        ! Generation of the conversion vector 
    103  
    104        delta_veg(:) = veget_max(i,:)-veget_max_old(i,:) 
    105        delta_veg_sum = SUM(delta_veg,MASK=delta_veg.LT.zero) 
    106  
    107        dilu_lit(i,:,:) = zero 
    108        dilu_soil_carbon(i,:) = zero 
    109        DO j=1, nvm 
    110           IF ( delta_veg(j) < -min_stomate ) THEN  
    111              dilu_lit(i,:,:)=  dilu_lit(i,:,:) - delta_veg(j)*litter(i,:,j,:) / delta_veg_sum 
    112              dilu_soil_carbon(i,:)=  dilu_soil_carbon(i,:) - delta_veg(j) * carbon(i,:,j) / delta_veg_sum 
    113           ENDIF 
    114        ENDDO 
    115  
    116        DO j=1, nvm 
    117           IF ( delta_veg(j) > min_stomate) THEN 
    118  
    119              ! Dilution of reservoirs 
    120  
    121              ! Litter 
    122              litter(i,:,j,:)=(litter(i,:,j,:) * veget_max_old(i,j) + dilu_lit(i,:,:) * delta_veg(j)) / veget_max(i,j) 
    123  
    124              ! Soil carbon 
    125              carbon(i,:,j)=(carbon(i,:,j) * veget_max_old(i,j) + dilu_soil_carbon(i,:) * delta_veg(j)) / veget_max(i,j) 
    126  
    127           ENDIF 
    128           !SZ correct biomass to conserve mass since it's defined on veget_max 
    129           IF(j.GE.2.AND.veget_max_old(i,j).GT.min_stomate.AND.veget_max(i,j).GT.min_stomate) THEN 
    130              biomass(i,j,:)=biomass(i,j,:)*veget_max_old(i,j)/veget_max(i,j) 
    131           ENDIF 
    132  
    133        ENDDO 
    134     ENDDO 
    135177 
    136178    ! 
    … …  
    140182    ! 
    141183    !MM in Soenke code but not in merge version ; must keep that ?? 
     184!NV, MM : we keep those comments for compatibility with CMIP5 computations. 
     185!! They have to be uncommented avec CMIP5 versions in the trunk ! 
    142186!!$    DO j = 2,nvm 
    143187!!$       lai(:,j) = biomass(:,j,ileaf,icarbon)*sla(j) 
    … …  
    153197             veget(i,j) = veget_max(i,j) 
    154198          ELSE 
    155              veget(i,j) = veget_max(i,j) * ( 1. - exp( - lai(i,j) * ext_coeff(j) ) ) 
     199             IF ( control%ok_dgvm ) THEN 
     200!!$SZneed to check this - this formulation will cause 100% veget, otherwise there will always  
     201!!$ be some percent bare ground 
     202                veget(i,j) = ind(i,j) * cn_ind(i,j)  * ( un - EXP( - lai(i,j) * ext_coeff(j) ) ) 
     203             ELSE 
     204                veget(i,j) = veget_max(i,j) * ( un - EXP( - lai(i,j) * ext_coeff(j) ) ) 
     205             ENDIF 
     206          ENDIF 
     207 
     208          ! check sums of fpc for natural vegetation (see correction below!) in dynamic mode 
     209          IF ( control%ok_dgvm ) THEN 
     210 
     211             IF(natural(j))THEN 
     212                IF(tree(j)) THEN 
     213                   sum_vegettree(i)=sum_vegettree(i)+veget(i,j) 
     214                ELSE  
     215                   sum_vegetgrass(i)=sum_vegetgrass(i)+veget(i,j) 
     216                ENDIF 
     217             ENDIF 
     218 
    156219          ENDIF 
    157220       ENDDO 
    158221    ENDDO 
    159     ! 
     222 
     223 
     224    ! 3.1 correct gridscale fpc for dynamic vegetation 
     225!!$SZ, this part should be obsolete now that veget_max is forced to 1.0 
     226!!$ nevertheless maintained just for savety. Whoever wants to test 
     227!!$ whether this works without is invited to do so. 
     228 
     229    ! in the DGVM mode, we can arrive at a sum of veget slighly exceeding 1.0, 
     230    ! because mainly of grass dynamics... 
     231    ! In this case, we devide the fpar over natural vegetation first such that  
     232    ! grasses are shadowed by trees, and in the theoretically impossible case that 
     233    ! this is not sufficient, reduce proportionally all veget's. 
     234    ! 
     235    IF ( control%ok_dgvm ) THEN 
     236 
     237       DO i = 1,npts 
     238 
     239          diff=sum_vegettree(i)+sum_vegetgrass(i)-frac_nat(i) 
     240          reduct(:) = 0. 
     241          ! ordinary case, the reason too much grasses  
     242          ! reduce grass veget to match the maximum 
     243          IF (diff .GT. 0. ) THEN 
     244 
     245             IF (sum_vegetgrass(i).GT.min_stomate) THEN 
     246                sr=0. 
     247                DO j=2,nvm 
     248                   IF(natural(j).AND..NOT.tree(j)) THEN 
     249                      reduct(j)=-MIN(diff,sum_vegetgrass(i))*veget(i,j)/sum_vegetgrass(i) 
     250                      sr=sr+reduct(j) 
     251                   ENDIF 
     252                ENDDO 
     253                diff=diff+sr 
     254             ENDIF 
     255 
     256          ENDIF 
     257 
     258          ! this is theoretically impossible, since trees can only occupy 95%, 
     259          ! but better be save than sorry 
     260          IF (diff .GT. min_stomate ) THEN 
     261 
     262             IF (sum_vegettree(i).GT.min_stomate) THEN 
     263                sr=0. 
     264                DO j=2,nvm 
     265                   IF(natural(j).AND.tree(j)) THEN 
     266                      reduct(j)=-MIN(diff,sum_vegettree(i))*veget(i,j)/sum_vegettree(i) 
     267                      sr=sr+reduct(j) 
     268                   ENDIF 
     269                ENDDO 
     270                diff=diff+sr  
     271             ENDIF 
     272 
     273          ENDIF 
     274 
     275!!$          ! tell user if the problem could not be resolved 
     276!!$          ! in theory the model should stop here! 
     277!!$          IF (diff .GT. min_stomate ) THEN 
     278!!$ 
     279!!$             write(numout,*) 'ATT, DGVM!: veget exceeds bareground without vegetation left' 
     280!!$             write(numout,*) 'ATT, DGVM!: is this a bug? cell: ',i 
     281!!$             write(numout,*) 'ATT, DGVM!: veget ',veget(i,:) 
     282!!$ 
     283!!$          ENDIF 
     284 
     285          ! finally, implement the reduction. (reduc is negative!) 
     286          veget(i,:)=veget(i,:)+reduct(:) 
     287 
     288       ENDDO 
     289 
     290    ENDIF 
     291 
    160292    veget(:,ibare_sechiba) = un 
    161293    DO j = 2,nvm 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/lpj_crown.f90

    r64 r257  
    66  !--------------------------------------------------------------------- 
    77  !- calculate individual crown area from stem mass. 
     8  !- SZ, I've put the woodmass calculation out of this routine 
     9  !      because after the very first establishment, woodmass 
     10  !      could not be calculated here as veget_max = zero and  
     11  !      d_ind not known... 
    812  !--------------------------------------------------------------------- 
    913  USE ioipsl 
    … …  
    2428  !- 
    2529  SUBROUTINE crown & 
    26        &  (npts, PFTpresent, ind, biomass, veget_max, cn_ind, height) 
     30       &  (npts, PFTpresent, ind, biomass, woodmass_ind, veget_max, cn_ind, height) 
    2731    !--------------------------------------------------------------------- 
    2832    ! 0 declarations 
    … …  
    3842    ! biomass (gC/(m**2 of ground)) 
    3943    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(in) :: biomass 
     44    ! woodmass of the individual, needed to calculate crownarea in lpj_crownarea 
     45    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: woodmass_ind 
    4046    !- 
    4147    ! 0.2 modified fields 
    … …  
    5965    ! wood mass of an individual 
    6066    !- 
    61     REAL(r_std),DIMENSION(npts) :: woodmass 
     67!!$    REAL(r_std),DIMENSION(npts) :: woodmass 
    6268    !- 
    6369    ! index 
    … …  
    7581    ! 1.1 check if DGVM activated 
    7682    !- 
    77     IF (.NOT.control%ok_dgvm) THEN 
     83    IF (.NOT.control%ok_dgvm .AND. lpj_gap_const_mort) THEN 
    7884       STOP 'crown: not to be called with static vegetation.' 
    7985    ENDIF 
    … …  
    8187    ! 1.2 initialize output to zero 
    8288    !- 
    83     cn_ind(:,:) = 0.0 
     89    cn_ind(:,:) = zero 
    8490    ! no convertion, just cop 
    8591    height_presc_12(1:nvm) = height_presc(1:nvm) 
    … …  
    94100          IF (natural(j)) THEN 
    95101             !------ 2.1.1 natural 
    96              WHERE (PFTpresent(:,j) .AND.ind(:,j).GT.min_stomate) 
    97                 !-------- 2.1.1.1 calculate individual wood mass 
    98                 woodmass(:) = & 
    99                      &         (biomass(:,j,isapabove)+biomass(:,j,isapbelow) & 
    100                      &         +biomass(:,j,iheartabove)+biomass(:,j,iheartbelow))/ind(:,j) 
     102             !WHERE (PFTpresent(:,j) .AND.ind(:,j).GT.min_stomate) 
     103             WHERE (PFTpresent(:,j) .AND.woodmass_ind(:,j).GT.min_stomate) 
     104!!$SZ note that woodmass_ind needs to be defined on the individual, hence 
     105!!$ biomass*veget_max/ind, not as stated here, correction MERGE 
     106!!$!-------- 2.1.1.1 calculate individual wood mass 
     107!!$          woodmass(:) = & 
     108!!$ &         (biomass(:,j,isapabove)+biomass(:,j,isapbelow) & 
     109!!$ &         +biomass(:,j,iheartabove)+biomass(:,j,iheartbelow))/ind(:,j) 
    101110                !-------- 2.1.1.2 stem diameter (pipe model) 
    102                 dia(:) = (woodmass(:)/(pipe_density*pi/4.*pipe_tune2)) & 
     111!!$          dia(:) = (woodmass(:)/(pipe_density*pi/4.*pipe_tune2)) & 
     112                dia(:) = (woodmass_ind(:,j)/(pipe_density*pi/4.*pipe_tune2)) & 
    103113                     &                **(1./(2.+pipe_tune3)) 
    104114                !-------- 2.1.1.3 height 
    105115                height(:,j) = pipe_tune2*(dia(:)**pipe_tune3) 
    106                 WHERE (height(:,j) > height_presc_12(j)) 
    107                    dia(:) = (height_presc_12(j)/pipe_tune2)**(1./pipe_tune3) 
    108                    height(:,j) = height_presc_12(j) 
    109                 ENDWHERE 
     116!!$SZ: The constraint on height has nothing to do with LPJ (for that purpose there's dia_max 
     117!!$ cannot see why this is necessary - it also blurrs the output, hence I leave it commented 
     118!!$                WHERE (height(:,j) > height_presc_12(j)) 
     119!!$                   dia(:) = (height_presc_12(j)/pipe_tune2)**(1./pipe_tune3) 
     120!!$                   height(:,j) = height_presc_12(j) 
     121!!$                ENDWHERE 
    110122                !-------- 2.1.1.4 crown area: for large truncs, crown area cannot 
    111123                !--------         exceed a certain value, prescribed through maxdia. 
    … …  
    122134          WHERE (PFTpresent(:,j)) 
    123135             !------ 2.2.1 an "individual" is 1 m**2 of grass 
    124              cn_ind(:,j) = 1. 
     136             cn_ind(:,j) = un 
    125137          ENDWHERE 
    126138       ENDIF 
    … …  
    129141       !       ind and cn_ind are 0 if not present 
    130142       !--- 
    131        !SZ isn't this physically inconsistent with the assumptions of sechiba?? 
    132        ! the actual LPJ formulation calculates fpc from maximum LAI, and fpar from actual LAI=veget 
    133        IF (natural(j).AND.control%ok_dgvm) THEN 
    134           veget_max(:,j) = ind(:,j) * cn_ind(:,j) 
    135        ENDIF 
     143!!$SZ: since now all state variables are defined on veget_max it is very 
     144!!$ dangerous to change this several times in stomate_lpj, as then GPP, turnover and allocated  
     145!!$ biomass are not defined on the same space! Hence, veget_max is now kept constant 
     146!!$ and updated at the end of stomate_lpj in lpj_cover.f90 
     147!!$ Eventually, this routine should only be called once at the beginning and the end of stomate_lpj 
     148!!$ or prefereably cn_ind made a saved state variable! 
     149!!$    IF (natural(j).AND.control%ok_dgvm) THEN 
     150!!$      veget_max(:,j) = ind(:,j) * cn_ind(:,j) 
     151!!$    ENDIF 
    136152    ENDDO 
    137153    !------------------- 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/lpj_establish.f90

    r64 r257  
    3333       neighbours, resolution, need_adjacent, herbivores, & 
    3434       precip_annual, gdd0, lm_lastyearmax, & 
    35        cn_ind, lai, avail_tree, avail_grass, & 
     35       cn_ind, lai, avail_tree, avail_grass,  npp_longterm, & 
    3636       leaf_age, leaf_frac, & 
    37        ind, biomass, age, everywhere, co2_to_bm,veget_max) 
    38  
     37       ind, biomass, age, everywhere, co2_to_bm,veget_max, woodmass_ind) 
    3938    ! 
    4039    ! 0 declarations 
    … …  
    7473    ! space availability for grasses 
    7574    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: avail_grass 
     75    ! longterm NPP, for each PFT (gC/(m**2 of ground)) 
     76    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                :: npp_longterm 
    7677    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground  
    7778    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: veget_max 
    … …  
    9495    !NV passage 2D 
    9596    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: co2_to_bm 
     97    ! woodmass of the individual, needed to calculate crownarea in lpj_crownarea 
     98    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: woodmass_ind 
    9699 
    97100    ! 0.3 local 
    … …  
    111114    ! total natural fpc 
    112115    REAL(r_std), DIMENSION(npts)                                :: sumfpc 
     116    ! total fraction occupied by natural vegetation 
     117    REAL(r_std), DIMENSION(npts)                                :: fracnat 
    113118    ! total woody fpc 
    114119    REAL(r_std), DIMENSION(npts)                                :: sumfpc_wood 
    … …  
    129134    ! woodmass of an individual 
    130135    REAL(r_std), DIMENSION(npts)                                :: woodmass 
     136    ! carbon mass in youngest leaf age class (gC/m**2 PFT) 
     137    REAL(r_std), DIMENSION(npts)                                :: leaf_mass_young 
    131138    ! ratio of hw(above) to total hw, sm(above) to total sm 
    132139    REAL(r_std), DIMENSION(npts)                                :: sm_at 
    133140    ! reduction factor for establishment if many trees or grasses are present 
    134141    REAL(r_std), DIMENSION(npts)                                :: factor 
     142    ! Total carbon mass for all pools 
     143    REAL(r_std), DIMENSION(npts)                                :: total_bm_c 
     144    ! Total sappling biomass for all pools 
     145    REAL(r_std), DIMENSION(npts)                                :: total_bm_sapl 
    135146    ! from how many sides is the grid box invaded 
    136147    INTEGER(i_std)                                              :: nfrontx 
    137148    INTEGER(i_std)                                              :: nfronty 
    138149    ! daily establishment rate is large compared to present number of individuals 
    139     LOGICAL, DIMENSION(npts)                                   :: many_new 
     150    !LOGICAL, DIMENSION(npts)                                   :: many_new 
     151    ! flow due to new individuals 
     152    !   veget_max after establishment, to get a proper estimate of carbon and nitrogen  
     153    REAL(r_std), DIMENSION(npts)                                 :: vn 
     154    !   lai on each PFT surface  
     155    REAL(r_std), DIMENSION(npts)                                 :: lai_ind 
     156 
    140157    ! indices 
    141158    INTEGER(i_std)                                              :: i,j,k,m 
    … …  
    161178    ENDIF 
    162179 
    163     ! 
    164     ! 2 recalculate fpc 
    165     ! 
    166  
    167     ! 
    168     ! 2.1 Only natural part of the grid cell 
    169     ! 
    170  
    171     DO j = 2,nvm 
    172  
    173        IF ( natural(j) ) THEN 
    174           DO i = 1, npts 
    175              IF (lai(i,j) == val_exp) THEN                
    176                 fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) 
    177              ELSE 
    178                 fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) * ( 1. - exp( -lai(i,j) * ext_coeff(j) ) ) 
    179              ENDIF 
    180           ENDDO 
    181        ELSE 
    182  
    183           fpc_nat(:,j) = 0.0 
    184  
    185        ENDIF 
    186  
    187     ENDDO 
    188  
    189     ! 
    190     ! 2.2 total natural fpc on grid 
    191     ! 
    192  
    193     sumfpc(:) = SUM( fpc_nat(:,:), DIM=2 ) 
    194  
    195     ! 
    196     ! 2.3 total woody fpc on grid and number of regenerative tree pfts 
    197     ! 
    198  
    199     sumfpc_wood(:) = 0.0 
    200     spacefight_tree(:) = 0.0 
    201  
    202     DO j = 2,nvm 
    203  
    204        IF ( tree(j) .AND. natural(j) ) THEN 
    205  
    206           ! total woody fpc 
    207  
    208           WHERE ( PFTpresent(:,j) ) 
    209              sumfpc_wood(:) = sumfpc_wood(:) + fpc_nat(:,j) 
    210           ENDWHERE 
    211  
    212           ! how many trees are competing? Count a PFT fully only if it is present 
    213           !   on the whole grid box. 
    214  
    215           WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) ) 
    216              spacefight_tree(:) = spacefight_tree(:) + everywhere(:,j) 
    217           ENDWHERE 
    218  
    219        ENDIF 
    220  
    221     ENDDO 
    222  
    223     ! 
    224     ! 2.4 number of natural grasses 
    225     ! 
    226  
    227     spacefight_grass(:) = 0.0 
    228  
    229     DO j = 2,nvm 
    230  
    231        IF ( .NOT. tree(j) .AND. natural(j) ) THEN 
    232  
    233           ! how many grasses are competing? Count a PFT fully only if it is present 
    234           !   on the whole grid box. 
    235  
    236           WHERE ( PFTpresent(:,j) ) 
    237              spacefight_grass(:) = spacefight_grass(:) + everywhere(:,j) 
    238           ENDWHERE 
    239  
    240        ENDIF 
    241  
    242     ENDDO 
    243  
    244     ! 
    245     ! 3 establishment rate 
    246     ! 
    247  
    248     ! 
    249     ! 3.1 maximum establishment rate, based on climate only 
    250     ! 
    251  
    252     WHERE ( ( precip_annual(:) .GE. precip_crit ) .AND. ( gdd0(:) .GE. gdd_crit_estab ) ) 
    253  
    254        estab_rate_max_climate_tree(:) = estab_max_tree 
    255        estab_rate_max_climate_grass(:) = estab_max_grass 
    256  
    257     ELSEWHERE 
    258  
    259        estab_rate_max_climate_tree(:) = 0.0 
    260        estab_rate_max_climate_grass(:) = 0.0 
    261  
    262     ENDWHERE 
    263  
    264     ! 
    265     ! 3.2 reduce maximum tree establishment rate if many trees present. 
    266     !     In the original DGVM, this is done using a step function which yields a 
    267     !     reduction by factor 4 if sumfpc_wood(i) .GT.  fpc_crit - 0.05. 
    268     !     This can lead to small oscillations (without consequences however). 
    269     !     Here, a steady linear transition is used between fpc_crit-0.075 and 
    270     !     fpc_crit-0.025. 
    271     ! 
    272  
    273     factor(:) = 1. - establish_scal_fact * ( sumfpc_wood(:) - (fpc_crit - fpc_crit_max) ) 
    274     factor(:) = MAX( 0.25_r_std, MIN( un, factor(:) ) ) 
    275  
    276     estab_rate_max_tree(:) = estab_rate_max_climate_tree(:) * factor(:) 
    277  
    278     ! 
    279     ! 3.3 Modulate grass establishment rate. 
    280     !     If canopy is not closed (fpc < fpc_crit-0.05), normal establishment. 
    281     !     If canopy is closed, establishment is reduced by a factor 4. 
    282     !     Factor is linear between these two bounds. 
    283     !     This is different from the original DGVM where a step function is 
    284     !     used at fpc_crit-0.05 (This can lead to small oscillations, 
    285     !     without consequences however). 
    286     ! 
    287  
    288     factor(:) = 1. - establish_scal_fact * ( sumfpc(:) - (fpc_crit - fpc_crit_min) ) 
    289     factor(:) = MAX( 0.25_r_std, MIN( un, factor(:) ) ) 
    290  
    291     estab_rate_max_grass(:) = estab_rate_max_climate_grass(:) * factor(:) 
    292  
    293     ! 
    294     ! 4 do establishment for natural PFTs 
    295     ! 
    296  
    297     d_ind(:,:) = 0.0 
    298  
    299     DO j = 2,nvm 
    300  
    301        ! only for natural PFTs 
    302  
    303        IF ( natural(j) ) THEN 
    304  
    305           ! 
    306           ! 4.1 PFT expansion across the grid box. Not to be confused with areal 
    307           !     coverage. 
    308           ! 
    309  
    310           IF ( treat_expansion ) THEN 
    311  
    312              ! only treat plants that are regenerative and present and still can expand 
    313  
    314              DO i = 1, npts 
    315  
    316                 IF ( PFTpresent(i,j) .AND. & 
    317                      ( everywhere(i,j) .LT. 1. ) .AND. & 
    318                      ( regenerate(i,j) .GT. regenerate_crit ) ) THEN 
    319  
    320                    ! from how many sides is the grid box invaded (separate x and y directions 
    321                    ! because resolution may be strongly anisotropic) 
    322                    ! 
    323                    ! For the moment we only look into 4 direction but that can be extanded (JP)  
    324                    ! 
    325                    nfrontx = 0 
    326                    IF ( neighbours(i,3) .GT. 0 ) THEN 
    327                       IF ( everywhere(neighbours(i,3),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1 
    328                    ENDIF 
    329                    IF ( neighbours(i,7) .GT. 0 ) THEN 
    330                       IF ( everywhere(neighbours(i,7),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1 
    331                    ENDIF 
    332  
    333                    nfronty = 0 
    334                    IF ( neighbours(i,1) .GT. 0 ) THEN 
    335                       IF ( everywhere(neighbours(i,1),j) .GT. 1.-min_stomate ) nfronty = nfronty+1 
    336                    ENDIF 
    337                    IF ( neighbours(i,5) .GT. 0 ) THEN 
    338                       IF ( everywhere(neighbours(i,5),j) .GT. 1.-min_stomate ) nfronty = nfronty+1 
    339                    ENDIF 
    340  
    341                    everywhere(i,j) = & 
    342                         everywhere(i,j) + migrate(j) * dt/one_year * & 
    343                         ( nfrontx / resolution(i,1) + nfronty / resolution(i,2) ) 
    344  
    345                    IF ( .NOT. need_adjacent(i,j) ) THEN 
    346  
    347                       ! in that case, we also assume that the PFT expands from places within 
    348                       ! the grid box (e.g., oasis). 
    349  
     180 
     181    IF (control%ok_dgvm) THEN 
     182       ! 
     183       ! 2 recalculate fpc 
     184       ! 
     185 
     186       ! 
     187       ! 2.1 Only natural part of the grid cell 
     188       ! 
     189 
     190       fracnat(:) = un 
     191       do j = 2,nvm 
     192          IF ( .NOT. natural(j) ) THEN 
     193             fracnat(:) = fracnat(:) - veget_max(:,j) 
     194          ENDIF 
     195       ENDDO 
     196 
     197       ! 
     198       ! 2.2 total natural fpc on grid 
     199       ! 
     200       sumfpc(:) = zero 
     201       DO j = 2,nvm 
     202 
     203          IF ( natural(j) ) THEN 
     204             WHERE(fracnat(:).GT.min_stomate) 
     205                WHERE (lai(:,j) == val_exp)  
     206                   fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) 
     207                ELSEWHERE 
     208                   fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) &  
     209                        * ( 1. - exp( - lm_lastyearmax(:,j) * sla(j) * ext_coeff(j) ) ) 
     210                ENDWHERE 
     211             ENDWHERE 
     212 
     213             WHERE ( PFTpresent(:,j) ) 
     214                sumfpc(:) = sumfpc(:) + fpc_nat(:,j) 
     215             ENDWHERE 
     216          ELSE 
     217 
     218             fpc_nat(:,j) = zero 
     219 
     220          ENDIF 
     221 
     222       ENDDO 
     223 
     224       ! 
     225       ! 2.3 total woody fpc on grid and number of regenerative tree pfts 
     226       ! 
     227        
     228       sumfpc_wood(:) = zero 
     229       spacefight_tree(:) = zero 
     230 
     231       DO j = 2,nvm 
     232           
     233          IF ( tree(j) .AND. natural(j) ) THEN 
     234              
     235             ! total woody fpc 
     236              
     237             WHERE ( PFTpresent(:,j) ) 
     238                sumfpc_wood(:) = sumfpc_wood(:) + fpc_nat(:,j) 
     239             ENDWHERE 
     240              
     241             ! how many trees are competing? Count a PFT fully only if it is present 
     242             !   on the whole grid box. 
     243              
     244             WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) ) 
     245                spacefight_tree(:) = spacefight_tree(:) + everywhere(:,j) 
     246             ENDWHERE 
     247              
     248          ENDIF 
     249           
     250       ENDDO 
     251        
     252       ! 
     253       ! 2.4 number of natural grasses 
     254       ! 
     255        
     256       spacefight_grass(:) = zero 
     257        
     258       DO j = 2,nvm 
     259           
     260          IF ( .NOT. tree(j) .AND. natural(j) ) THEN 
     261              
     262             ! how many grasses are competing? Count a PFT fully only if it is present 
     263             !   on the whole grid box. 
     264              
     265             WHERE ( PFTpresent(:,j) ) 
     266                spacefight_grass(:) = spacefight_grass(:) + everywhere(:,j) 
     267             ENDWHERE 
     268              
     269          ENDIF 
     270           
     271       ENDDO 
     272        
     273       ! 
     274       ! 3 establishment rate 
     275       ! 
     276        
     277       ! 
     278       ! 3.1 maximum establishment rate, based on climate only 
     279       ! 
     280        
     281       WHERE ( ( precip_annual(:) .GE. precip_crit ) .AND. ( gdd0(:) .GE. gdd_crit_estab ) ) 
     282           
     283          estab_rate_max_climate_tree(:) = estab_max_tree 
     284          estab_rate_max_climate_grass(:) = estab_max_grass 
     285           
     286       ELSEWHERE 
     287           
     288          estab_rate_max_climate_tree(:) = zero 
     289          estab_rate_max_climate_grass(:) = zero 
     290           
     291       ENDWHERE 
     292     
     293       ! 
     294       ! 3.2 reduce maximum tree establishment rate if many trees present. 
     295       !     In the original DGVM, this is done using a step function which yields a 
     296       !     reduction by factor 4 if sumfpc_wood(i) .GT.  fpc_crit - 0.05. 
     297       !     This can lead to small oscillations (without consequences however). 
     298       !     Here, a steady linear transition is used between fpc_crit-0.075 and 
     299       !     fpc_crit-0.025. 
     300       ! 
     301        
     302       !factor(:) = 1. - establish_scal_fact * ( sumfpc_wood(:) - (fpc_crit - fpc_crit_max) ) 
     303       !factor(:) = MAX( 0.25_r_std, MIN( un, factor(:) ) ) 
     304        
     305       !SZ modified according to Smith et al. 2001, 080806 
     306       factor(:)=(1.0-exp(-5.0*(1.0-sumfpc_wood(:))))*(1.0-sumfpc_wood(:)) 
     307 
     308       estab_rate_max_tree(:) = estab_rate_max_climate_tree(:) * factor(:) 
     309        
     310       ! 
     311       ! 3.3 Modulate grass establishment rate. 
     312       !     If canopy is not closed (fpc < fpc_crit-0.05), normal establishment. 
     313       !     If canopy is closed, establishment is reduced by a factor 4. 
     314       !     Factor is linear between these two bounds. 
     315       !     This is different from the original DGVM where a step function is 
     316       !     used at fpc_crit-0.05 (This can lead to small oscillations, 
     317       !     without consequences however). 
     318       ! 
     319        
     320       !factor(:) = 1. - establish_scal_fact * ( sumfpc(:) - (fpc_crit - fpc_crit_min) ) 
     321       !factor(:) = MAX( 0.25_r_std, MIN( un, factor(:) ) ) 
     322       !estab_rate_max_grass(:) = estab_rate_max_climate_grass(:) * factor(:) 
     323  
     324       !SZ modified to true LPJ formulation, grasses are only allowed in the 
     325       !fpc fraction not occupied by trees..., 080806 
     326!NVmodif       estab_rate_max_grass(:)=MAX(0.98-sumfpc(:),zero) 
     327       estab_rate_max_grass(:)=MAX(MIN(estab_rate_max_climate_grass(:),0.98-sumfpc(:)),zero) 
     328 
     329       ! SZ: longterm grass NPP for competition between C4 and C3 grasses 
     330       !     to avoid equal veget_max, the idea is that more reestablishment 
     331       !     is possible for the more productive PFT 
     332       factor(:)=min_stomate 
     333       DO j = 2,nvm 
     334          IF ( natural(j) .AND. .NOT.tree(j)) &  
     335               factor(:)=factor(:)+npp_longterm(:,j) * & 
     336               lm_lastyearmax(:,j) * sla(j) 
     337       ENDDO  
     338       ! 
     339       ! 
     340       ! 
     341       ! 4 do establishment for natural PFTs 
     342       ! 
     343        
     344       d_ind(:,:) = zero 
     345        
     346       DO j = 2,nvm 
     347           
     348          ! only for natural PFTs 
     349           
     350          IF ( natural(j) ) THEN 
     351              
     352             ! 
     353             ! 4.1 PFT expansion across the grid box. Not to be confused with areal 
     354             !     coverage. 
     355             ! 
     356              
     357             IF ( treat_expansion ) THEN 
     358                 
     359                ! only treat plants that are regenerative and present and still can expand 
     360                 
     361                DO i = 1, npts 
     362                    
     363                   IF ( PFTpresent(i,j) .AND. & 
     364                        ( everywhere(i,j) .LT. un ) .AND. & 
     365                        ( regenerate(i,j) .GT. regenerate_crit ) ) THEN 
     366                       
     367                      ! from how many sides is the grid box invaded (separate x and y directions 
     368                      ! because resolution may be strongly anisotropic) 
     369                      ! 
     370                      ! For the moment we only look into 4 direction but that can be extanded (JP)  
     371                      ! 
     372                      nfrontx = 0 
     373                      IF ( neighbours(i,3) .GT. 0 ) THEN 
     374                         IF ( everywhere(neighbours(i,3),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1 
     375                      ENDIF 
     376                      IF ( neighbours(i,7) .GT. 0 ) THEN 
     377                         IF ( everywhere(neighbours(i,7),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1 
     378                      ENDIF 
     379                       
     380                      nfronty = 0 
     381                      IF ( neighbours(i,1) .GT. 0 ) THEN 
     382                         IF ( everywhere(neighbours(i,1),j) .GT. 1.-min_stomate ) nfronty = nfronty+1 
     383                      ENDIF 
     384                      IF ( neighbours(i,5) .GT. 0 ) THEN 
     385                         IF ( everywhere(neighbours(i,5),j) .GT. 1.-min_stomate ) nfronty = nfronty+1 
     386                      ENDIF 
     387                       
    350388                      everywhere(i,j) = & 
    351389                           everywhere(i,j) + migrate(j) * dt/one_year * & 
    352                            2. * SQRT( pi*everywhere(i,j)/(resolution(i,1)*resolution(i,2)) ) 
    353  
     390                           ( nfrontx / resolution(i,1) + nfronty / resolution(i,2) ) 
     391                       
     392                      IF ( .NOT. need_adjacent(i,j) ) THEN 
     393                          
     394                         ! in that case, we also assume that the PFT expands from places within 
     395                         ! the grid box (e.g., oasis). 
     396                          
     397                         everywhere(i,j) = & 
     398                              everywhere(i,j) + migrate(j) * dt/one_year * & 
     399                              2. * SQRT( pi*everywhere(i,j)/(resolution(i,1)*resolution(i,2)) ) 
     400                          
     401                      ENDIF 
     402                       
     403                      everywhere(i,j) = MIN( everywhere(i,j), un ) 
     404                       
    354405                   ENDIF 
    355  
    356                    everywhere(i,j) = MIN( everywhere(i,j), un ) 
    357  
    358                 ENDIF 
    359  
    360              ENDDO 
    361  
    362           ENDIF  ! treat expansion? 
    363  
    364           ! 
    365           ! 4.2 establishment rate 
    366           !     - Is lower if the PFT is only present in a small part of the grid box 
    367           !       (after its introduction), therefore multiplied by "everywhere". 
    368           !     - Is divided by the number of PFTs that compete ("spacefight"). 
    369           !     - Is modulated by space availability (avail_tree, avail_grass). 
    370           ! 
    371  
    372           IF ( tree(j) ) THEN 
    373  
    374              ! 4.2.1 present and regenerative trees 
    375  
    376              WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) ) 
    377  
    378  
    379                 d_ind(:,j) = estab_rate_max_tree(:)*everywhere(:,j)/spacefight_tree(:) * & 
    380                      avail_tree(:) * dt/one_year 
    381  
    382              ENDWHERE 
    383  
    384           ELSE 
    385  
    386              ! 4.2.2 present and regenerative grasses 
    387  
    388              WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) ) 
    389  
    390                 d_ind(:,j) = estab_rate_max_grass(:)*everywhere(:,j)/spacefight_grass(:) * & 
    391                      avail_grass(:) * dt/one_year 
    392  
    393              ENDWHERE 
    394  
    395           ENDIF  ! tree/grass 
     406                    
     407                ENDDO 
     408                 
     409             ENDIF  ! treat expansion? 
     410              
     411             ! 
     412             ! 4.2 establishment rate 
     413             !     - Is lower if the PFT is only present in a small part of the grid box 
     414             !       (after its introduction), therefore multiplied by "everywhere". 
     415             !     - Is divided by the number of PFTs that compete ("spacefight"). 
     416             !     - Is modulated by space availability (avail_tree, avail_grass). 
     417             ! 
     418              
     419             IF ( tree(j) ) THEN 
     420                 
     421                ! 4.2.1 present and regenerative trees 
     422                 
     423                WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) ) 
     424                    
     425                    
     426                   d_ind(:,j) = estab_rate_max_tree(:)*everywhere(:,j)/spacefight_tree(:) * & 
     427                        avail_tree(:) * dt/one_year 
     428                    
     429                ENDWHERE 
     430                 
     431             ELSE 
     432                 
     433                ! 4.2.2 present and regenerative grasses 
     434                 
     435                WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit )  &  
     436                     .AND.factor(:).GT.min_stomate .AND. spacefight_grass(:).GT. min_stomate)  
     437                    
     438                   d_ind(:,j) = estab_rate_max_grass(:)*everywhere(:,j)/spacefight_grass(:) * & 
     439                        MAX(min_stomate,npp_longterm(:,j)*lm_lastyearmax(:,j)*sla(j)/factor(:)) * fracnat(:) * dt/one_year 
     440                    
     441                ENDWHERE 
     442 
     443             ENDIF  ! tree/grass 
     444 
     445          ENDIF ! if natural 
     446       ENDDO ! PFTs 
     447 
     448    ELSE ! lpj establishment in static case, SZ 080806, account for real LPJ dynamics in  
     449       ! prescribed vegetation, i.e. population dynamics within a given area of the  
     450       ! grid cell 
     451 
     452       d_ind(:,:) = zero 
     453 
     454       DO j = 2,nvm 
     455 
     456          ! only for natural PFTs 
     457 
     458          WHERE(ind(:,j)*cn_ind(:,j).GT.min_stomate) 
     459             lai_ind(:)=sla(j) * lm_lastyearmax(:,j)/(ind(:,j)*cn_ind(:,j)) 
     460          ELSEWHERE 
     461             lai_ind(:)= zero 
     462          ENDWHERE 
     463 
     464          IF ( natural(j) .AND. tree(j)) THEN  
     465 
     466             fpc_nat(:,j) =  MIN(1.0,cn_ind(:,j) * ind(:,j) * &  
     467                  MAX( ( 1._r_std - exp( - ext_coeff(j) * lai_ind(:) ) ), min_cover ) ) 
     468             !fpc_nat(:,j) = max(fpc_nat(:,j),1.-exp(-0.5*sla(j) * lm_lastyearmax(:,j))) 
     469 
     470 
     471             WHERE (veget_max(:,j).GT.min_stomate.AND.ind(:,j).LE.2.) 
     472 
     473                ! only establish into growing stands, ind can become very 
     474                ! large in the static mode because LAI is very low in poor  
     475                ! growing conditions, favouring continuous establishment. To avoid this 
     476                ! a maximum IND is set. BLARPP: This should be replaced by a  
     477                ! better stand density criteria 
     478                ! 
     479                factor(:)=(1.0-exp(-5.0*(1.0-fpc_nat(:,j))))*(1.0-fpc_nat(:,j)) 
     480 
     481                estab_rate_max_tree(:) = estab_max_tree * factor(:)  
     482                ! 
     483                ! 4 do establishment for natural PFTs 
     484                ! 
     485                d_ind(:,j) = MAX( zero, estab_rate_max_tree(:) * dt/one_year) 
     486 
     487             ENDWHERE 
     488 
     489             !SZ: quickfix: to simulate even aged stand, uncomment the following lines... 
     490             !where (ind(:,j) .LE. min_stomate) 
     491             !d_ind(:,j) = 0.1 !MAX( 0.0, estab_rate_max_tree(:) * dt/one_year) 
     492 
     493             WHERE (veget_max(:,j).GT.min_stomate.AND.ind(:,j).EQ.zero) 
     494                d_ind(:,j) = ind_0*10. 
     495                !          elsewhere 
     496                !d_ind(:,j) =0.0 
     497             endwhere 
     498 
     499          ELSEIF ( natural(j) .AND. .NOT.tree(j)) THEN  
     500 
     501             WHERE (veget_max(:,j).GT.min_stomate) 
     502 
     503                fpc_nat(:,j) =  cn_ind(:,j) * ind(:,j) * &  
     504                     MAX( ( 1._r_std - exp( - ext_coeff(j) * lai_ind(:) ) ), min_cover ) 
     505 
     506                d_ind(:,j) = MAX(zero , (1.0-fpc_nat(:,j)) * dt/one_year ) 
     507 
     508             ENDWHERE 
     509 
     510             WHERE (veget_max(:,j).GT.min_stomate.AND.ind(:,j).EQ.zero) 
     511                d_ind(:,j) = ind_0*10. 
     512             ENDWHERE 
     513 
     514          ENDIF 
     515 
     516       ENDDO 
     517 
     518    ENDIF ! DGVM OR NOT 
     519 
     520    DO j = 2,nvm 
     521 
     522       ! only for natural PFTs 
     523 
     524       IF ( natural(j) ) THEN 
    396525 
    397526          ! 
    … …  
    409538          ! 
    410539          ! 4.4 be sure that ind*cn_ind does not exceed 1 
    411           ! 
    412  
    413           WHERE ( ( d_ind(:,j) .GT. 0.0 ) .AND. & 
    414                ( (ind(:,j)+d_ind(:,j))*cn_ind(:,j) .GT. 1. ) ) 
    415  
    416              d_ind(:,j) = MAX( un / cn_ind(:,j) - ind(:,j), zero) 
    417  
    418           ENDWHERE 
     540          !SZ This control is now moved to lpj_cover.f90 
     541          !SZ 
     542 
     543          !The aim is to control for sum(veget)=1., irrespective of ind*cnd (crowns can overlap as long as 
     544          ! there is enough light 
     545          ! 
     546          !SZ: This could be part of the dynamic vegetation problem of Orchidee 
     547          !in conjunction with the wrong formulation of establishment response  
     548          !to tree fpc above... 
     549          !          WHERE ( ( d_ind(:,j) .GT. zero ) .AND. & 
     550          !                  ( (ind(:,j)+d_ind(:,j))*cn_ind(:,j) .GT. un ) ) 
     551          ! 
     552          !            d_ind(:,j) = MAX( 1._stnd / cn_ind(:,j) - ind(:,j), zero ) 
     553          ! 
     554          !          ENDWHERE 
    419555 
    420556          ! 
    … …  
    428564 
    429565          ! compare establishment rate and present number of inidivuals 
    430           many_new(:) = ( d_ind(:,j) .GT. 0.1 * ind(:,j) ) 
     566          !many_new(:) = ( d_ind(:,j) .GT. 0.1 * ind(:,j) ) 
    431567 
    432568          ! gives a better vectorization of the VPP 
    433569 
    434           IF ( ANY( many_new(:) ) ) THEN 
    435  
    436              DO k = 1, nparts 
    437  
    438                 WHERE ( many_new(:) ) 
    439  
    440                    bm_new(:) = d_ind(:,j) * bm_sapl(j,k) / veget_max (:,j) 
    441  
    442                    biomass(:,j,k) = biomass(:,j,k) + bm_new(:) 
    443  
    444                    !NV passage 2D 
    445                    co2_to_bm(:,j) = co2_to_bm(:,j) + bm_new(:) / dt 
    446  
    447                 ENDWHERE 
    448  
     570          !IF ( ANY( many_new(:) ) ) THEN 
     571 
     572          ! save old leaf mass to calculate leaf age 
     573          leaf_mass_young(:) = leaf_frac(:,j,1) * biomass(:,j,ileaf) 
     574          ! total biomass of existing PFT to limit biomass added from establishment 
     575          total_bm_c(:) = zero 
     576 
     577          DO k = 1, nparts 
     578             total_bm_c(:)=total_bm_c(:)+biomass(:,j,k) 
     579          ENDDO 
     580          IF(control%ok_dgvm) THEN 
     581             vn(:)=veget_max(:,j) 
     582          ELSE 
     583             vn(:)=1.0 
     584          ENDIF 
     585          total_bm_sapl(:)=zero 
     586          DO k = 1, nparts 
     587             WHERE(d_ind(:,j).GT.min_stomate.AND.vn(:).GT.min_stomate) 
     588 
     589                total_bm_sapl(:) = total_bm_sapl(:) + &  
     590                     bm_sapl(j,k) * d_ind(:,j) / vn(:) 
     591             ENDWHERE 
     592          ENDDO 
     593 
     594          IF(control%ok_dgvm) THEN 
     595             ! SZ calculate new woodmass_ind and veget_max after establishment (needed for correct scaling!) 
     596             ! essential correction for MERGE! 
     597             IF(tree(j))THEN 
     598                DO i=1,npts 
     599                   IF((d_ind(i,j)+ind(i,j)).GT.min_stomate) THEN 
     600 
     601                      IF((total_bm_c(i).LE.min_stomate) .OR. (veget_max(i,j) .LE. min_stomate)) THEN 
     602 
     603                         ! new wood mass of PFT 
     604                         woodmass_ind(i,j) = & 
     605                              & (((biomass(i,j,isapabove)+biomass(i,j,isapbelow) & 
     606                              & +biomass(i,j,iheartabove)+biomass(i,j,iheartbelow))*veget_max(i,j)) & 
     607                              & +(bm_sapl(j,isapabove)+bm_sapl(j,isapbelow) & 
     608                              & +bm_sapl(j,iheartabove)+bm_sapl(j,iheartbelow))*d_ind(i,j))/(ind(i,j)+d_ind(i,j)) 
     609 
     610                      ELSE  
     611                         ! new biomass is added to the labile pool, hence there is no change in CA associated with establishment 
     612                         woodmass_ind(i,j) = & 
     613                              & (biomass(i,j,isapabove)+biomass(i,j,isapbelow) & 
     614                              & +biomass(i,j,iheartabove)+biomass(i,j,iheartbelow))*veget_max(i,j) & 
     615                              & /(ind(i,j)+d_ind(i,j)) 
     616 
     617                      ENDIF 
     618 
     619                      ! new diameter of PFT 
     620                      dia(i) = (woodmass_ind(i,j)/(pipe_density*pi/4.*pipe_tune2)) & 
     621                           &                **(1./(2.+pipe_tune3)) 
     622 
     623                      vn(:)=(ind(i,j)+d_ind(i,j))*pipe_tune1*MIN(dia(i),maxdia(j))**pipe_tune_exp_coeff 
     624 
     625                   ENDIF 
     626                ENDDO 
     627             ELSE ! for grasses, cnd=1, so the above calculation cancels 
     628                vn(:)=ind(:,j)+d_ind(:,j) 
     629             ENDIF 
     630          ELSE ! static 
     631             DO i=1,npts 
     632                IF(tree(j).AND.(d_ind(i,j)+ind(i,j)).GT.min_stomate) THEN 
     633                   IF(total_bm_c(i).LE.min_stomate) THEN 
     634 
     635                      ! new wood mass of PFT 
     636                      woodmass_ind(i,j) = & 
     637                           & (((biomass(i,j,isapabove)+biomass(i,j,isapbelow) & 
     638                           & +biomass(i,j,iheartabove)+biomass(i,j,iheartbelow))) & 
     639                           & +(bm_sapl(j,isapabove)+bm_sapl(j,isapbelow) & 
     640                           & +bm_sapl(j,iheartabove)+bm_sapl(j,iheartbelow))*d_ind(i,j))/(ind(i,j)+d_ind(i,j)) 
     641 
     642                   ELSE ! new biomass is added to the labile pool, hence there is no change in CA associated with establishment 
     643 
     644                      woodmass_ind(i,j) = & 
     645                           & (biomass(i,j,isapabove)+biomass(i,j,isapbelow) & 
     646                           & +biomass(i,j,iheartabove)+biomass(i,j,iheartbelow)) & 
     647                           & /(ind(i,j)+d_ind(i,j)) 
     648 
     649                   ENDIF 
     650                ENDIF 
    449651             ENDDO 
    450652 
    451              ! reset leaf ages. Should do a real calculation like in the npp routine,  
    452              ! but this case is rare and not worth messing around. 
    453  
    454              WHERE ( many_new(:) ) 
    455                 leaf_age(:,j,1) = 0.0 
    456                 leaf_frac(:,j,1) = 1.0 
    457              ENDWHERE 
    458  
    459              DO m = 2, nleafages 
    460  
    461                 WHERE ( many_new(:) ) 
    462                    leaf_age(:,j,m) = 0.0 
    463                    leaf_frac(:,j,m) = 0.0 
    464                 ENDWHERE 
    465  
    466              ENDDO 
    467  
    468           ENDIF   ! establishment rate is large 
    469  
    470           WHERE ( d_ind(:,j) .GT. 0.0 ) 
    471  
    472              ! 4.5.2 age decreases 
     653             vn(:)=1.0 ! cannot change in static!, and veget_max implicit in d_ind 
     654 
     655          ENDIF 
     656          ! total biomass of PFT added by establishment defined over veget_max ... 
     657          total_bm_sapl(:)=zero 
     658          DO k = 1, nparts 
     659             WHERE(d_ind(:,j).GT.min_stomate.AND.total_bm_c(:).GT.min_stomate.AND.vn(:).GT.min_stomate) 
     660 
     661                total_bm_sapl(:) = total_bm_sapl(:) + &  
     662                     bm_sapl(j,k) * d_ind(:,j) / vn(:) 
     663             ENDWHERE 
     664 
     665          ENDDO 
     666 
     667          DO k = 1, nparts 
     668 
     669             bm_new(:)=zero 
     670 
     671             ! first ever establishment, C flows 
     672             WHERE( d_ind(:,j).GT.min_stomate .AND. & 
     673                  total_bm_c(:).LE.min_stomate .AND. & 
     674                  vn(:).GT.min_stomate) 
     675                ! WHERE ( many_new(:) ) 
     676 
     677                !bm_new(:) = d_ind(:,j) * bm_sapl(j,k) / veget_max (:,j) 
     678                bm_new(:) = d_ind(:,j) * bm_sapl(j,k) / vn(:) 
     679 
     680                biomass(:,j,k) = biomass(:,j,k) + bm_new(:) 
     681 
     682                co2_to_bm(:,j) = co2_to_bm(:,j) + bm_new(:) / dt 
     683 
     684             ENDWHERE 
     685 
     686             ! establishment into existing population, C flows 
     687             WHERE(d_ind(:,j).GT.min_stomate.AND.total_bm_c(:).GT.min_stomate) 
     688 
     689                bm_new(:) = total_bm_sapl(:) * biomass(:,j,k) / total_bm_c(:) 
     690 
     691                biomass(:,j,k) = biomass(:,j,k) + bm_new(:) 
     692                co2_to_bm(:,j) = co2_to_bm(:,j) + bm_new(:) / dt 
     693 
     694             ENDWHERE 
     695          ENDDO 
     696 
     697          ! reset leaf ages. Should do a real calculation like in the npp routine,  
     698          ! but this case is rare and not worth messing around. 
     699          ! SZ 080806, added real calculation now, because otherwise leaf_age/leaf_frac 
     700          ! are not initialised for the calculation of vmax, and hence no growth at all. 
     701          ! logic follows that of stomate_npp.f90, just that it's been adjusted for the code here 
     702          ! 
     703          ! 4.5.2 Decrease leaf age in youngest class if new leaf biomass is higher than old one. 
     704          ! 
     705 
     706!!$          WHERE ( many_new(:) ) 
     707!!$             leaf_age(:,j,1) = zero 
     708!!$             leaf_frac(:,j,1) = un 
     709!!$          ENDWHERE 
     710!!$ 
     711!!$          DO m = 2, nleafages 
     712!!$ 
     713!!$             WHERE ( many_new(:) ) 
     714!!$                leaf_age(:,j,m) = zero 
     715!!$                leaf_frac(:,j,m) = zero 
     716!!$             ENDWHERE 
     717!!$ 
     718!!$          ENDDO 
     719 
     720          WHERE ( d_ind(:,j) * bm_sapl(j,ileaf) .GT. min_stomate )  
     721 
     722             leaf_age(:,j,1) = leaf_age(:,j,1) * leaf_mass_young(:) / & 
     723                  ( leaf_mass_young(:) + d_ind(:,j) * bm_sapl(j,ileaf) ) 
     724 
     725          ENDWHERE 
     726 
     727          ! 
     728          leaf_mass_young(:) = leaf_mass_young(:) + d_ind(:,j) * bm_sapl(j,ileaf) 
     729 
     730          ! 
     731          ! new age class fractions (fraction in youngest class increases) 
     732          ! 
     733 
     734          ! youngest class: new mass in youngest class divided by total new mass 
     735 
     736          WHERE ( biomass(:,j,ileaf) .GT. min_stomate ) 
     737 
     738             leaf_frac(:,j,1) = leaf_mass_young(:) / biomass(:,j,ileaf) 
     739 
     740          ENDWHERE 
     741 
     742          ! other classes: old mass in leaf age class divided by new mass 
     743 
     744          DO m = 2, nleafages 
     745 
     746             WHERE ( biomass(:,j,ileaf) .GT. min_stomate ) 
     747 
     748                leaf_frac(:,j,m) = leaf_frac(:,j,m) * &  
     749                     ( biomass(:,j,ileaf) + d_ind(:,j) * bm_sapl(j,ileaf) ) /  biomass(:,j,ileaf) 
     750           
     751             ENDWHERE 
     752 
     753          ENDDO 
     754 
     755          !ENDIF   ! establishment rate is large 
     756 
     757          WHERE ( d_ind(:,j) .GT. min_stomate ) 
     758 
     759             ! 4.5.3 age decreases 
    473760 
    474761             age(:,j) = age(:,j) * ind(:,j) / ( ind(:,j) + d_ind(:,j) ) 
    475762 
    476              ! 4.5.3 new number of individuals 
     763             ! 4.5.4 new number of individuals 
    477764 
    478765             ind(:,j) = ind(:,j) + d_ind(:,j) 
    … …  
    484771          ! 
    485772 
     773          !SZ to clarify with Gerhard Krinner: This is theoretically inconsistent because  
     774          ! the allocation to sapwood and leaves do not follow the LPJ logic in stomate_alloc.f90 
     775          ! hence imposing this here not only solves for the uneveness of age (mixing new and average individual) 
     776          ! but also corrects for the discrepancy between SLAVE and LPJ logic of allocation, thus leads to excess heartwood 
     777          ! and thus carbon accumulation! 
     778          ! should be removed. 
     779 
    486780          IF ( tree(j) ) THEN 
    487781 
    488              sm2(:) = 0.0 
    489  
    490              WHERE ( d_ind(:,j) .GT. 0.0 )  
    491  
    492                 ! ratio of above / total sap parts 
    493                 sm_at(:) = biomass(:,j,isapabove) / & 
    494                      ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) ) 
    495  
    496                 ! woodmass of an individual 
    497  
    498                 woodmass(:) = & 
    499                      ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) + & 
    500                      biomass(:,j,iheartabove) + biomass(:,j,iheartbelow) ) / ind(:,j) 
    501  
    502                 ! crown area (m**2) depends on stem diameter (pipe model) 
    503                 dia(:) = ( woodmass(:) / ( pipe_density * pi/4. * pipe_tune2 ) ) & 
    504                      ** ( 1. / ( 2. + pipe_tune3 ) ) 
    505  
    506                 b1(:) = pipe_k1 / ( sla(j) * pipe_density*pipe_tune2 * dia(:)**pipe_tune3 ) * & 
    507                      ind(:,j) 
    508                 sm2(:) = lm_lastyearmax(:,j) / b1(:) 
    509  
    510              ENDWHERE 
    511  
    512              WHERE ( ( d_ind(:,j) .GT. 0.0 ) .AND. & 
     782!!$             sm2(:) = 0.0 
     783!!$             WHERE ( d_ind(:,j) .GT. 0.0 )  
     784!!$ 
     785!!$                ! ratio of above / total sap parts 
     786!!$                sm_at(:) = biomass(:,j,isapabove) / & 
     787!!$                     ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) ) 
     788!!$ 
     789!!$                ! woodmass of an individual 
     790!!$ 
     791!!$                woodmass(:) = & 
     792!!$                     ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) + & 
     793!!$                     biomass(:,j,iheartabove) + biomass(:,j,iheartbelow) ) / ind(:,j) 
     794!!$ 
     795!!$                ! crown area (m**2) depends on stem diameter (pipe model) 
     796!!$                dia(:) = ( woodmass(:) / ( pipe_density * pi/4. * pipe_tune2 ) ) & 
     797!!$                     ** ( 1. / ( 2. + pipe_tune3 ) ) 
     798!!$ 
     799!!$                b1(:) = pipe_k1 / ( sla(j) * pipe_density*pipe_tune2 * dia(:)**pipe_tune3 ) * & 
     800!!$                     ind(:,j) 
     801!!$                sm2(:) = lm_lastyearmax(:,j) / b1(:) 
     802!!$ 
     803!!$             ENDWHERE 
     804 
     805             sm2(:)=biomass(:,j,isapabove) + biomass(:,j,isapbelow) 
     806 
     807             WHERE ( ( d_ind(:,j) .GT. min_stomate ) .AND. & 
    513808                  ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) ) .GT. sm2(:) ) 
    514809 
    … …  
    518813 
    519814                biomass(:,j,iheartbelow) = biomass(:,j,iheartbelow) + & 
    520                      ( biomass(:,j,isapbelow) - sm2(:) * (1. - sm_at) ) 
    521                 biomass(:,j,isapbelow) = sm2(:) * (1. - sm_at(:)) 
     815                     ( biomass(:,j,isapbelow) - sm2(:) * (un - sm_at) ) 
     816                biomass(:,j,isapbelow) = sm2(:) * (un - sm_at(:)) 
    522817 
    523818             ENDWHERE 
    … …  
    536831 
    537832    CALL histwrite (hist_id_stomate, 'IND_ESTAB', itime, d_ind, npts*nvm, horipft_index) 
     833    CALL histwrite (hist_id_stomate, 'ESTABTREE', itime, estab_rate_max_tree, npts, hori_index) 
     834    CALL histwrite (hist_id_stomate, 'ESTABGRASS', itime, estab_rate_max_grass, npts, hori_index) 
    538835 
    539836    IF (bavard.GE.4) WRITE(numout,*) 'Leaving establish' 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/lpj_fire.f90

    r136 r257  
    9999    !MM Shilong ?? 
    100100!!$    REAL(r_std), PARAMETER                                           :: tau_fire = 365.  ! GKtest 
    101  
    102101    ! fire perturbation 
    103102    REAL(r_std), DIMENSION(npts)                                     :: fire_disturb 
    … …  
    273272       IF(.NOT.disable_fire.AND.natural(j))THEN 
    274273          WHERE ( aff(:) .GT. 0.1 ) 
    275              firefrac(:,j) = 1. - ( 1. - aff(:) ) ** (dt/one_year) 
     274             firefrac(:,j) = un - ( un - aff(:) ) ** (dt/one_year) 
    276275          ELSEWHERE 
    277276             firefrac(:,j) = aff(:) * dt/one_year 
    … …  
    315314          ! 4.2.1 Trees: always disturbed 
    316315 
    317           fire_disturb(:) = ( 1. - resist(j) ) * firefrac(:,j) 
     316          fire_disturb(:) = ( un - resist(j) ) * firefrac(:,j) 
    318317 
    319318       ELSE 
    … …  
    323322          WHERE ( biomass(:,j,ileaf) .GT. min_stomate ) 
    324323 
    325              fire_disturb(:) = ( 1. - resist(j) ) * firefrac(:,j) 
     324             fire_disturb(:) = ( un - resist(j) ) * firefrac(:,j) 
    326325 
    327326          ELSEWHERE 
    … …  
    353352             ! 4.3.2 Determine the residue, in gC/m**2 of ground. 
    354353 
    355              residue(:) = biomass(:,j,k) * fire_disturb(:) * ( 1. - co2frac(k) ) 
    356              !MM in SZ ???        residue(:) = fire_disturb(:) * ( 1. - co2frac(k) ) 
     354             residue(:) = biomass(:,j,k) * fire_disturb(:) * ( un - co2frac(k) ) 
     355             !MM in SZ ???        residue(:) = fire_disturb(:) * ( un - co2frac(k) ) 
    357356 
    358357             ! 4.3.2.1 determine fraction of black carbon. Only for plant parts above the 
    … …  
    400399          IF ( .NOT. ( ( .NOT. tree(j) ) .AND. ( ( k.EQ.iroot ) .OR. ( k.EQ.icarbres) ) ) ) THEN 
    401400 
    402              biomass(:,j,k) = ( 1. - fire_disturb(:) ) * biomass(:,j,k) 
     401             biomass(:,j,k) = ( un - fire_disturb(:) ) * biomass(:,j,k) 
    403402 
    404403          ENDIF 
    … …  
    409408       !       individuals. 
    410409 
    411        IF ( control%ok_dgvm .AND. tree(j) ) THEN 
     410       IF ( (control%ok_dgvm .OR. .NOT.lpj_gap_const_mort) .AND. tree(j) ) THEN 
    412411 
    413412          ! fraction of plants that dies each day. 
    … …  
    415414          firedeath(:,j) = fire_disturb(:) / dt 
    416415 
    417           ind(:,j) = ( 1. - fire_disturb(:) ) * ind(:,j) 
     416          ind(:,j) = ( un - fire_disturb(:) ) * ind(:,j) 
    418417 
    419418       ENDIF 
    … …  
    440439 
    441440       litter(:,imetabolic,j,iabove) = litter(:,imetabolic,j,iabove) * & 
    442             ( 1. - firefrac(:,j) ) 
     441            ( un - firefrac(:,j) ) 
    443442 
    444443       ! 
    … …  
    455454       co2_fire(:,j) = co2_fire(:,j) + & 
    456455            litter(:,istructural,j,iabove) * firefrac(:,j) * & 
    457             ( 1. - struc_residual(:) )/ dt 
     456            ( un - struc_residual(:) )/ dt 
    458457 
    459458       ! 5.2.3 determine residue (litter that undergoes fire, but is not transformed 
    460459       !       into CO2) 
    461460 
    462        residue(:) = litter(:,istructural,j,iabove) * firefrac(:,j) * & 
    463             struc_residual(:) 
     461!NV,MM : We add this test to keep coherence with CMIP5 computations without DGVM. 
     462!        It has to be removed in trunk version after CMIP5. 
     463       IF (control%ok_dgvm .OR. .NOT.lpj_gap_const_mort) THEN 
     464          residue(:) = firefrac(:,j) * struc_residual(:) 
     465       ELSE 
     466          residue(:) = litter(:,istructural,j,iabove) * firefrac(:,j) * & 
     467               struc_residual(:) 
     468       ENDIF 
     469 
     470!       residue(:) = litter(:,istructural,j,iabove) * firefrac(:,j) * & 
     471!            struc_residual(:) 
    464472       !MM in SZ        residue(:) = firefrac(:,j) * struc_residual(:) 
    465473 
    … …  
    482490 
    483491       litter(:,istructural,j,iabove) = & 
    484             litter(:,istructural,j,iabove) * ( 1. - firefrac(:,j) ) + & 
    485             residue(:) * ( 1. - bcfrac(:) ) 
    486        !MM in SZ            residue(:) * ( 1. - bcfrac(:) ) * litter(:,iwoody,j,iabove) 
     492            litter(:,istructural,j,iabove) * ( un - firefrac(:,j) ) + & 
     493            residue(:) * ( un - bcfrac(:) ) 
     494       !MM in SZ            residue(:) * ( un - bcfrac(:) ) * litter(:,iwoody,j,iabove) 
    487495 
    488496    ENDDO  !  ground 
    … …  
    496504 
    497505       DO k = 1, nlitt 
    498           dead_leaves(:,j,k) = dead_leaves(:,j,k) * ( 1. - firefrac(:,j) ) 
     506          dead_leaves(:,j,k) = dead_leaves(:,j,k) * ( un - firefrac(:,j) ) 
    499507       ENDDO 
    500508 
    … …  
    543551 
    544552    firefrac_result(:) = & 
    545 !         x(:) * EXP( xm1(:) / ( -.13*xm1(:)*xm1(:)*xm1(:) + .6*xm1(:)*xm1(:) + .8*xm1(:) + .45 ) ) 
    546553         x(:) * EXP( xm1(:) / ( -firefrac_coeff(4)*xm1(:)*xm1(:)*xm1(:) + firefrac_coeff(3)*xm1(:)*xm1(:) + firefrac_coeff(2)*xm1(:) + firefrac_coeff(1) ) ) 
    547554 
    548  
    549555  END FUNCTION firefrac_func 
    550556 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/lpj_gap.f90

    r64 r257  
    3939  SUBROUTINE gap (npts, dt, & 
    4040       npp_longterm, turnover_longterm, lm_lastyearmax, & 
    41        PFTpresent, biomass, ind, bm_to_litter) 
     41       PFTpresent, biomass, ind, bm_to_litter, mortality) 
    4242 
    4343    ! 
    … …  
    6868    ! biomass taken away (gC/(m**2 of ground)) 
    6969    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)  :: bm_to_litter 
     70    ! mortality (fraction of trees that is dying per time step), per day in history file 
     71    REAL(r_std), DIMENSION(npts,nvm),INTENT(out)             :: mortality 
    7072 
    7173    ! 0.3 local 
    7274 
    73     ! which kind of mortality 
    74     LOGICAL, SAVE                                           :: constant_mortality 
    7575    ! biomass increase 
    7676    REAL(r_std), DIMENSION(npts)                             :: delta_biomass 
     77    ! biomass increase 
     78    REAL(r_std), DIMENSION(npts)                             :: dmortality 
    7779    ! vigour 
    7880    REAL(r_std), DIMENSION(npts)                             :: vigour 
    7981    ! natural availability, based on vigour 
    8082    REAL(r_std), DIMENSION(npts)                             :: availability 
    81     ! mortality (fraction of trees that is dying per time step), per day in history file 
    82     REAL(r_std), DIMENSION(npts,nvm)                        :: mortality 
    8383    ! indices 
    84     INTEGER(i_std)                                           :: j,k 
     84    INTEGER(i_std)                                           :: j,k,m 
     85    REAL(r_std) :: ref_greff 
    8586 
    8687    ! ========================================================================= 
    … …  
    9091       firstcall = .FALSE. 
    9192 
    92        !Config  Key  = LPJ_GAP_CONST_MORT 
    93        !Config  Desc = constant tree mortality 
    94        !Config  Def  = y 
    95        !Config  Help = If yes, then a constant mortality is applied to trees.  
    96        !Config         Otherwise, mortality is a function of the trees'  
    97        !Config         vigour (as in LPJ). 
    98  
    99        constant_mortality = .TRUE. 
    100        CALL getin_p('LPJ_GAP_CONST_MORT', constant_mortality)      
    101        WRITE(numout,*) 'gap: constant mortality:', constant_mortality 
    102  
    10393    ENDIF 
    10494 
    105     IF (bavard.GE.3) WRITE(numout,*) 'Entering gap' 
     95    IF (bavard.GE.3) WRITE(numout,*) 'Entering gap',lpj_gap_const_mort 
    10696 
    10797    mortality(:,:) = zero 
    10898 
     99    ref_greff =  0.035 
     100 
    109101    DO j = 2,nvm 
    110102 
    … …  
    117109          ! 
    118110 
    119           IF ( .NOT. constant_mortality ) THEN 
     111          IF ( .NOT.  lpj_gap_const_mort ) THEN 
    120112 
    121113             ! 
    … …  
    125117             WHERE ( PFTpresent(:,j) .AND. ( lm_lastyearmax(:,j) .GT. min_stomate ) ) 
    126118 
     119!SZ 080806, changed to LPJ formulation according to Smith et al., 2001  
     120 
    127121                ! how much did the tree grow per year? 
    128122 
    129                 delta_biomass(:) = & 
    130                      MAX( npp_longterm(:,j) - ( turnover_longterm(:,j,ileaf) + & 
    131                      turnover_longterm(:,j,iroot) + turnover_longterm(:,j,ifruit) ), & 
    132                      zero ) 
     123!!$                delta_biomass(:) = & 
     124!!$                     MAX( npp_longterm(:,j) - ( turnover_longterm(:,j,ileaf) + & 
     125!!$                     turnover_longterm(:,j,iroot) + turnover_longterm(:,j,ifruit) ), & 
     126!!$                     0._r_std ) 
     127 
     128            ! note that npp_longterm is now actually longterm growth efficiency (NPP/LAI) 
     129            ! to be fair to deciduous trees 
     130             delta_biomass(:) = MAX( npp_longterm(:,j) - ( turnover_longterm(:,j,ileaf) + & 
     131                  turnover_longterm(:,j,iroot) + turnover_longterm(:,j,ifruit) + &  
     132                  turnover_longterm(:,j,isapabove) + turnover_longterm(:,j,isapbelow) ) ,zero) 
    133133 
    134134                ! scale this to the leaf surface of the tree 
    135  
    136                 vigour(:) = delta_biomass(:) / (lm_lastyearmax(:,j)*sla(j)) / vigour_coeff 
     135!!$                vigour(:) = delta_biomass(:) / (lm_lastyearmax(:,j)*sla(j)) / vigour_coeff 
     136             vigour(:) = delta_biomass(:) / (lm_lastyearmax(:,j)*sla(j)) 
    137137 
    138138             ELSEWHERE 
    … …  
    147147                ! low vigour. 
    148148 
    149                 availability(:) = availability_fact / ( 1.+vigour(:)/vigour_ref) 
     149!SZ 080806, changed to LPJ formulation according to Smith et al., 2001  
     150! tuned maximal mortality to 0.05 to get realistic range of avergage age to get ~100 years at GREFF=100 
     151! for the range of modelled annual NPP 
     152!!$                availability(:) = min_avail / ( 1.+vigour(:)/vigour_ref ) 
     153                availability(:) = 0.1 / ( 1.+ref_greff*vigour(:) ) 
    150154 
    151155                ! Mortality (fraction per time step). 
    … …  
    158162                ! approximation ok as availability < 0.02 << 1 
    159163 
    160                 mortality(:,j) = availability(:) * dt/one_year 
     164                mortality(:,j) = MAX(min_avail,availability(:))  * dt/one_year   
     165!!$                mortality(:,j) = availability(:) * dt/one_year 
    161166 
    162167             ENDWHERE 
    … …  
    199204             WHERE ( PFTpresent(:,j) ) 
    200205 
    201                 bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + mortality(:,j) * biomass(:,j,k) 
    202  
    203                 biomass(:,j,k) = biomass(:,j,k) * ( 1. - mortality(:,j) ) 
     206                dmortality(:) =  mortality(:,j) * biomass(:,j,k) 
     207                bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + dmortality(:) 
     208                 
     209                biomass(:,j,k) = biomass(:,j,k) - dmortality(:) 
    204210 
    205211             ENDWHERE 
    … …  
    211217          ! 
    212218 
    213           IF ( control%ok_dgvm ) THEN 
    214  
    215              WHERE ( PFTpresent(:,j) ) 
    216  
    217                 ind(:,j) = ind(:,j) * ( 1. - mortality(:,j) ) 
    218  
    219              ENDWHERE 
    220  
     219!SZ 080806, allow changing density in static case when mortality is dynamic 
     220          IF ( control%ok_dgvm .OR. .NOT.lpj_gap_const_mort) THEN 
     221 
     222             WHERE ( PFTpresent(:,j) ) 
     223 
     224                ind(:,j) = ind(:,j) * ( un - mortality(:,j) ) 
     225 
     226             ENDWHERE 
     227 
     228          ENDIF 
     229 
     230       ELSE  
     231 
     232          IF ( .NOT.control%ok_dgvm .AND. .NOT.lpj_gap_const_mort) THEN 
     233 
     234             WHERE ( PFTpresent(:,j) .AND. ( npp_longterm(:,j) .LE. 10. ) ) 
     235 
     236                mortality(:,j) = 1. 
     237 
     238             ENDWHERE 
     239             DO k = 1, nparts 
     240 
     241                WHERE ( PFTpresent(:,j) ) 
     242 
     243                   dmortality(:) =  mortality(:,j) * biomass(:,j,k) 
     244                    
     245                   bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + dmortality(:) 
     246                    
     247                   biomass(:,j,k) = biomass(:,j,k) - dmortality(:) 
     248 
     249                ENDWHERE 
     250             ENDDO 
     251              
    221252          ENDIF 
    222253 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/lpj_kill.f90

    r64 r257  
    2525  SUBROUTINE kill (npts, whichroutine, lm_lastyearmax, & 
    2626       ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, & 
    27        lai, age, leaf_age, leaf_frac, & 
     27       lai, age, leaf_age, leaf_frac, npp_longterm, & 
    2828       when_growthinit, everywhere, veget, veget_max, bm_to_litter) 
    2929 
    … …  
    3737    INTEGER(i_std), INTENT(in)                                       :: npts 
    3838    ! message 
    39     CHARACTER*10, INTENT(in)                                  :: whichroutine 
     39    CHARACTER(LEN=10), INTENT(in)                                  :: whichroutine 
    4040    ! last year's maximum leaf mass, for each PFT (gC/(m**2 of ground)) 
    4141    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lm_lastyearmax 
    … …  
    7272    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground 
    7373    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget_max 
     74    ! "long term" net primary productivity (gC/(m**2 of ground)/year) 
     75    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: npp_longterm  
    7476    ! conversion of biomass to litter (gC/(m**2 of ground)) / day 
    7577    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)    :: bm_to_litter 
    … …  
    98100          ! the "was_killed" business is necessary for a more efficient code on the VPP 
    99101 
    100           WHERE ( PFTpresent(:,j) .AND. & 
    101                ( ( ind(:,j) .LT. min_stomate ) .OR. & 
    102                ( lm_lastyearmax(:,j) .LT. min_stomate ) ) ) 
    103  
     102          IF ( control%ok_dgvm ) THEN 
     103             WHERE ( PFTpresent(:,j) .AND. & 
     104                  ( ( ind(:,j) .LT. min_stomate ) .OR. & 
     105                  ( lm_lastyearmax(:,j) .LT. min_stomate ) ) ) 
     106              
    104107             was_killed(:) = .TRUE. 
    105  
    106           ENDWHERE 
     108              
     109             ENDWHERE 
     110           
     111          ELSE 
     112             WHERE ( PFTpresent(:,j) .AND. &  
     113                  (biomass(:,j,icarbres) .LE.zero .OR. &  
     114                  biomass(:,j,iroot).LT.-min_stomate .OR. biomass(:,j,ileaf).LT.-min_stomate ).AND. &  
     115                  ind(:,j).GT. zero) 
     116 
     117                was_killed(:) = .TRUE. 
     118 
     119             ENDWHERE 
     120 
     121             IF(.NOT.tree(j).AND..NOT.lpj_gap_const_mort)THEN 
     122                WHERE ( was_killed(:) ) 
     123 
     124                   npp_longterm(:,j)=500. 
     125 
     126                ENDWHERE 
     127             ENDIF 
     128 
     129          ENDIF 
    107130 
    108131          IF ( ANY( was_killed(:) ) ) THEN 
    109132 
    110133             WHERE ( was_killed(:) ) 
    111  
    112                 ind(:,j) = 0.0 
    113134 
    114135                bm_to_litter(:,j,ileaf) = bm_to_litter(:,j,ileaf) + biomass(:,j,ileaf) 
    … …  
    123144                bm_to_litter(:,j,icarbres) = bm_to_litter(:,j,icarbres) + biomass(:,j,icarbres) 
    124145 
    125                 biomass(:,j,ileaf) = 0.0 
    126                 biomass(:,j,isapabove) = 0.0 
    127                 biomass(:,j,isapbelow) = 0.0 
    128                 biomass(:,j,iheartabove) = 0.0 
    129                 biomass(:,j,iheartbelow) = 0.0 
    130                 biomass(:,j,iroot) = 0.0 
    131                 biomass(:,j,ifruit) = 0.0 
    132                 biomass(:,j,icarbres) = 0.0 
    133  
    134                 PFTpresent(:,j) = .FALSE. 
    135  
    136                 cn_ind(:,j) = 0.0 
     146                biomass(:,j,ileaf) = zero 
     147                biomass(:,j,isapabove) = zero 
     148                biomass(:,j,isapbelow) = zero 
     149                biomass(:,j,iheartabove) = zero 
     150                biomass(:,j,iheartbelow) = zero 
     151                biomass(:,j,iroot) = zero 
     152                biomass(:,j,ifruit) = zero 
     153                biomass(:,j,icarbres) = zero 
     154 
     155             ENDWHERE   ! number of individuals very low 
     156 
     157             IF (control%ok_dgvm) THEN 
     158 
     159                WHERE ( was_killed(:) ) 
     160                   PFTpresent(:,j) = .FALSE. 
     161 
     162                   veget_max(:,j) = zero 
     163                    
     164                   RIP_time(:,j) = zero 
     165 
     166                ENDWHERE  ! number of individuals very low 
     167 
     168             ENDIF 
     169 
     170             WHERE ( was_killed(:) ) 
     171 
     172                ind(:,j) = zero 
     173 
     174                cn_ind(:,j) = zero 
    137175 
    138176                senescence(:,j) = .FALSE. 
    139177 
    140  
    141                 age(:,j) = 0.0 
    142  
    143                 when_growthinit(:,j) = undef 
    144  
    145                 everywhere(:,j) = 0.0 
    146  
    147                 veget(:,j) = 0.0 
    148  
    149                 veget_max(:,j) = 0.0 
    150  
    151                 RIP_time(:,j) = 0.0 
     178                age(:,j) = zero 
     179 
     180                ! SZ: why undef ??? this causes a delay in reestablishment 
     181                !when_growthinit(:,j) = undef 
     182                when_growthinit(:,j) = large_value  
     183 
     184                everywhere(:,j) = zero 
     185 
     186                veget(:,j) = zero 
    152187 
    153188             ENDWHERE   ! number of individuals very low 
    … …  
    157192                WHERE ( was_killed(:) ) 
    158193 
    159                    leaf_age(:,j,m) = 0.0  
    160                    leaf_frac(:,j,m) = 0.0  
     194                   leaf_age(:,j,m) = zero  
     195                   leaf_frac(:,j,m) = zero  
    161196 
    162197                ENDWHERE 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/lpj_light.f90

    r64 r257  
    1414! Exclude agricultural pfts from competition 
    1515! 
     16! SZ: added light competition for the static case if the mortality is not  
     17!     assumed to be constant. 
     18! other modifs: 
     19! -1      FPC is now always calculated from lm_lastyearmax*sla, since the aim of this DGVM is  
     20!         to represent community ecology effects; seasonal variations in establishment related to phenology 
     21!         may be relevant, but beyond the scope of a 1st generation DGVM  
     22! -2      problem, if agriculture is present, fpc can never reach 1.0 since natural veget_max < 1.0. To 
     23!         correct for this, ind must be recalculated to correspond to the natural density... 
     24!         since ind is 1/m2 grid cell, this can be achived by dividing ind by the agricultural fraction 
     25 
     26! 
    1627! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_light.f90,v 1.8 2009/01/06 15:01:25 ssipsl Exp $ 
    1728! IPSL (2006) 
    … …  
    4354 
    4455  SUBROUTINE light (npts, dt, & 
    45        PFTpresent, cn_ind, lai, maxfpc_lastyear, & 
    46        ind, biomass, veget_lastlight, bm_to_litter) 
     56       veget_max, fpc_max, PFTpresent, cn_ind, lai, maxfpc_lastyear, & 
     57       lm_lastyearmax, ind, biomass, veget_lastlight, bm_to_litter, mortality) 
    4758 
    4859    ! 
    … …  
    6475    ! last year's maximum fpc for each natural PFT, on ground 
    6576    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: maxfpc_lastyear 
     77    ! last year's maximum leafmass for each natural PFT, on ground 
     78    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: lm_lastyearmax 
     79    ! last year's maximum fpc for each natural PFT, on ground 
     80    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: veget_max 
     81    ! last year's maximum fpc for each natural PFT, on ground 
     82    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: fpc_max 
    6683 
    6784    ! 0.2 modified fields 
    … …  
    7592    ! biomass taken away (gC/m**2) 
    7693    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)   :: bm_to_litter 
     94    ! fraction of individuals that died this time step 
     95    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)          :: mortality 
    7796 
    7897    ! 0.3 local 
    7998 
    8099    ! index 
    81     INTEGER(i_std)                                            :: i,j 
     100    INTEGER(i_std)                                            :: i,j,k,m 
    82101    ! total natural fpc 
    83102    REAL(r_std), DIMENSION(npts)                              :: sumfpc 
     103    ! fraction of natural vegetation at grid cell level 
     104    REAL(r_std), DIMENSION(npts)                              :: fracnat 
    84105    ! total natural woody fpc 
    85106    REAL(r_std)                                               :: sumfpc_wood 
    … …  
    100121    ! Fraction of plants that survive 
    101122    REAL(r_std), DIMENSION(nvm)                              :: survive 
     123    ! FPC for static mode 
     124    REAL(r_std), DIMENSION(npts)                              :: fpc_real 
     125    ! FPC mortality for static mode 
     126    REAL(r_std), DIMENSION(npts)                              :: lai_ind 
    102127    ! number of grass PFTs present in the grid box 
    103     INTEGER(i_std)                                            :: num_grass 
     128!    INTEGER(i_std)                                            :: num_grass 
    104129    ! New total grass fpc 
    105130    REAL(r_std)                                               :: sumfpc_grass2 
    106131    ! fraction of plants that dies each day (1/day) 
    107132    REAL(r_std), DIMENSION(npts,nvm)                         :: light_death 
     133    ! Relative change of number of individuals for trees 
     134    REAL(r_std)                                               :: fpc_dec 
    108135 
    109136    ! ========================================================================= 
    … …  
    139166    ENDIF 
    140167 
    141     ! 
    142     ! 2 fpc characteristics 
    143     ! 
    144  
    145     ! 
    146     ! 2.1 calculate fpc on natural part of grid cell. 
    147     ! 
    148  
    149     DO j = 2, nvm 
    150  
    151        IF ( natural(j) ) THEN 
    152  
    153           ! 2.1.1 natural PFTs 
    154  
    155           IF ( tree(j) ) THEN 
    156  
    157              ! 2.1.1.1 trees: minimum cover due to stems, branches etc. 
    158  
    159              DO i = 1, npts 
    160                 IF (lai(i,j) == val_exp) THEN 
    161                    fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) 
    162                 ELSE 
    163                    fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) * & 
    164                         MAX( ( un - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover ) 
    165                 ENDIF 
    166              ENDDO 
     168    IF (control%ok_dgvm) THEN 
     169       ! 
     170       ! 2 fpc characteristics 
     171       ! 
     172 
     173       ! 2.0 Only natural part of the grid cell: 
     174       ! calculate fraction of natural and agricultural (1-fracnat) surface 
     175 
     176       fracnat(:) = 1. 
     177       DO j = 2,nvm 
     178          IF ( .NOT. natural(j) ) THEN 
     179             fracnat(:) = fracnat(:) - veget_max(:,j) 
     180          ENDIF 
     181       ENDDO 
     182       ! 
     183       ! 2.1 calculate fpc on natural part of grid cell. 
     184       ! 
     185       fpc_nat(:,:)=zero 
     186       fpc_nat(:,ibare_sechiba)=un 
     187 
     188       DO j = 2, nvm 
     189 
     190          IF ( natural(j) ) THEN 
     191 
     192             ! 2.1.1 natural PFTs 
     193 
     194             IF ( tree(j) ) THEN 
     195 
     196                ! 2.1.1.1 trees: minimum cover due to stems, branches etc. 
     197 
     198                !          DO i = 1, npts 
     199                !             IF (lai(i,j) == val_exp) THEN 
     200                !                fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) 
     201                !             ELSE 
     202                !                fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) * & 
     203                !                     MAX( ( 1._r_std - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover ) 
     204                !             ENDIF 
     205                !          ENDDO 
     206 
     207                !NV : modif from SZ version : fpc is based on veget_max, not veget. 
     208                WHERE(fracnat(:).GE.min_stomate) 
     209                   !            WHERE(LAI(:,j) == val_exp) 
     210                   !               fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) 
     211                   !            ELSEWHERE 
     212                   !               fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) * & 
     213                   !                    MAX( ( 1._r_std - exp( - lm_lastyearmax(:,j) * sla(j) * ext_coeff(j) ) ), min_cover ) 
     214                   !            ENDWHERE 
     215                   fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) 
     216                ENDWHERE 
     217 
     218             ELSE 
     219 
     220                !NV : modif from SZ version : fpc is based on veget_max, not veget. 
     221                WHERE(fracnat(:).GE.min_stomate) 
     222                   !            WHERE(LAI(:,j) == val_exp) 
     223                   !               fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) 
     224                   !            ELSEWHERE 
     225                   !               fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) * & 
     226                   !                    ( 1._r_std - exp( - lm_lastyearmax(:,j) * sla(j) * ext_coeff(j) ) ) 
     227                   !            ENDWHERE 
     228                   fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) / fracnat(:) 
     229                ENDWHERE 
     230 
     231!!$                ! 2.1.1.2 bare ground  
     232!!$                IF (j == ibare_sechiba) THEN 
     233!!$                   fpc_nat(:,j) = cn_ind(:,j) * ind(:,j)  
     234!!$ 
     235!!$                   ! 2.1.1.3 grasses 
     236!!$                ELSE 
     237!!$                   DO i = 1, npts 
     238!!$                      IF (lai(i,j) == val_exp) THEN 
     239!!$                         fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) 
     240!!$                      ELSE 
     241!!$                         fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) * & 
     242!!$                              ( 1._r_std - exp( -lai(i,j) * ext_coeff(j) ) ) 
     243!!$                      ENDIF 
     244!!$                   ENDDO 
     245!!$                ENDIF 
     246 
     247             ENDIF  ! tree/grass 
    167248 
    168249          ELSE 
    169250 
    170              ! 2.1.1.2 bare ground  
    171              IF (j == ibare_sechiba) THEN 
    172                 fpc_nat(:,j) = cn_ind(:,j) * ind(:,j)  
    173  
    174                 ! 2.1.1.3 grasses 
     251             ! 2.1.2 agricultural PFTs: not present on natural part 
     252 
     253             fpc_nat(:,j) = zero 
     254 
     255          ENDIF    ! natural/agricultural 
     256 
     257       ENDDO 
     258        
     259       ! 
     260       ! 2.2 sum natural fpc for every grid point 
     261       ! 
     262 
     263       sumfpc(:) = zero 
     264       DO j = 2,nvm 
     265          !SZ bug correction MERGE: need to subtract agricultural area! 
     266          sumfpc(:) = sumfpc(:) + fpc_nat(:,j) 
     267       ENDDO 
     268        
     269       ! 
     270       ! 3 Light competition 
     271       ! 
     272        
     273       light_death(:,:) = zero 
     274 
     275       DO i = 1, npts ! SZ why this loop and not a vector statement ? 
     276           
     277          ! Only if vegetation cover is dense 
     278           
     279          IF ( sumfpc(i) .GT. fpc_crit ) THEN 
     280              
     281             ! fpc change for each pft 
     282             ! There are two possibilities: either we compare today's fpc with the fpc after the last 
     283             ! time step, or we compare it to last year's maximum fpc of that PFT. In the first case, 
     284             ! the fpc increase will be strong for seasonal PFTs at the beginning of the growing season. 
     285             ! As for trees, the cutback is proportional to this increase, this means that seasonal trees 
     286             ! will be disadvantaged compared to evergreen trees. In the original LPJ model, with its  
     287             ! annual time step, the second method was used (this corresponds to annual_increase=.TRUE.) 
     288              
     289             IF ( annual_increase ) THEN 
     290                deltafpc(:) = MAX( (fpc_nat(i,:)-maxfpc_lastyear(i,:)), zero ) 
    175291             ELSE 
    176                 DO i = 1, npts 
    177                    IF (lai(i,j) == val_exp) THEN 
    178                       fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) 
     292                deltafpc(:) = MAX( (fpc_nat(i,:)-veget_lastlight(i,:)), zero ) 
     293             ENDIF 
     294              
     295             ! default: survive 
     296              
     297             survive(:) = 1.0 
     298              
     299             ! 
     300             ! 3.1 determine some characteristics of the fpc distribution 
     301             ! 
     302              
     303             sumfpc_wood = zero 
     304             sumdelta_fpc_wood = zero 
     305             maxfpc_wood = zero 
     306             optpft_wood = 0 
     307             sumfpc_grass = zero 
     308             !        num_grass = 0 
     309              
     310             DO j = 2,nvm 
     311                 
     312                ! only natural pfts 
     313                 
     314                IF ( natural(j) ) THEN 
     315                    
     316                   IF ( tree(j) ) THEN 
     317                       
     318                      ! trees 
     319                       
     320                      ! total woody fpc 
     321                       
     322                      sumfpc_wood = sumfpc_wood + fpc_nat(i,j) 
     323                       
     324                      ! how much did the woody fpc increase 
     325                       
     326                      sumdelta_fpc_wood = sumdelta_fpc_wood + deltafpc(j) 
     327                       
     328                      ! which woody pft is preponderant 
     329                       
     330                      IF ( fpc_nat(i,j) .GT. maxfpc_wood ) THEN 
     331                          
     332                         optpft_wood = j 
     333                          
     334                         maxfpc_wood = fpc_nat(i,j) 
     335                       
     336                      ENDIF 
     337                    
    179338                   ELSE 
    180                       fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) * & 
    181                            ( un - exp( -lai(i,j) * ext_coeff(j) ) ) 
    182                    ENDIF 
    183                 ENDDO 
    184              ENDIF 
    185           ENDIF  ! tree/grass 
    186  
    187        ELSE 
    188  
    189           ! 2.1.2 agricultural PFTs: not present on natural part 
    190  
    191           fpc_nat(:,j) = 0.0 
    192  
    193        ENDIF    ! natural/agricultural 
    194  
    195     ENDDO 
    196  
    197     ! 
    198     ! 2.2 sum natural fpc for every grid point 
    199     ! 
    200  
    201     sumfpc(:) = zero 
    202     DO j = 2,nvm 
    203        !SZ bug correction MERGE: need to subtract agricultural area! 
    204        sumfpc(:) = sumfpc(:) + fpc_nat(:,j) 
    205     ENDDO 
    206  
    207     ! 
    208     ! 3 Light competition 
    209     ! 
    210  
    211     light_death(:,:) = 0.0 
    212  
    213     DO i = 1, npts ! SZ why this loop and not a vector statement ? 
    214  
    215        ! Only if vegetation cover is dense 
    216  
    217        IF ( sumfpc(i) .GT. fpc_crit ) THEN 
    218  
    219           ! fpc change for each pft 
    220           ! There are two possibilities: either we compare today's fpc with the fpc after the last 
    221           ! time step, or we compare it to last year's maximum fpc of that PFT. In the first case, 
    222           ! the fpc increase will be strong for seasonal PFTs at the beginning of the growing season. 
    223           ! As for trees, the cutback is proportional to this increase, this means that seasonal trees 
    224           ! will be disadvantaged compared to evergreen trees. In the original LPJ model, with its  
    225           ! annual time step, the second method was used (this corresponds to annual_increase=.TRUE.) 
    226  
    227           IF ( annual_increase ) THEN 
    228              deltafpc(:) = MAX( (fpc_nat(i,:)-maxfpc_lastyear(i,:)), zero ) 
    229           ELSE 
    230              deltafpc(:) = MAX( (fpc_nat(i,:)-veget_lastlight(i,:)), zero ) 
    231           ENDIF 
    232  
    233           ! default: survive 
    234  
    235           survive(:) = 1.0 
    236  
    237           ! 
    238           ! 3.1 determine some characteristics of the fpc distribution 
    239           ! 
    240  
    241           sumfpc_wood = 0.0 
    242           sumdelta_fpc_wood = 0.0 
    243           maxfpc_wood = 0.0 
    244           optpft_wood = 0 
    245           sumfpc_grass = 0.0 
    246           num_grass = 0 
    247  
    248           DO j = 2,nvm 
    249  
    250              ! only natural pfts 
    251  
    252              IF ( natural(j) ) THEN 
    253  
    254                 IF ( tree(j) ) THEN 
    255  
    256                    ! trees 
    257  
    258                    ! total woody fpc 
    259  
    260                    sumfpc_wood = sumfpc_wood + fpc_nat(i,j) 
    261  
    262                    ! how much did the woody fpc increase 
    263  
    264                    sumdelta_fpc_wood = sumdelta_fpc_wood + deltafpc(j) 
    265  
    266                    ! which woody pft is preponderant 
    267  
    268                    IF ( fpc_nat(i,j) .GT. maxfpc_wood ) THEN 
    269  
    270                       optpft_wood = j 
    271  
    272                       maxfpc_wood = fpc_nat(i,j) 
    273  
    274                    ENDIF 
    275  
    276                 ELSE 
    277  
     339                    
    278340                   ! grasses 
    279341 
    280342                   ! total (natural) grass fpc 
    281  
     343                    
    282344                   sumfpc_grass = sumfpc_grass + fpc_nat(i,j) 
    283  
     345                    
    284346                   ! number of grass PFTs present in the grid box 
    285  
    286                    IF ( PFTpresent(i,j) ) THEN 
    287                       num_grass = num_grass + 1 
    288                    ENDIF 
    289  
     347                    
     348                   ! IF ( PFTpresent(i,j) ) THEN 
     349                   !    num_grass = num_grass + 1 
     350                   ! ENDIF 
     351                    
    290352                ENDIF   ! tree or grass 
    291  
     353                 
    292354             ENDIF   ! natural 
    293  
     355              
    294356          ENDDO     ! loop over pfts 
    295  
     357           
    296358          ! 
    297359          ! 3.2 light competition: assume wood outcompetes grass 
    298360          ! 
    299  
    300           IF (sumfpc_wood .GE. fpc_crit ) THEN 
    301  
    302              ! 
    303              ! 3.2.1 all allowed natural space is covered by wood: 
    304              !       cut back trees to fpc_crit. 
    305              !       Original DGVM: kill grasses. Modified: we let a very 
    306              !       small fraction of grasses survive. 
    307              ! 
    308  
     361          !SZ 
     362!!$             IF (sumfpc_wood .GE. fpc_crit ) THEN 
     363           
     364          ! 
     365          ! 3.2.1 all allowed natural space is covered by wood: 
     366          !       cut back trees to fpc_crit. 
     367          !       Original DGVM: kill grasses. Modified: we let a very 
     368          !       small fraction of grasses survive. 
     369          ! 
     370           
     371          DO j = 2,nvm 
     372              
     373             ! only present and natural pfts compete 
     374              
     375             IF ( PFTpresent(i,j) .AND. natural(j) ) THEN 
     376                 
     377                IF ( tree(j) ) THEN 
     378                    
     379                   ! 
     380                   ! 3.2.1.1 tree 
     381                   ! 
     382                    
     383                   ! no single woody pft is overwhelming 
     384                   ! (original DGVM: tree_mercy = 0.0 ) 
     385                   ! The reduction rate is proportional to the ratio deltafpc/fpc. 
     386                    
     387                   IF (sumfpc_wood .GE. fpc_crit .AND. fpc_nat(i,j) .GT. min_stomate .AND. &  
     388                        sumdelta_fpc_wood .GT. min_stomate) THEN 
     389                       
     390                      ! reduct = MIN( ( ( deltafpc(j)/sumdelta_fpc_wood * & 
     391                      !     (sumfpc_wood-fpc_crit) ) / fpc_nat(i,j) ), & 
     392                      !     ( 1._r_std - tree_mercy ) ) 
     393                      reduct = un - MIN((fpc_nat(i,j)-(sumfpc_wood-fpc_crit) &  
     394                           * deltafpc(j)/sumdelta_fpc_wood)/fpc_nat(i,j), un ) 
     395                       
     396                   ELSE 
     397                       
     398                      ! tree fpc didn't icrease or it started from nothing 
     399                       
     400                      reduct = zero 
     401                       
     402                   ENDIF 
     403                    
     404                   survive(j) = un - reduct 
     405                    
     406                ELSE 
     407                    
     408                   ! 
     409                   ! 3.2.1.2 grass: let a very small fraction survive (the sum of all 
     410                   !         grass individuals may make up a maximum cover of 
     411                   !         grass_mercy [for lai -> infinity]). 
     412                   !         In the original DGVM, grasses were killed in that case, 
     413                   !         corresponding to grass_mercy = 0. 
     414                   ! 
     415                    
     416                   ! survive(j) = ( grass_mercy / REAL( num_grass,r_std ) ) / ind(i,j) 
     417                    
     418                   ! survive(j) = MIN( 1._r_std, survive(j)  
     419                    
     420                   IF(sumfpc_grass .GE. 1.0-MIN(fpc_crit,sumfpc_wood).AND. &  
     421                        sumfpc_grass.GE.min_stomate) THEN 
     422                       
     423                      fpc_dec=(sumfpc_grass-1.+MIN(fpc_crit,sumfpc_wood))*fpc_nat(i,j)/sumfpc_grass 
     424                       
     425                      reduct=fpc_dec 
     426                   ELSE  
     427                      reduct = zero 
     428                   ENDIF 
     429                   survive(j) = ( un -  reduct )  
     430                    
     431                ENDIF   ! tree or grass 
     432                 
     433             ENDIF     ! pft there and natural 
     434           
     435          ENDDO       ! loop over pfts 
     436        
     437       !SZ 
     438!!$    ELSE 
     439!!$        
     440!!$       ! 
     441!!$       ! 3.2.2 not too much wood so that grasses can subsist 
     442!!$       ! 
     443!!$        
     444!!$       ! new total grass fpc 
     445!!$       sumfpc_grass2 = fpc_crit - sumfpc_wood 
     446!!$        
     447!!$       DO j = 2,nvm 
     448!!$           
     449!!$          ! only present and natural PFTs compete 
     450!!$           
     451!!$          IF ( PFTpresent(i,j) .AND. natural(j) ) THEN 
     452!!$              
     453!!$             IF ( tree(j) ) THEN 
     454!!$                 
     455!!$                ! no change for trees 
     456!!$                 
     457!!$                survive(j) = 1.0 
     458!!$                 
     459!!$             ELSE 
     460!!$                 
     461!!$                ! grass: fractional loss is the same for all grasses 
     462!!$                 
     463!!$                IF ( sumfpc_grass .GT. min_stomate ) THEN 
     464!!$                   survive(j) = sumfpc_grass2 / sumfpc_grass 
     465!!$                ELSE 
     466!!$                   survive(j)=  zero 
     467!!$                ENDIF 
     468!!$                 
     469!!$             ENDIF 
     470!!$              
     471!!$          ENDIF    ! pft there and natural 
     472!!$           
     473!!$       ENDDO       ! loop over pfts 
     474!!$        
     475!!$    ENDIF    ! sumfpc_wood > fpc_crit 
     476 
     477             ! 
     478             ! 3.3 update output variables 
     479             ! 
     480        
    309481             DO j = 2,nvm 
    310  
    311                 ! only present and natural pfts compete 
    312  
     482           
    313483                IF ( PFTpresent(i,j) .AND. natural(j) ) THEN 
    314  
    315                    IF ( tree(j) ) THEN 
    316  
    317                       ! 
    318                       ! 3.2.1.1 tree 
    319                       ! 
    320  
    321                       IF ( maxfpc_wood .GE. fpc_crit ) THEN 
    322  
    323                          ! 3.2.1.1.1 one single woody pft is overwhelming 
    324  
    325                          IF ( j .eq. optpft_wood ) THEN 
    326  
    327                             ! reduction for this dominant pft 
    328  
    329                             reduct = 1. - fpc_crit / fpc_nat(i,j) 
    330  
    331                          ELSE 
    332  
    333                             ! strongly reduce all other woody pfts 
    334                             !   (original DGVM: tree_mercy = 0.0 ) 
    335  
    336                             reduct = 1. - tree_mercy 
    337  
    338                          ENDIF   ! pft = dominant woody pft 
    339  
    340                       ELSE 
    341  
    342                          ! 3.2.1.1.2 no single woody pft is overwhelming 
    343                          !           (original DGVM: tree_mercy = 0.0 ) 
    344                          !           The reduction rate is proportional to the ratio deltafpc/fpc. 
    345  
    346                          IF ( fpc_nat(i,j) .GE. min_stomate ) THEN 
    347  
    348                             reduct = MIN( ( ( deltafpc(j)/sumdelta_fpc_wood * & 
    349                                  (sumfpc_wood-fpc_crit) ) / fpc_nat(i,j) ), & 
    350                                  ( un - tree_mercy ) ) 
    351  
    352                          ELSE 
    353  
    354                             ! tree fpc didn't icrease or it started from nothing 
    355  
    356                             reduct = 0. 
    357  
    358                          ENDIF 
    359  
    360                       ENDIF   ! maxfpc_wood > fpc_crit 
    361  
    362                       survive(j) = 1. - reduct 
    363  
     484                    
     485                   bm_to_litter(i,j,:) = bm_to_litter(i,j,:) + & 
     486                        biomass(i,j,:) * ( un - survive(j) ) 
     487                    
     488                   biomass(i,j,:) = biomass(i,j,:) * survive(j) 
     489                    
     490                   IF ( control%ok_dgvm ) THEN 
     491                      ind(i,j) = ind(i,j) * survive(j) 
     492                   ENDIF 
     493                    
     494                   ! fraction of plants that dies each day.  
     495                   ! exact formulation: light_death(i,j) = 1. - survive(j) ** (1/dt) 
     496                   light_death(i,j) = ( un - survive(j) ) / dt 
     497                    
     498                ENDIF      ! pft there and natural 
     499                 
     500             ENDDO        ! loop over pfts 
     501              
     502          ENDIF      ! sumfpc > fpc_crit 
     503           
     504       ENDDO        ! loop over grid points 
     505        
     506       ! 
     507       ! 4 recalculate fpc on natural part of grid cell (for next light competition) 
     508       ! 
     509        
     510       DO j = 2,nvm 
     511           
     512          IF ( natural(j) ) THEN 
     513              
     514             ! 
     515             ! 4.1 natural PFTs 
     516             ! 
     517              
     518             IF ( tree(j) ) THEN 
     519                 
     520                ! 4.1.1 trees: minimum cover due to stems, branches etc. 
     521                 
     522                DO i = 1, npts 
     523                   !NVMODIF          
     524                   !    IF (lai(i,j) == val_exp) THEN 
     525                   !                veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j)  
     526                   !             ELSE 
     527                   !                veget_lastlight(i,j) = & 
     528                   !                     cn_ind(i,j) * ind(i,j) * & 
     529                   !                     MAX( ( un - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover ) 
     530                   !             ENDIF 
     531                   !!                veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j)  
     532                   IF (lai(i,j) == val_exp) THEN 
     533                      veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j)  
    364534                   ELSE 
    365  
    366                       ! 
    367                       ! 3.2.1.2 grass: let a very small fraction survive (the sum of all 
    368                       !         grass individuals may make up a maximum cover of 
    369                       !         grass_mercy [for lai -> infinity]). 
    370                       !         In the original DGVM, grasses were killed in that case, 
    371                       !         corresponding to grass_mercy = 0. 
    372                       ! 
    373  
    374                       survive(j) = ( grass_mercy / REAL( num_grass,r_std ) ) / ind(i,j) 
    375  
    376                       survive(j) = MIN( un, survive(j) ) 
    377  
    378                    ENDIF   ! tree or grass 
    379  
    380                 ENDIF     ! pft there and natural 
    381  
    382              ENDDO       ! loop over pfts 
    383  
     535                      veget_lastlight(i,j) = & 
     536                           cn_ind(i,j) * ind(i,j) * & 
     537                           MAX( ( un - EXP( - lm_lastyearmax(i,j) * sla(j) * ext_coeff(j) ) ), min_cover ) 
     538                   ENDIF 
     539                ENDDO 
     540                 
     541             ELSE 
     542                 
     543                ! 4.1.2 grasses 
     544                DO i = 1, npts 
     545                   !NVMODIF          
     546                   !            IF (lai(i,j) == val_exp) THEN 
     547                   !                veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j)  
     548                   !             ELSE 
     549                   !                veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j) * & 
     550                   !                     ( un - exp( -lai(i,j) * ext_coeff(j) ) ) 
     551                   !             ENDIF 
     552                   !!veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j)  
     553                   IF (lai(i,j) == val_exp) THEN 
     554                      veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j)  
     555                   ELSE 
     556                      veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j) * & 
     557                           ( un - exp( - lm_lastyearmax(i,j) * sla(j) * ext_coeff(j) ) ) 
     558                   ENDIF 
     559                ENDDO 
     560             ENDIF    ! tree/grass 
     561              
    384562          ELSE 
    385  
    386              ! 
    387              ! 3.2.2 not too much wood so that grasses can subsist 
    388              ! 
    389  
    390              ! new total grass fpc 
    391              sumfpc_grass2 = fpc_crit - sumfpc_wood 
    392  
    393              DO j = 2,nvm 
    394  
    395                 ! only present and natural PFTs compete 
    396  
    397                 IF ( PFTpresent(i,j) .AND. natural(j) ) THEN 
    398  
    399                    IF ( tree(j) ) THEN 
    400  
    401                       ! no change for trees 
    402  
    403                       survive(j) = 1.0 
    404  
    405                    ELSE 
    406  
    407                       ! grass: fractional loss is the same for all grasses 
    408  
    409                       IF ( sumfpc_grass .GT. min_stomate ) THEN 
    410                          survive(j) = sumfpc_grass2 / sumfpc_grass 
    411                       ELSE 
    412                          survive(j)=  0.0 
    413                       ENDIF 
    414  
    415                    ENDIF 
    416  
    417                 ENDIF    ! pft there and natural 
    418  
    419              ENDDO       ! loop over pfts 
    420  
    421           ENDIF    ! sumfpc_wood > fpc_crit 
    422  
    423           ! 
    424           ! 3.3 update output variables 
    425           ! 
    426  
    427           DO j = 2,nvm 
    428  
    429              IF ( PFTpresent(i,j) .AND. natural(j) ) THEN 
    430  
    431                 bm_to_litter(i,j,:) = bm_to_litter(i,j,:) + & 
    432                      biomass(i,j,:) * ( 1. - survive(j) ) 
    433  
    434                 biomass(i,j,:) = biomass(i,j,:) * survive(j) 
    435  
    436                 IF ( control%ok_dgvm ) THEN 
    437                    ind(i,j) = ind(i,j) * survive(j) 
    438                 ENDIF 
    439  
    440                 ! fraction of plants that dies each day.  
    441                 ! exact formulation: light_death(i,j) = 1. - survive(j) ** (1/dt) 
    442                 light_death(i,j) = ( 1. - survive(j) ) / dt 
    443  
    444              ENDIF      ! pft there and natural 
    445  
    446           ENDDO        ! loop over pfts 
    447  
    448        ENDIF      ! sumfpc > fpc_crit 
    449  
    450     ENDDO        ! loop over grid points 
    451  
    452     ! 
    453     ! 4 recalculate fpc on natural part of grid cell (for next light competition) 
    454     ! 
    455  
    456     DO j = 2,nvm 
    457  
    458        IF ( natural(j) ) THEN 
    459  
    460           ! 
    461           ! 4.1 natural PFTs 
    462           ! 
    463  
    464           IF ( tree(j) ) THEN 
    465  
    466              ! 4.1.1 trees: minimum cover due to stems, branches etc. 
    467  
    468              DO i = 1, npts 
    469                 IF (lai(i,j) == val_exp) THEN 
    470                    veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j)  
    471                 ELSE 
    472                    veget_lastlight(i,j) = & 
    473                         cn_ind(i,j) * ind(i,j) * & 
    474                         MAX( ( un - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover ) 
    475                 ENDIF 
     563              
     564             ! 
     565             ! 4.2 agricultural PFTs: not present on natural part 
     566             ! 
     567              
     568             veget_lastlight(:,j) = zero 
     569              
     570          ENDIF      ! natural/agricultural 
     571           
     572       ENDDO 
     573        
     574    ELSE ! static 
     575        
     576       light_death(:,:) = zero 
     577        
     578       DO j = 2, nvm 
     579           
     580          IF ( natural(j) ) THEN 
     581              
     582             ! 2.1.1 natural PFTs, in the one PFT only case there needs to be no special case for grasses, 
     583             ! neither a redistribution of mortality (delta fpc) 
     584              
     585             WHERE( ind(:,j)*cn_ind(:,j) .GT. min_stomate )  
     586                lai_ind(:)=sla(j) * lm_lastyearmax(:,j) / ( ind(:,j) * cn_ind(:,j) ) 
     587             ELSEWHERE 
     588                lai_ind(:)=zero 
     589             ENDWHERE 
     590              
     591             fpc_nat(:,j) =  cn_ind(:,j) * ind(:,j) * &  
     592                  MAX( ( 1._r_std - exp( - ext_coeff(j) * lai_ind(:) ) ), min_cover ) 
     593              
     594             WHERE(fpc_nat(:,j).GT.fpc_max(:,j)) 
     595                 
     596                light_death(:,j)=MIN(un,un-fpc_max(:,j)/fpc_nat(:,j))  
     597                 
     598             ENDWHERE 
     599              
     600             DO k=1,nparts 
     601                 
     602                bm_to_litter(:,j,k)=bm_to_litter(:,j,k)+light_death(:,j)*biomass(:,j,k) 
     603                biomass(:,j,k)=biomass(:,j,k)-light_death(:,j)*biomass(:,j,k) 
     604                 
    476605             ENDDO 
    477  
    478           ELSE 
    479  
    480              ! 4.1.2 grasses 
    481              DO i = 1, npts 
    482                 IF (lai(i,j) == val_exp) THEN 
    483                    veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j)  
    484                 ELSE 
    485                    veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j) * & 
    486                         ( 1. - exp( -lai(i,j) * ext_coeff(j) ) ) 
    487                 ENDIF 
    488              ENDDO 
    489           ENDIF    ! tree/grass 
    490  
    491        ELSE 
    492  
    493           ! 
    494           ! 4.2 agricultural PFTs: not present on natural part 
    495           ! 
    496  
    497           veget_lastlight(:,j) = 0.0 
    498  
    499        ENDIF      ! natural/agricultural 
    500  
    501     ENDDO 
    502  
     606             ind(:,j)=ind(:,j)-light_death(:,j)*ind(:,j) 
     607             ! if (j==10) print *,'ind10bis=',ind(:,j),light_death(:,j)*ind(:,j) 
     608          ENDIF 
     609       ENDDO 
     610        
     611       light_death(:,:)=light_death(:,:)/dt 
     612        
     613    ENDIF 
     614     
    503615    ! 
    504616    ! 5 history 
    505617    ! 
    506  
     618     
    507619    CALL histwrite (hist_id_stomate, 'LIGHT_DEATH', itime, & 
    508620         light_death, npts*nvm, horipft_index) 
    509  
     621     
    510622    IF (bavard.GE.4) WRITE(numout,*) 'Leaving light' 
    511  
     623     
    512624  END SUBROUTINE light 
    513  
     625   
    514626END MODULE lpj_light 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/lpj_pftinout.f90

    r64 r257  
    3333  SUBROUTINE pftinout (npts, dt, adapted, regenerate, & 
    3434       neighbours, veget, veget_max, & 
    35        biomass, ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, & 
     35       biomass, ind, cn_ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, & 
    3636       PFTpresent, everywhere, when_growthinit, need_adjacent, RIP_time, & 
    3737       co2_to_bm, & 
    … …  
    6666    ! density of individuals 1/m**2 
    6767    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: ind 
     68    ! crownarea of individuals m**2 
     69    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: cn_ind 
    6870    ! mean age (years) 
    6971    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: age 
    … …  
    104106    REAL(r_std), DIMENSION(npts)                               :: avail 
    105107    ! indices 
    106     INTEGER(i_std)                                             :: i,j 
     108    INTEGER(i_std)                                             :: i,j,m 
    107109    ! total woody vegetation cover 
    108110    REAL(r_std), DIMENSION(npts)                               :: sumfrac_wood 
    … …  
    111113    ! we can introduce this PFT 
    112114    LOGICAL, DIMENSION(npts)                                  :: can_introduce 
     115    ! no real need for dimension(ntps) except for vectorisation 
     116    REAL(r_std), DIMENSION(npts)                               :: fracnat 
    113117 
    114118    ! ========================================================================= 
    … …  
    132136    ! 
    133137 
    134     ! need to know total woody vegetation fraction 
    135  
     138    ! 2.1 Only natural part of the grid cell 
     139    ! 
     140    !SZ bug correction MERGE: need to subtract agricultural area! 
     141    ! fraction of agricultural surface 
     142    fracnat(:) = 1. 
     143    do j = 2,nvm 
     144       IF ( .NOT. natural(j) ) THEN 
     145          fracnat(:) = fracnat(:) - veget_max(:,j) 
     146       ENDIF 
     147    ENDDO 
     148 
     149    ! 
     150    ! 2.2 total woody fpc on grid 
     151    ! 
    136152    sumfrac_wood(:) = zero 
    137153 
    138154    DO j = 2,nvm 
    139  
    140        IF ( tree(j) ) THEN 
    141  
    142           sumfrac_wood(:) = sumfrac_wood(:) + veget(:,j) 
    143  
     155       !SZ problem here: agriculture, not convinced that this representation of LPJ is correct 
     156       !if agriculture is present, ind must be recalculated to correspond to the natural density... 
     157       ! since ind is per grid cell, can be achived by discounting for agricultura fraction 
     158       IF ( natural(j).AND.tree(j) ) THEN 
     159          WHERE(fracnat(:).GT.min_stomate) 
     160                sumfrac_wood(:) = sumfrac_wood(:) + cn_ind(:,j) * ind(:,j) / fracnat(:) &  
     161                     * ( 1. - exp( - lm_lastyearmax(:,j) * sla(j) * ext_coeff(j) ) ) 
     162                !lai changed to lm_last 
     163          ENDWHERE 
    144164       ENDIF 
    145  
    146165    ENDDO 
    147166 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate.f90

    r64 r257  
    227227  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:)  :: nforce 
    228228 
     229  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)  :: harvest_above_monthly, cflux_prod_monthly 
     230 
     231  ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground  
     232  REAL(r_std), ALLOCATABLE,SAVE,DIMENSION(:,:)              :: fpc_max 
     233 
    229234  ! Date and EndOfYear, intialize and update in slowproc 
    230235  ! (Now managed in slowproc for land_use) 
    231236  ! time step of STOMATE in days 
    232   REAL(r_std),SAVE                              :: dt_days=0.           ! Time step in days for stomate 
     237  REAL(r_std),SAVE                              :: dt_days=zero           ! Time step in days for stomate 
    233238  ! to check 
    234   REAL(r_std),SAVE                              :: day_counter=0.       ! count each sechiba (dtradia) time step each day 
     239  REAL(r_std),SAVE                              :: day_counter=zero       ! count each sechiba (dtradia) time step each day 
    235240  ! date (d) 
    236241  INTEGER(i_std),SAVE                          :: date=0 
    … …  
    242247  ! Land cover change flag 
    243248  LOGICAL,SAVE                                 :: lcchange=.FALSE. 
     249  ! Do update of monthly variables ? 
     250  ! This variable must be .TRUE. once a month 
     251  LOGICAL, SAVE                                :: EndOfMonth=.FALSE. 
    244252  PUBLIC  dt_days, day_counter, date, do_slow, EndOfYear, lcchange 
    245253 
    … …  
    554562 
    555563    REAL(r_std), DIMENSION(kjpindex)                                   :: vartmp 
     564    REAL(r_std)      :: net_cflux_prod_monthly_sum   , net_cflux_prod_monthly_tot 
     565    REAL(r_std)      :: net_harvest_above_monthly_sum, net_harvest_above_monthly_tot 
     566    REAL(r_std)      :: net_biosp_prod_monthly_sum   , net_biosp_prod_monthly_tot 
    556567    !--------------------------------------------------------------------- 
    557568    ! first of all: store time step in common value 
    558569    itime = kjit 
    559570 
    560     z_soil(0) = 0. 
     571    z_soil(0) = zero 
    561572    z_soil(1:nbdl) = diaglev(1:nbdl) 
    562573    DO j=1,nvm 
    … …  
    877888             ENDIF 
    878889 
    879              dt_forcesoil = 0. 
     890             dt_forcesoil = zero 
    880891             nparan = nparan+1 
    881892             DO WHILE (dt_forcesoil < dt_slow/one_day) 
    … …  
    951962       l_first_stomate = .FALSE. 
    952963       ! 
    953        ! 1.11 retu n 
     964       ! 1.11 return 
    954965       ! 
    955966       RETURN 
    … …  
    11581169    ENDDO 
    11591170 
     1171    IF ( day == 1 .AND. sec .LT. dtradia ) THEN 
     1172       EndOfMonth=.TRUE. 
     1173    ELSE 
     1174       EndOfMonth=.FALSE. 
     1175    ENDIF 
    11601176    ! 
    11611177    ! 5 "daily" variables 
    … …  
    12931309 
    12941310          CALL StomateLpj & 
    1295                &            (kjpindex, dt_days, EndOfYear, & 
     1311               &            (kjpindex, dt_days, EndOfYear, EndOfMonth, & 
    12961312               &             neighbours, resolution, & 
    12971313               &             clay, herbivores, & 
    … …  
    13181334               &             t_photo_min, t_photo_opt, t_photo_max,bm_to_litter,& 
    13191335               &             prod10, prod100, flux10, flux100, veget_cov_max_new,& 
    1320                &             convflux, cflux_prod10, cflux_prod100, harvest_above, lcchange) 
     1336               &             convflux, cflux_prod10, cflux_prod100, harvest_above, lcchange,& 
     1337               &             fpc_max) 
    13211338 
    13221339          ! 
    … …  
    15341551       ! 
    15351552       co2_flux_monthly(:,:) = co2_flux_monthly(:,:) + co2_flux_daily(:,:) 
    1536        IF ( day == 1 .AND. sec .LT. dtradia ) THEN 
     1553!      Monthly Cumulative fluxes of fluc and harvest 
     1554       harvest_above_monthly(:) = harvest_above_monthly(:) + harvest_above(:) 
     1555       cflux_prod_monthly(:) = cflux_prod_monthly(:) + convflux(:) + cflux_prod10(:) + cflux_prod100(:) 
     1556       IF ( EndOfMonth ) THEN 
    15371557          IF ( control%ok_stomate ) THEN 
    1538              CALL histwrite (hist_id_stomate, 'CO2FLUX_MONTHLY', itime, & 
     1558             CALL histwrite (hist_id_stomate, 'CO2FLUX', itime, & 
    15391559                  co2_flux_monthly, kjpindex*nvm, horipft_index) 
    15401560          ENDIF 
    15411561!MM 
    15421562! Si on supprimer le cumul par mois,  
    1543 ! il ne faut pas oublié cette modif resolution(:,1)*resolution(:,2)*contfrac(:)  
     1563! il ne faut pas oublier cette modif resolution(:,1)*resolution(:,2)*contfrac(:)  
    15441564          DO j=2, nvm 
    15451565             co2_flux_monthly(:,j) = co2_flux_monthly(:,j)* & 
    … …  
    15511571             DO j=2,nvm 
    15521572                net_co2_flux_monthly = net_co2_flux_monthly + & 
    1553                      &  co2_flux_monthly(ji,j)*veget_max(ji,j) 
     1573                     &  co2_flux_monthly(ji,j)*veget_cov_max(ji,j) 
    15541574             ENDDO 
    15551575          ENDDO 
     1576!         Total ( land) Cumulative fluxes of fluc and harvest 
     1577          net_cflux_prod_monthly_sum=& 
     1578              &  SUM(cflux_prod_monthly(:)*resolution(:,1)*resolution(:,2)*contfrac(:))*1e-15 
     1579          CALL reduce_sum(net_cflux_prod_monthly_sum,net_cflux_prod_monthly_tot) 
     1580          CALL bcast(net_cflux_prod_monthly_tot) 
     1581 
     1582          net_harvest_above_monthly_sum=& 
     1583             &   SUM(harvest_above_monthly(:)*resolution(:,1)*resolution(:,2)*contfrac(:))*1e-15 
     1584          CALL reduce_sum(net_harvest_above_monthly_sum,net_harvest_above_monthly_tot) 
     1585          CALL bcast(net_harvest_above_monthly_tot) 
     1586 
    15561587          net_co2_flux_monthly = net_co2_flux_monthly*1e-15 
    1557           WRITE(numout,*) 'net_co2_flux_monthly (Peta gC/month)  = ',net_co2_flux_monthly 
    1558  
    15591588          CALL reduce_sum(net_co2_flux_monthly,net_co2_flux_monthly_sum) 
    1560           IF ( control%ok_stomate ) THEN 
    1561              CALL histwrite (hist_id_stomate, 'CO2FLUX_MONTHLY_SUM', itime, & 
    1562                   (/ net_co2_flux_monthly /), 1, (/ 1 /) ) 
    1563           ENDIF 
     1589          CALL bcast(net_co2_flux_monthly_sum) 
     1590 
     1591          WRITE(numout,9010) 'GLOBAL net_cflux_prod_monthly    (Peta gC/month)  = ',net_cflux_prod_monthly_tot 
     1592          WRITE(numout,9010) 'GLOBAL net_harvest_above_monthly (Peta gC/month)  = ',net_harvest_above_monthly_tot 
     1593          WRITE(numout,9010) 'GLOBAL net_co2_flux_monthly      (Peta gC/month)  = ',net_co2_flux_monthly_sum 
     1594 
     1595!         Calculation of net biospheric production 
     1596          net_biosp_prod_monthly_tot =  & 
     1597             &    ( net_co2_flux_monthly_sum + net_cflux_prod_monthly_tot + net_harvest_above_monthly_tot ) 
     1598          WRITE(numout,9010) 'GLOBAL net_biosp_prod_monthly    (Peta gC/month)  = ',net_biosp_prod_monthly_tot 
     1599 
     16009010  FORMAT(A52,F17.14) 
     1601!!$          IF ( control%ok_stomate ) THEN 
     1602!!$             vartmp(:)=net_co2_flux_monthly_sum 
     1603!!$             CALL histwrite (hist_id_stomate, 'CO2FLUX_MONTHLY_SUM', itime, & 
     1604!!$                  vartmp, kjpindex, hori_index ) 
     1605!!$          ENDIF 
    15641606!!$          IF (is_root_prc) THEN 
    15651607!!$             OPEN( unit=39,              & 
    … …  
    15791621!!$          ENDIF 
    15801622          co2_flux_monthly(:,:) = zero 
     1623          harvest_above_monthly(:) = zero 
     1624          cflux_prod_monthly(:)    = zero 
    15811625       ENDIF 
    15821626       ! 
    … …  
    15991643 
    16001644    ENDIF  ! daily processes? 
    1601     ! CO2FLUX Daily values are saved each dtradia, 
    1602     ! then the value is wrong for the first day without restart. 
    1603     IF ( hist_id > 0 ) THEN 
    1604        CALL histwrite (hist_id, 'CO2FLUX', itime, & 
    1605             co2_flux_daily, kjpindex*nvm, horipft_index) 
    1606     ENDIF 
    1607     IF ( hist2_id > 0 ) THEN 
    1608        CALL histwrite (hist2_id, 'CO2FLUX', itime, & 
    1609             co2_flux_daily, kjpindex*nvm, horipft_index) 
    1610     ENDIF 
    1611  
    16121645    ! 
    16131646    ! 7 Outputs from Stomate 
    … …  
    19071940    ALLOCATE(co2_flux_monthly(kjpindex,nvm),stat=ier) 
    19081941    l_error = l_error .OR. (ier /= 0) 
     1942    ALLOCATE (cflux_prod_monthly(kjpindex), stat=ier) 
     1943    l_error = l_error .OR. (ier.NE.0) 
     1944    ALLOCATE (harvest_above_monthly(kjpindex), stat=ier) 
     1945    l_error = l_error .OR. (ier.NE.0) 
    19091946    ALLOCATE(bm_to_litter(kjpindex,nvm,nparts),stat=ier) 
    19101947    l_error = l_error .OR. (ier /= 0) 
    … …  
    19551992    l_error = l_error .OR. (ier.NE.0) 
    19561993    ! 
     1994    ALLOCATE (fpc_max(kjpindex,nvm), stat=ier) 
     1995    l_error = l_error .OR. (ier.NE.0) 
     1996    ! 
    19571997    IF (l_error) THEN 
    19581998       STOP 'stomate_init: error in memory allocation' 
    … …  
    20282068    WRITE(numout,*) & 
    20292069         &  'expansion across a grid cell is treated: ',treat_expansion 
     2070 
     2071    !Config Key  = LPJ_GAP_CONST_MORT 
     2072    !Config Desc = prescribe mortality if not using DGVM? 
     2073    !Config Def  = y 
     2074    !Config Help = set to TRUE if constant mortality is to be activated 
     2075    !              ignored if DGVM=true! 
     2076    ! 
     2077    lpj_gap_const_mort=.TRUE. 
     2078    CALL getin('LPJ_GAP_CONST_MORT', lpj_gap_const_mort) 
     2079    WRITE(numout,*) 'LPJ GAP: constant mortality:', lpj_gap_const_mort 
    20302080 
    20312081    !Config  Key  = HARVEST_AGRI 
    … …  
    20462096    co2_flux_daily(:,:) = zero 
    20472097    co2_flux_monthly(:,:) = zero 
    2048  
     2098    cflux_prod_monthly(:) = zero 
     2099    harvest_above_monthly(:) = zero 
     2100    control_moist_daily(:,:) = zero 
     2101    control_temp_daily(:,:) = zero 
     2102    soilcarbon_input_daily(:,:,:) = zero 
    20492103 
    20502104    ! initialisation of land cover change variables 
    … …  
    20562110    cflux_prod10(:) = zero 
    20572111    cflux_prod100(:)= zero 
     2112 
     2113    fpc_max(:,:)=zero 
    20582114    !-------------------------- 
    20592115  END SUBROUTINE stomate_init 
    … …  
    21412197    IF (ALLOCATED(co2_flux_daily)) DEALLOCATE(co2_flux_daily) 
    21422198    IF (ALLOCATED(co2_flux_monthly)) DEALLOCATE(co2_flux_monthly) 
     2199    IF (ALLOCATED(harvest_above_monthly)) DEALLOCATE (harvest_above_monthly) 
     2200    IF (ALLOCATED(cflux_prod_monthly)) DEALLOCATE (cflux_prod_monthly) 
    21432201    IF (ALLOCATED(bm_to_litter)) DEALLOCATE(bm_to_litter) 
    21442202    IF (ALLOCATED(bm_to_littercalc)) DEALLOCATE(bm_to_littercalc) 
    … …  
    22032261    IF ( ALLOCATED (control_temp_daily)) DEALLOCATE (control_temp_daily) 
    22042262    IF ( ALLOCATED (control_moist_daily)) DEALLOCATE (control_moist_daily) 
     2263 
     2264    IF ( ALLOCATED (fpc_max)) DEALLOCATE (fpc_max) 
    22052265 
    22062266    ! 2. reset l_first 
    … …  
    22652325    !- 
    22662326    ! dummy time step, must be zero 
    2267     REAL(r_std),PARAMETER                        :: dt_0 = 0. 
     2327    REAL(r_std),PARAMETER                        :: dt_0 = zero 
    22682328    REAL(r_std),DIMENSION(kjpindex,nvm)          :: vcmax 
    22692329    REAL(r_std),DIMENSION(kjpindex,nvm)          :: vjmax 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_alloc.f90

    r64 r257  
    162162       ! 1.1.1 soil levels 
    163163 
    164        z_soil(0) = 0. 
     164       z_soil(0) = zero 
    165165       z_soil(1:nbdl) = diaglev(1:nbdl) 
    166166 
    … …  
    202202    ! 
    203203 
    204     f_alloc(:,:,:) = 0.0 
    205     f_alloc(:,:,icarbres) = 1.0 
     204    f_alloc(:,:,:) = zero 
     205    f_alloc(:,:,icarbres) = un 
    206206    ! 
    207207    ! 1.3 Convolution of the temperature and humidity profiles with some kind of profile 
    … …  
    212212 
    213213    ! 1.3.1.1 rpc is an integration constant such that the integral of the root profile is 1. 
    214     rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_nitrogen ) ) 
     214    rpc(:) = un / ( un - EXP( -z_soil(nbdl) / z_nitrogen ) ) 
    215215 
    216216    ! 1.3.1.2 integrate over the nbdl levels 
    … …  
    229229 
    230230    ! 1.3.2.1 rpc is an integration constant such that the integral of the root profile is 1. 
    231     rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_nitrogen ) ) 
     231    rpc(:) = un / ( un - EXP( -z_soil(nbdl) / z_nitrogen ) ) 
    232232 
    233233    ! 1.3.2.2 integrate over the nbdl levels 
    234234 
    235     h_nitrogen(:) = 0.0 
     235    h_nitrogen(:) = zero 
    236236 
    237237    DO l = 1, nbdl 
    … …  
    251251    ! mean LAI on natural part 
    252252 
    253     natveg_tot(:) = 0.0 
    254     lai_nat(:) = 0.0 
     253    natveg_tot(:) = zero 
     254    lai_nat(:) = zero 
    255255 
    256256    DO j = 2, nvm 
    … …  
    259259          veget_max_nat(:,j) = veget_max(:,j) 
    260260       ELSE 
    261           veget_max_nat(:,j) = 0.0 
     261          veget_max_nat(:,j) = zero 
    262262       ENDIF 
    263263 
    … …  
    314314       !             3/ must be at the beginning of the growing season 
    315315 
    316        WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. &  
     316       WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. &  
    317317            ( .NOT. senescence(:,j) ) .AND. & 
    318318            ( lai(:,j) .LT. lai_happy(j) ) .AND. & 
    … …  
    337337       ELSEWHERE 
    338338 
    339           transloc_leaf(:) = 0.0 
     339          transloc_leaf(:) = zero 
    340340 
    341341       ENDWHERE 
    … …  
    468468          ! leaf allocation 
    469469 
    470           LtoLSR(:) = 1. - RtoLSR(:) - StoLSR(:) 
     470          LtoLSR(:) = un - RtoLSR(:) - StoLSR(:) 
    471471          LtoLSR(:) = MAX( min_LtoLSR, MIN( max_LtoLSR, LtoLSR(:) ) ) 
    472472 
    473473          ! roots: the rest 
    474474 
    475           RtoLSR(:) = 1. - LtoLSR(:) - StoLSR(:) 
     475          RtoLSR(:) = un - LtoLSR(:) - StoLSR(:) 
    476476 
    477477       ENDWHERE 
    … …  
    483483          StoLSR(:) = StoLSR(:) + LtoLSR(:) 
    484484 
    485           LtoLSR(:) = 0.0 
     485          LtoLSR(:) = zero 
    486486 
    487487       ENDWHERE 
    … …  
    514514 
    515515                IF ( ( biomass(i,j,icarbres)*sla(j) ) .LT. 2*lai_max(j) ) THEN 
    516                    carb_rescale(i) = 1. / ( 1. + ecureuil(j) * ( LtoLSR(i) + RtoLSR(i) ) ) 
     516                   carb_rescale(i) = un / ( un + ecureuil(j) * ( LtoLSR(i) + RtoLSR(i) ) ) 
    517517                ELSE 
    518                    carb_rescale(i) = 1. 
     518                   carb_rescale(i) = un 
    519519                ENDIF 
    520520 
    … …  
    522522 
    523523                f_alloc(i,j,isapabove) = StoLSR(i) * alloc_sap_above(i) * & 
    524                      ( 1. - f_alloc(i,j,ifruit) ) * carb_rescale(i) 
    525                 f_alloc(i,j,isapbelow) = StoLSR(i) * ( 1. - alloc_sap_above(i) ) * & 
    526                      ( 1. - f_alloc(i,j,ifruit) ) * carb_rescale(i) 
     524                     ( un - f_alloc(i,j,ifruit) ) * carb_rescale(i) 
     525                f_alloc(i,j,isapbelow) = StoLSR(i) * ( un - alloc_sap_above(i) ) * & 
     526                     ( un - f_alloc(i,j,ifruit) ) * carb_rescale(i) 
    527527 
    528528                f_alloc(i,j,iroot) = RtoLSR(i) * ( 1.-f_alloc(i,j,ifruit) ) * carb_rescale(i) 
    … …  
    530530                ! this is equivalent to: 
    531531                ! reserve alloc = ecureuil*(LtoLSR+StoLSR)*(1-fruit_alloc)*carb_rescale 
    532                 f_alloc(i,j,icarbres) = ( 1. - carb_rescale(i) ) * ( 1.-f_alloc(i,j,ifruit) ) 
     532                f_alloc(i,j,icarbres) = ( un - carb_rescale(i) ) * ( 1.-f_alloc(i,j,ifruit) ) 
    533533 
    534534             ENDIF  ! senescent? 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_data.f90

    r252 r257  
    156156       ! Oct 2010 : replaced by values given by N.Viovy 
    157157 
    158        IF ( bavard .GE. 1 ) WRITE(numout,*) '       specific leaf area (m**2/gC):', sla(j) !, 12./leaflife(j) 
     158       ! includes conversion from  
     159       !!       sla(j) = 2. * 1e-4 * EXP(5.615 - 0.46 * log(12./leaflife_tab(j))) 
     160 
     161       IF ( leaf_tab(j) .EQ. 2 ) THEN 
     162 
     163          ! needle leaved tree 
     164          sla(j) = 2. * ( 10. ** ( 2.29 - 0.4 * LOG10(12./leaflife_tab(j)) ) ) *1e-4 
     165 
     166       ELSE 
     167 
     168          ! broad leaved tree or grass (Reich et al 1992) 
     169          sla(j) = 2. * ( 10. ** ( 2.41 - 0.38 * LOG10(12./leaflife_tab(j)) ) ) *1e-4 
     170 
     171       ENDIF 
     172 
     173!!$      IF ( leaf_tab(j) .EQ. 1 ) THEN 
     174!!$ 
     175!!$        ! broad leaved tree 
     176!!$ 
     177!!$        sla(j) = 2. * ( 10. ** ( 2.41 - 0.38 * LOG10(12./leaflife_tab(j)) ) ) *1e-4 
     178!!$ 
     179!!$      ELSE 
     180!!$ 
     181!!$        ! needle leaved or grass (Reich et al 1992) 
     182!!$ 
     183!!$        sla(j) = 2. * ( 10. ** ( 2.29 - 0.4 * LOG10(12./leaflife_tab(j)) ) ) *1e-4 
     184!!$ 
     185!!$      ENDIF 
     186!!$ 
     187!!$      IF ( ( leaf_tab(j) .EQ. 2 ) .AND. ( pheno_type_tab(j) .EQ. 2 ) ) THEN 
     188!!$ 
     189!!$        ! summergreen needle leaf 
     190!!$ 
     191!!$        sla(j) = 1.25 * sla(j) 
     192!!$ 
     193!!$      ENDIF 
     194 
     195       IF ( bavard .GE. 1 ) WRITE(numout,*) '       specific leaf area (m**2/gC):', sla(j), 12./leaflife_tab(j) 
    159196 
    160197       ! 
    … …  
    175212             bm_sapl(j,icarbres) = bm_sapl_carbres * bm_sapl(j,ileaf) 
    176213          ELSE 
    177              bm_sapl(j,icarbres) = 0.0 
     214             bm_sapl(j,icarbres) = zero 
    178215          ENDIF 
    179216 
    … …  
    203240          bm_sapl(j,icarbres) = init_sapl_mass_carbres *bm_sapl(j,ileaf) 
    204241 
    205           bm_sapl(j,isapabove) = 0. 
    206           bm_sapl(j,isapbelow) = 0. 
    207  
    208           bm_sapl(j,iheartabove) = 0. 
    209           bm_sapl(j,iheartbelow) = 0. 
     242          bm_sapl(j,isapabove) = zero 
     243          bm_sapl(j,isapbelow) = zero 
     244 
     245          bm_sapl(j,iheartabove) = zero 
     246          bm_sapl(j,iheartbelow) = zero 
    210247 
    211248       ENDIF 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_io.f90

    r64 r257  
    17301730    REAL(r_std),DIMENSION(nbvmax) :: area 
    17311731    REAL(r_std),DIMENSION(nbvmax) :: tt 
    1732  
    17331732    REAL(r_std) :: resx, resy 
    17341733    LOGICAL :: do_again 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_lcchange.f90

    r64 r257  
    139139 
    140140    ! Turnover rates (gC/(m**2 of ground)/day) 
    141     REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(out)               :: turnover_daily 
     141    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)               :: turnover_daily 
    142142 
    143143    ! 0.4 local 
    … …  
    207207                   cn_ind(i,j) = cn_sapl(j) 
    208208                ELSE 
    209                    cn_ind(i,j)=1.0 
     209                   cn_ind(i,j) = un 
    210210                ENDIF 
    211211                ind(i,j)= delta_veg(j) / cn_ind(i,j) 
    212212                PFTpresent(i,j) = .TRUE. 
    213                 everywhere(i,j) = 1. 
     213                everywhere(i,j) = un 
    214214                senescence(i,j) = .FALSE. 
    215215                age(i,j) = 0. 
    216216 
    217217                when_growthinit(i,j) = large_value 
    218                 leaf_frac(i,j,1) = 1.0 
     218                leaf_frac(i,j,1) = un 
    219219                npp_longterm(i,j) = 10. 
    220220                lm_lastyearmax(i,j) = bm_sapl(j,ileaf) * ind(i,j) 
    … …  
    321321       flux100(i,1)      = 0.01 * prod100(i,0) 
    322322       prod100(i,1)      = prod100(i,0) 
    323 !MM=>          IF (prod100(i,1).LT.1.0) prod100(i,1) = 0.0 
     323!MM=>          IF (prod100(i,1).LT.1.0) prod100(i,1) = zero 
    324324!MM=>stomate_lpj.f90       prod100_total(i)  = prod100_total(i) + prod100(i,1) 
    325        prod10(i,0)        = 0.0 
    326        prod100(i,0)       = 0.0  
     325       prod10(i,0)        = zero 
     326       prod100(i,0)       = zero 
    327327 
    328328    ENDDO  ! End loop on npts 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_litter.f90

    r64 r257  
    185185       ! 
    186186 
    187        z_soil(0) = 0. 
     187       z_soil(0) = zero 
    188188       z_soil(1:nbdl) = diaglev(1:nbdl) 
    189189 
    … …  
    441441 
    442442    ! 4.2.1 rpc is an integration constant such that the integral of the root profile is 1. 
    443     rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_decomp ) ) 
     443    rpc(:) = un / ( un - EXP( -z_soil(nbdl) / z_decomp ) ) 
    444444 
    445445    ! 4.2.2 integrate over the nbdl levels 
    … …  
    473473 
    474474    ! 5.2.1 rpc is an integration constant such that the integral of the root profile is 1. 
    475     rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_decomp ) ) 
     475    rpc(:) = un / ( un - EXP( -z_soil(nbdl) / z_decomp ) ) 
    476476 
    477477    ! 5.2.2 integrate over the nbdl levels 
    … …  
    514514          ! to avoid a multiple (for ibelow and iabove) modification of dead_leaves, 
    515515          ! we do this test to do this calcul only ones in 1,nlev loop 
    516           if (l == iabove)  dead_leaves(:,m,istructural) = dead_leaves(:,m,istructural) * ( 1. - fd(:) ) 
     516          if (l == iabove)  dead_leaves(:,m,istructural) = dead_leaves(:,m,istructural) * ( un - fd(:) ) 
    517517 
    518518          ! 6.1.3 non-lignin fraction of structural litter goes into 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_lpj.f90

    r136 r257  
    3939  USE stomate_assimtemp 
    4040  USE stomate_lcchange 
    41  
    4241  !  USE Write_Field_p 
    4342 
    … …  
    7069  END SUBROUTINE StomateLpj_clear 
    7170 
    72   SUBROUTINE StomateLpj (npts, dt_days, EndOfYear, & 
     71  SUBROUTINE StomateLpj (npts, dt_days, EndOfYear, EndOfMonth, & 
    7372       neighbours, resolution, & 
    7473       clay, herbivores, & 
    … …  
    9493       t_photo_min, t_photo_opt, t_photo_max,bm_to_litter, & 
    9594       prod10,prod100,flux10, flux100, veget_max_new, & 
    96        convflux,cflux_prod10,cflux_prod100, harvest_above, lcchange) 
     95       convflux,cflux_prod10,cflux_prod100, harvest_above, lcchange, & 
     96       fpc_max) 
    9797 
    9898    ! 
    … …  
    168168    ! maintenance respiration of different plant parts (gC/day/m**2 of ground) 
    169169    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)             :: resp_maint_part 
     170    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground  
     171    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: fpc_max 
    170172 
    171173    ! 0.2 modified fields 
    … …  
    264266    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: height 
    265267    ! fraction of soil covered by dead leaves 
    266     REAL(r_std), DIMENSION(npts), INTENT(out)                      :: deadleaf_cover 
     268    REAL(r_std), DIMENSION(npts), INTENT(inout)                      :: deadleaf_cover 
    267269    ! Maximum rate of carboxylation 
    268270    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: vcmax 
    … …  
    301303    ! Do update of yearly variables? This variable must be .TRUE. once a year 
    302304    LOGICAL, INTENT(in)                                                :: EndOfYear 
    303  
     305    ! Do update of monthly variables ? This variable must be .TRUE. once a month 
     306    LOGICAL, INTENT(in)                                                :: EndOfMonth 
    304307 
    305308    ! 0.4 local 
    … …  
    321324    ! crown area of individuals (m**2) 
    322325    REAL(r_std), DIMENSION(npts,nvm)                               :: cn_ind 
     326    ! woodmass of individuals (gC) 
     327    REAL(r_std), DIMENSION(npts,nvm)                               :: woodmass_ind 
    323328    ! fraction that goes into plant part 
    324329    REAL(r_std), DIMENSION(npts,nvm,nparts)                        :: f_alloc 
    … …  
    337342    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground 
    338343    REAL(r_std),DIMENSION(npts,nvm)                                :: veget_max_old 
     344 
     345    ! fraction of individual dying this time step 
     346    REAL(r_std), DIMENSION(npts,nvm)                               :: mortality 
    339347 
    340348    REAL(r_std), DIMENSION(npts)                                   :: vartmp 
    … …  
    367375    bm_to_litter(:,:,:) = zero 
    368376    cn_ind(:,:) = zero 
     377    woodmass_ind(:,:) = zero 
    369378    veget_max_old(:,:) = veget_max(:,:) 
    370379 
    371     ! 
    372     ! 1.3 Prescribe some vegetation characteristics if the vegetation is not dynamic 
     380    ! 1.3 Calculate some vegetation characteristics 
     381 
     382    ! 
     383    ! 1.3.1 Calculate some vegetation characteristics (cn_ind and height) from 
     384    !     state variables if running DGVM or dynamic mortality in static cover mode 
     385    ! 
     386    IF ( control%ok_dgvm .OR. .NOT.lpj_gap_const_mort) THEN 
     387       IF(control%ok_dgvm) THEN 
     388          WHERE (ind(:,:).GT.min_stomate) 
     389             woodmass_ind(:,:) = & 
     390                  ((biomass(:,:,isapabove)+biomass(:,:,isapbelow) & 
     391                  +biomass(:,:,iheartabove)+biomass(:,:,iheartbelow)) &  
     392                  *veget_max(:,:))/ind(:,:) 
     393          ENDWHERE 
     394       ELSE 
     395          WHERE (ind(:,:).GT.min_stomate) 
     396             woodmass_ind(:,:) = & 
     397                  (biomass(:,:,isapabove)+biomass(:,:,isapbelow) & 
     398                  +biomass(:,:,iheartabove)+biomass(:,:,iheartbelow))/ind(:,:) 
     399          ENDWHERE 
     400       ENDIF 
     401 
     402       CALL crown (npts,  PFTpresent, & 
     403            ind, biomass, woodmass_ind, & 
     404            veget_max, cn_ind, height) 
     405    ENDIF 
     406 
     407    ! 
     408    ! 1.3.2 Prescribe some vegetation characteristics if the vegetation is not dynamic 
    373409    !     IF the DGVM is not activated, the density of individuals and their crown 
    374410    !     areas don't matter, but they should be defined for the case we switch on 
    … …  
    389425 
    390426    CALL constraints (npts, dt_days, & 
    391          t2m_month, t2m_min_daily, when_growthinit, & 
     427         t2m_month, t2m_min_daily,when_growthinit, & 
    392428         adapted, regenerate) 
    393429 
    … …  
    404440       CALL pftinout (npts, dt_days, adapted, regenerate, & 
    405441            neighbours, veget, veget_max, & 
    406             biomass, ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, & 
     442            biomass, ind, cn_ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, & 
    407443            PFTpresent, everywhere, when_growthinit, need_adjacent, RIP_time, & 
    408444            co2_to_bm, & 
    … …  
    417453       CALL kill (npts, 'pftinout  ', lm_lastyearmax, & 
    418454            ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, & 
    419             lai, age, leaf_age, leaf_frac, & 
     455            lai, age, leaf_age, leaf_frac, npp_longterm, & 
    420456            when_growthinit, everywhere, veget, veget_max, bm_to_litter) 
    421457 
    … …  
    423459       ! 3.3 calculate new crown area and maximum vegetation cover 
    424460       ! 
     461       ! 
     462       ! unsure whether this is really required 
     463       ! - in theory this could ONLY be done at the END of stomate_lpj 
     464       ! 
     465 
     466       ! calculate woodmass of individual tree 
     467       WHERE ((ind(:,:).GT.min_stomate)) 
     468          WHERE  ( veget_max(:,:) .GT. min_stomate) 
     469             woodmass_ind(:,:) = & 
     470                  ((biomass(:,:,isapabove)+biomass(:,:,isapbelow) & 
     471                  +biomass(:,:,iheartabove)+biomass(:,:,iheartbelow))*veget_max(:,:))/ind(:,:) 
     472          ELSEWHERE 
     473             woodmass_ind(:,:) =(biomass(:,:,isapabove)+biomass(:,:,isapbelow) & 
     474                  +biomass(:,:,iheartabove)+biomass(:,:,iheartbelow))/ind(:,:) 
     475          ENDWHERE 
     476 
     477       ENDWHERE 
    425478 
    426479       CALL crown (npts, PFTpresent, & 
    427             ind, biomass, & 
     480            ind, biomass, woodmass_ind, & 
    428481            veget_max, cn_ind, height) 
    429482 
    … …  
    487540         resp_maint, resp_growth, npp_daily) 
    488541 
    489     IF ( control%ok_dgvm ) THEN 
     542    IF ( control%ok_dgvm .OR. .NOT.lpj_gap_const_mort) THEN 
     543       CALL kill (npts, 'npp       ', lm_lastyearmax,  & 
     544            ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, & 
     545            lai, age, leaf_age, leaf_frac, npp_longterm, & 
     546            when_growthinit, everywhere, veget, veget_max, bm_to_litter) 
    490547 
    491548       ! new provisional crown area and maximum vegetation cover after growth 
     549       IF(control%ok_dgvm) THEN 
     550          WHERE (ind(:,:).GT.min_stomate) 
     551             woodmass_ind(:,:) = & 
     552                  ((biomass(:,:,isapabove)+biomass(:,:,isapbelow) & 
     553                  +biomass(:,:,iheartabove)+biomass(:,:,iheartbelow)) &  
     554                  *veget_max(:,:))/ind(:,:) 
     555          ENDWHERE 
     556       ELSE 
     557          WHERE (ind(:,:).GT.min_stomate) 
     558             woodmass_ind(:,:) = & 
     559                  (biomass(:,:,isapabove)+biomass(:,:,isapbelow) & 
     560                  +biomass(:,:,iheartabove)+biomass(:,:,iheartbelow))/ind(:,:) 
     561          ENDWHERE 
     562       ENDIF 
    492563 
    493564       CALL crown (npts, PFTpresent, & 
    494             ind, biomass, & 
     565            ind, biomass, woodmass_ind,& 
    495566            veget_max, cn_ind, height) 
    496567 
    … …  
    513584       CALL kill (npts, 'fire      ', lm_lastyearmax, & 
    514585            ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, & 
    515             lai, age, leaf_age, leaf_frac, & 
     586            lai, age, leaf_age, leaf_frac, npp_longterm, & 
    516587            when_growthinit, everywhere, veget, veget_max, bm_to_litter) 
    517588 
    … …  
    524595    CALL gap (npts, dt_days, & 
    525596         npp_longterm, turnover_longterm, lm_lastyearmax, & 
    526          PFTpresent, biomass, ind, bm_to_litter) 
     597         PFTpresent, biomass, ind, bm_to_litter, mortality) 
    527598 
    528599    IF ( control%ok_dgvm ) THEN 
    … …  
    532603       CALL kill (npts, 'gap       ', lm_lastyearmax, & 
    533604            ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, & 
    534             lai, age, leaf_age, leaf_frac, & 
     605            lai, age, leaf_age, leaf_frac, npp_longterm, & 
    535606            when_growthinit, everywhere, veget, veget_max, bm_to_litter) 
    536607 
    … …  
    570641 
    571642       CALL light (npts, dt_days, & 
    572             PFTpresent, cn_ind, lai, maxfpc_lastyear, & 
    573             ind, biomass, veget_lastlight, bm_to_litter) 
     643            veget_max, fpc_max, PFTpresent, cn_ind, lai, maxfpc_lastyear, & 
     644            lm_lastyearmax, ind, biomass, veget_lastlight, bm_to_litter, mortality) 
    574645 
    575646       ! 
    … …  
    579650       CALL kill (npts, 'light     ', lm_lastyearmax, & 
    580651            ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, & 
    581             lai, age, leaf_age, leaf_frac, & 
     652            lai, age, leaf_age, leaf_frac, npp_longterm, & 
    582653            when_growthinit, everywhere, veget, veget_max, bm_to_litter) 
    583654 
    … …  
    588659    ! 
    589660 
    590     IF ( control%ok_dgvm ) THEN 
     661    IF ( control%ok_dgvm .OR. .NOT.lpj_gap_const_mort ) THEN 
    591662 
    592663       ! 
    … …  
    597668            neighbours, resolution, need_adjacent, herbivores, & 
    598669            precip_lastyear, gdd0_lastyear, lm_lastyearmax, & 
    599             cn_ind, lai, avail_tree, avail_grass, & 
     670            cn_ind, lai, avail_tree, avail_grass, npp_longterm, & 
    600671            leaf_age, leaf_frac, & 
    601             ind, biomass, age, everywhere, co2_to_bm, veget_max) 
     672            ind, biomass, age, everywhere, co2_to_bm, veget_max, woodmass_ind) 
    602673 
    603674       ! 
    … …  
    606677 
    607678       CALL crown (npts, PFTpresent, & 
    608             ind, biomass, & 
     679            ind, biomass, woodmass_ind, & 
    609680            veget_max, cn_ind, height) 
    610681 
    … …  
    617688    CALL cover (npts, cn_ind, ind, biomass, & 
    618689         veget_max, veget_max_old, veget, & 
    619          lai, litter, carbon) 
     690         lai, litter, carbon, turnover_daily, bm_to_litter) 
    620691 
    621692    ! 
    … …  
    645716               prod10,prod100,convflux,cflux_prod10,cflux_prod100,leaf_frac,& 
    646717               npp_longterm, lm_lastyearmax, litter, carbon) 
    647  
    648718       ENDIF 
    649719    ENDIF 
    650 !MM déplacement pour initialisation correcte des grandeurs cumulées : 
     720    !MM déplacement pour initialisation correcte des grandeurs cumulées : 
    651721    cflux_prod_total(:) = convflux(:) + cflux_prod10(:) + cflux_prod100(:) 
    652722    prod10_total(:)=SUM(prod10,dim=2) 
    … …  
    736806    CALL histwrite (hist_id_stomate, 'CO2_TAKEN', itime, & 
    737807         co2_to_bm, npts*nvm, horipft_index) 
     808!MM : histdef à construire !  
     809!!$   CALL histwrite (hist_id_stomate, 'CN_IND', itime, & 
     810!!$                    cn_ind, npts*nvm, horipft_index) 
     811!!$   CALL histwrite (hist_id_stomate, 'WOODMASS_IND', itime, & 
     812!!$                    woodmass_ind, npts*nvm, horipft_index) 
    738813    ! land cover change 
    739814    CALL histwrite (hist_id_stomate, 'CONVFLUX', itime, & 
    … …  
    833908       vartmp(:)=SUM(tot_live_biomass*veget_max,dim=2)/1e3*contfrac 
    834909       CALL histwrite (hist_id_stomate_IPCC, "cVeg", itime, & 
    835          vartmp, npts, hori_index) 
     910            vartmp, npts, hori_index) 
    836911       vartmp(:)=SUM(tot_litter_carb*veget_max,dim=2)/1e3*contfrac 
    837912       CALL histwrite (hist_id_stomate_IPCC, "cLitter", itime, & 
    838          vartmp, npts, hori_index) 
     913            vartmp, npts, hori_index) 
    839914       vartmp(:)=SUM(tot_soil_carb*veget_max,dim=2)/1e3*contfrac 
    840915       CALL histwrite (hist_id_stomate_IPCC, "cSoil", itime, & 
    841          vartmp, npts, hori_index) 
     916            vartmp, npts, hori_index) 
    842917       vartmp(:)=(prod10_total + prod100_total)/1e3 
    843918       CALL histwrite (hist_id_stomate_IPCC, "cProduct", itime, & 
    844          vartmp, npts, hori_index) 
     919            vartmp, npts, hori_index) 
    845920       vartmp(:)=SUM(lai*veget_max,dim=2)*contfrac 
    846921       CALL histwrite (hist_id_stomate_IPCC, "lai", itime, & 
    847          vartmp, npts, hori_index) 
     922            vartmp, npts, hori_index) 
    848923       vartmp(:)=SUM(gpp_daily*veget_max,dim=2)/1e3/one_day*contfrac 
    849924       CALL histwrite (hist_id_stomate_IPCC, "gpp", itime, & 
    850          vartmp, npts, hori_index) 
     925            vartmp, npts, hori_index) 
    851926       vartmp(:)=SUM((resp_maint+resp_growth)*veget_max,dim=2)/1e3/one_day*contfrac 
    852927       CALL histwrite (hist_id_stomate_IPCC, "ra", itime, & 
    853          vartmp, npts, hori_index) 
     928            vartmp, npts, hori_index) 
    854929       vartmp(:)=SUM(npp_daily*veget_max,dim=2)/1e3/one_day*contfrac 
    855930       CALL histwrite (hist_id_stomate_IPCC, "npp", itime, & 
    856          vartmp, npts, hori_index) 
     931            vartmp, npts, hori_index) 
    857932       vartmp(:)=SUM(resp_hetero*veget_max,dim=2)/1e3/one_day*contfrac 
    858933       CALL histwrite (hist_id_stomate_IPCC, "rh", itime, & 
    859          vartmp, npts, hori_index) 
     934            vartmp, npts, hori_index) 
    860935       vartmp(:)=SUM(co2_fire*veget_max,dim=2)/1e3/one_day*contfrac 
    861936       CALL histwrite (hist_id_stomate_IPCC, "fFire", itime, & 
    862          vartmp, npts, hori_index) 
     937            vartmp, npts, hori_index) 
    863938       vartmp(:)=harvest_above/1e3/one_day*contfrac 
    864939       CALL histwrite (hist_id_stomate_IPCC, "fHarvest", itime, & 
    865          vartmp, npts, hori_index) 
     940            vartmp, npts, hori_index) 
    866941       vartmp(:)=cflux_prod_total/1e3/one_day*contfrac 
    867942       CALL histwrite (hist_id_stomate_IPCC, "fLuc", itime, & 
    868          vartmp, npts, hori_index) 
     943            vartmp, npts, hori_index) 
    869944       vartmp(:)=(SUM((gpp_daily-(resp_maint+resp_growth+resp_hetero)-co2_fire) & 
    870945            &        *veget_max,dim=2)-cflux_prod_total-harvest_above)/1e3/one_day*contfrac 
    871946       CALL histwrite (hist_id_stomate_IPCC, "nbp", itime, & 
    872          vartmp, npts, hori_index) 
     947            vartmp, npts, hori_index) 
    873948       vartmp(:)=SUM(tot_bm_to_litter*veget_max,dim=2)/1e3/one_day*contfrac 
    874949       CALL histwrite (hist_id_stomate_IPCC, "fVegLitter", itime, & 
    875          vartmp, npts, hori_index) 
     950            vartmp, npts, hori_index) 
    876951       vartmp(:)=SUM(SUM(soilcarbon_input,dim=2)*veget_max,dim=2)/1e3/one_day*contfrac 
    877952       CALL histwrite (hist_id_stomate_IPCC, "fLitterSoil", itime, & 
    878          vartmp, npts, hori_index) 
     953            vartmp, npts, hori_index) 
    879954       vartmp(:)=SUM(biomass(:,:,ileaf)*veget_max,dim=2)/1e3*contfrac 
    880955       CALL histwrite (hist_id_stomate_IPCC, "cLeaf", itime, & 
    881          vartmp, npts, hori_index) 
     956            vartmp, npts, hori_index) 
    882957       vartmp(:)=SUM((biomass(:,:,isapabove)+biomass(:,:,iheartabove))*veget_max,dim=2)/1e3*contfrac 
    883958       CALL histwrite (hist_id_stomate_IPCC, "cWood", itime, & 
    884          vartmp, npts, hori_index) 
     959            vartmp, npts, hori_index) 
    885960       vartmp(:)=SUM(( biomass(:,:,iroot) + biomass(:,:,isapbelow) + biomass(:,:,iheartbelow) ) & 
    886961            &        *veget_max,dim=2)/1e3*contfrac 
    887962       CALL histwrite (hist_id_stomate_IPCC, "cRoot", itime, & 
    888          vartmp, npts, hori_index) 
     963            vartmp, npts, hori_index) 
    889964       vartmp(:)=SUM(( biomass(:,:,icarbres) + biomass(:,:,ifruit))*veget_max,dim=2)/1e3*contfrac 
    890965       CALL histwrite (hist_id_stomate_IPCC, "cMisc", itime, & 
    891          vartmp, npts, hori_index) 
     966            vartmp, npts, hori_index) 
    892967       vartmp(:)=SUM((litter(:,istructural,:,iabove)+litter(:,imetabolic,:,iabove))*veget_max,dim=2)/1e3*contfrac 
    893968       CALL histwrite (hist_id_stomate_IPCC, "cLitterAbove", itime, & 
    894          vartmp, npts, hori_index) 
     969            vartmp, npts, hori_index) 
    895970       vartmp(:)=SUM((litter(:,istructural,:,ibelow)+litter(:,imetabolic,:,ibelow))*veget_max,dim=2)/1e3*contfrac 
    896971       CALL histwrite (hist_id_stomate_IPCC, "cLitterBelow", itime, & 
    897          vartmp, npts, hori_index) 
     972            vartmp, npts, hori_index) 
    898973       vartmp(:)=SUM(carbon(:,iactive,:)*veget_max,dim=2)/1e3*contfrac 
    899974       CALL histwrite (hist_id_stomate_IPCC, "cSoilFast", itime, & 
    900          vartmp, npts, hori_index) 
     975            vartmp, npts, hori_index) 
    901976       vartmp(:)=SUM(carbon(:,islow,:)*veget_max,dim=2)/1e3*contfrac 
    902977       CALL histwrite (hist_id_stomate_IPCC, "cSoilMedium", itime, & 
    903          vartmp, npts, hori_index) 
     978            vartmp, npts, hori_index) 
    904979       vartmp(:)=SUM(carbon(:,ipassive,:)*veget_max,dim=2)/1e3*contfrac 
    905980       CALL histwrite (hist_id_stomate_IPCC, "cSoilSlow", itime, & 
    906          vartmp, npts, hori_index) 
     981            vartmp, npts, hori_index) 
    907982       DO j=1,nvm 
    908983          histvar(:,j)=veget_max(:,j)*contfrac(:)*100 
    909984       ENDDO 
    910985       CALL histwrite (hist_id_stomate_IPCC, "landCoverFrac", itime, & 
    911          histvar, npts*nvm, horipft_index) 
    912        vartmp(:)=(veget_max(:,3)+veget_max(:,6)+veget_max(:,8)+veget_max(:,9))*contfrac*100 
     986            histvar, npts*nvm, horipft_index) 
     987 
     988       ! >> DS to be modified for the externalisation 
     989!       vartmp(:)=(veget_max(:,3)+veget_max(:,6)+veget_max(:,8)+veget_max(:,9))*contfrac*100 
     990       vartmp(:)=zero 
     991       DO j=2,nvm 
     992          IF(is_deciduous(j)) THEN 
     993             vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100 
     994          ENDIF 
     995       ENDDO 
    913996       CALL histwrite (hist_id_stomate_IPCC, "treeFracPrimDec", itime, & 
    914           vartmp, npts, hori_index) 
    915        vartmp(:)=(veget_max(:,2)+veget_max(:,4)+veget_max(:,5)+veget_max(:,7))*contfrac*100 
     997            vartmp, npts, hori_index) 
     998       !- 
     999!       vartmp(:)=(veget_max(:,2)+veget_max(:,4)+veget_max(:,5)+veget_max(:,7))*contfrac*100 
     1000       vartmp(:)=zero 
     1001       DO j=2,nvm 
     1002          IF(is_evergreen(j)) THEN 
     1003             vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100 
     1004          ENDIF 
     1005       ENDDO 
    9161006       CALL histwrite (hist_id_stomate_IPCC, "treeFracPrimEver", itime, & 
    917          vartmp, npts, hori_index) 
    918        vartmp(:)=(veget_max(:,10)+veget_max(:,12))*contfrac*100 
     1007            vartmp, npts, hori_index) 
     1008       !- 
     1009!       vartmp(:)=(veget_max(:,10)+veget_max(:,12))*contfrac*100 
     1010       vartmp(:)=zero 
     1011       DO j=2,nvm 
     1012          IF(is_c3(j)) THEN 
     1013             vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100 
     1014          ENDIF 
     1015       ENDDO 
    9191016       CALL histwrite (hist_id_stomate_IPCC, "c3PftFrac", itime, & 
    920          vartmp, npts, hori_index) 
    921        vartmp(:)=(veget_max(:,11)+veget_max(:,13))*contfrac*100 
     1017            vartmp, npts, hori_index) 
     1018       !- 
     1019 !      vartmp(:)=(veget_max(:,11)+veget_max(:,13))*contfrac*100 
     1020       vartmp(:)=zero 
     1021       DO j=2,nvm 
     1022          IF(is_c4(j)) THEN 
     1023             vartmp(:) = vartmp(:) + veget_max(:,j)*contfrac*100 
     1024          ENDIF 
     1025       ENDDO 
    9221026       CALL histwrite (hist_id_stomate_IPCC, "c4PftFrac", itime, & 
    923          vartmp, npts, hori_index) 
     1027            vartmp, npts, hori_index) 
     1028       !>> End modif 
     1029        
     1030 
    9241031       vartmp(:)=SUM(resp_growth*veget_max,dim=2)/1e3/one_day*contfrac 
    9251032       CALL histwrite (hist_id_stomate_IPCC, "rGrowth", itime, & 
    926          vartmp, npts, hori_index) 
     1033            vartmp, npts, hori_index) 
    9271034       vartmp(:)=SUM(resp_maint*veget_max,dim=2)/1e3/one_day*contfrac 
    9281035       CALL histwrite (hist_id_stomate_IPCC, "rMaint", itime, & 
    929          vartmp, npts, hori_index) 
     1036            vartmp, npts, hori_index) 
    9301037       vartmp(:)=SUM(bm_alloc(:,:,ileaf)*veget_max,dim=2)/1e3/one_day*contfrac 
    9311038       CALL histwrite (hist_id_stomate_IPCC, "nppLeaf", itime, & 
    932          vartmp, npts, hori_index) 
     1039            vartmp, npts, hori_index) 
    9331040       vartmp(:)=SUM(bm_alloc(:,:,isapabove)*veget_max,dim=2)/1e3/one_day*contfrac 
    9341041       CALL histwrite (hist_id_stomate_IPCC, "nppWood", itime, & 
    935          vartmp, npts, hori_index) 
     1042            vartmp, npts, hori_index) 
    9361043       vartmp(:)=SUM(( bm_alloc(:,:,isapbelow) + bm_alloc(:,:,iroot) )*veget_max,dim=2)/1e3/one_day*contfrac 
    9371044       CALL histwrite (hist_id_stomate_IPCC, "nppRoot", itime, & 
    938          vartmp, npts, hori_index) 
     1045            vartmp, npts, hori_index) 
    9391046 
    9401047       CALL histwrite (hist_id_stomate_IPCC, 'RESOLUTION_X', itime, & 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_npp.f90

    r64 r257  
    144144       ! 1.1.1 soil levels 
    145145 
    146        z_soil(0) = 0. 
     146       z_soil(0) = zero 
    147147       z_soil(1:nbdl) = diaglev(1:nbdl) 
    148148 
    … …  
    175175 
    176176       ! 1.3.1 rpc is an integration constant such that the integral of the root profile is 1. 
    177        rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / rprof(:,j) ) ) 
     177 
     178       rpc(:) = un / ( un - EXP( -z_soil(nbdl) / rprof(:,j) ) ) 
    178179 
    179180       ! 1.3.2 integrate over the nbdl levels 
    … …  
    243244          coeff_maint(:,j,k) = & 
    244245               MAX( coeff_maint_zero(j,k) * & 
    245                ( 1. + slope(:) * (t_maint(:,k)-ZeroCelsius) ), zero ) 
     246               ( un + slope(:) * (t_maint(:,k)-ZeroCelsius) ), zero ) 
    246247 
    247248       ENDDO 
    … …  
    336337       resp_growth_part(:,:) = frac_growthresp * bm_alloc(:,j,:) / dt 
    337338 
    338        bm_alloc(:,j,:) = ( 1. - frac_growthresp ) * bm_alloc(:,j,:) 
     339       bm_alloc(:,j,:) = ( un - frac_growthresp ) * bm_alloc(:,j,:) 
    339340 
    340341       ! 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_phenology.f90

    r109 r257  
    163163    ! 
    164164 
    165     allow_initpheno(:,1) = .FALSE. ! Add 02/02/2011 correctio of MM for the 1.9.5-1 version 
     165    allow_initpheno(:,ibare_sechiba) = .FALSE.  
    166166    DO j = 2,nvm 
    167167 
    … …  
    348348 
    349349       WHERE ( age_reset(:) ) 
    350           leaf_frac(:,j,1) = 1.0 
     350          leaf_frac(:,j,1) = un 
    351351       ENDWHERE 
    352352       DO m = 2, nleafages 
    353353          WHERE ( age_reset(:) ) 
    354              leaf_frac(:,j,m) = 0.0 
     354             leaf_frac(:,j,m) = zero 
    355355          ENDWHERE 
    356356       ENDDO 
    … …  
    360360       DO m = 1, nleafages 
    361361          WHERE ( age_reset(:) ) 
    362              leaf_age(:,j,m) = 0.0 
     362             leaf_age(:,j,m) = zero 
    363363          ENDWHERE 
    364364       ENDDO 
    … …  
    409409 
    410410    ! signal to start putting leaves on 
    411     LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves 
     411    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves 
    412412 
    413413    ! 0.3 local 
    414  
    415     ! moisture availability above which moisture tendency doesn't matter 
    416 !    REAL(r_std), PARAMETER                                   :: moiavail_always_tree = 1.0 
    417 !    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6 
    418414 
    419415    REAL(r_std)                                              :: moiavail_always 
    … …  
    543539 
    544540    ! signal to start putting leaves on 
    545     LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves 
     541    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves 
    546542 
    547543    ! 0.3 local 
    … …  
    679675 
    680676    ! signal to start putting leaves on 
    681     LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves 
     677    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves 
    682678 
    683679    ! 0.3 local 
    … …  
    775771          gdd_crit(i) = pheno_gdd_crit(j,1) + tl(i)*pheno_gdd_crit(j,2) + & 
    776772               tl(i)*tl(i)*pheno_gdd_crit(j,3) 
    777  
    778773 
    779774          IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. & 
    … …  
    839834 
    840835    ! signal to start putting leaves on 
    841     LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves 
     836    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves 
    842837 
    843838    ! 0.3 local 
    … …  
    986981 
    987982    ! signal to start putting leaves on 
    988     LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves 
     983    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves 
    989984 
    990985    ! 0.3 local 
    … …  
    10841079 
    10851080    ! signal to start putting leaves on 
    1086     LOGICAL, DIMENSION(npts,nvm), INTENT(out)              :: begin_leaves 
     1081    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves 
    10871082 
    10881083    ! 0.3 local 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_prescribe.f90

    r64 r257  
    1919  USE pft_parameters 
    2020  USE constantes 
    21  
    2221 
    2322  IMPLICIT NONE 
    … …  
    8988      ! only when the DGVM is not activated or agricultural PFT. 
    9089 
    91       IF ( ( .NOT. control%ok_dgvm ) .OR. ( .NOT. natural(j) ) ) THEN 
     90      IF ( ( .NOT. control%ok_dgvm .AND. lpj_gap_const_mort ) .OR. ( .NOT. natural(j) ) ) THEN 
    9291 
    9392        ! 
    … …  
    9594        ! 
    9695 
    97         cn_ind(:,j) = 0.0 
     96        cn_ind(:,j) = zero 
    9897 
    9998        IF ( tree(j) ) THEN 
    … …  
    103102          ! 
    104103 
    105           dia(:) = 0.0 
     104          dia(:) = zero 
    106105 
    107106          DO i = 1, npts 
    108107 
    109             IF ( veget_max(i,j) .GT. 0.0 ) THEN 
     108            IF ( veget_max(i,j) .GT. zero ) THEN 
    110109 
    111110              ! 1.1.1 calculate total wood mass 
    … …  
    128127 
    129128                dia(i) = ( woodmass_ind(i) / ( pipe_density * pi/4. * pipe_tune2 ) ) ** & 
    130                          ( 1. / ( 2. + pipe_tune3 ) ) 
     129                         ( un / ( 2. + pipe_tune3 ) ) 
    131130 
    132131                ! 1.1.5 crown area, provisional 
    … …  
    149148 
    150149                  dia(i) = ( woodmass_ind(i) / ( pipe_density * pi/4. * pipe_tune2 ) ) ** & 
    151                            ( 1. / ( 2. + pipe_tune3 ) ) 
     150                           ( un / ( 2. + pipe_tune3 ) ) 
    152151 
    153152                  ! final crown area 
    … …  
    176175          ! 
    177176 
    178           WHERE ( veget_max(:,j) .GT. 0.0 ) 
    179             cn_ind(:,j) = 1.0 
     177          WHERE ( veget_max(:,j) .GT. zero ) 
     178            cn_ind(:,j) = un 
    180179          ENDWHERE 
    181180 
    … …  
    186185        ! 
    187186 
    188         WHERE ( veget_max(:,j) .GT. 0.0 ) 
     187        WHERE ( veget_max(:,j) .GT. zero ) 
    189188 
    190189          ind(:,j) = veget_max(:,j) / cn_ind(:,j) 
    … …  
    192191        ELSEWHERE 
    193192 
    194           ind(:,j) = 0.0 
     193          ind(:,j) = zero 
    195194 
    196195        ENDWHERE 
    … …  
    247246              IF ( pheno_model(j) .NE. 'none' ) THEN 
    248247 
    249                 biomass(i,j,ileaf) = 0.0 
    250                 leaf_frac(i,j,1) = 0.0 
     248                biomass(i,j,ileaf) = zero 
     249                leaf_frac(i,j,1) = zero 
    251250 
    252251              ENDIF 
    … …  
    265264 
    266265              ! set leaf age classes 
    267               leaf_frac(i,j,:) = 0.0 
    268               leaf_frac(i,j,1) = 1.0 
     266              leaf_frac(i,j,:) = zero 
     267              leaf_frac(i,j,1) = un 
    269268 
    270269              ! set time since last beginning of growing season 
    … …  
    279278            IF ( veget_max(i,j) .GT. min_stomate ) THEN 
    280279              PFTpresent(i,j) = .TRUE. 
    281               everywhere(i,j) = 1. 
     280              everywhere(i,j) = un 
    282281            ENDIF 
    283282 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_resp.f90

    r64 r257  
    9595       ! 1.1.1 soil levels 
    9696 
    97        z_soil(0) = 0. 
     97       z_soil(0) = zero 
    9898       z_soil(1:nbdl) = diaglev(1:nbdl) 
    9999 
    … …  
    116116 
    117117       ! 1.3.1 rpc is an integration constant such that the integral of the root profile is 1. 
    118        rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / rprof(:,j) ) ) 
     118 
     119       rpc(:) = un / ( un - EXP( -z_soil(nbdl) / rprof(:,j) ) ) 
    119120 
    120121       ! 1.3.2 integrate over the nbdl levels 
    … …  
    174175          coeff_maint(:,j,k) = & 
    175176               MAX( (coeff_maint_zero(j,k)*dt/one_day) * & 
    176                ( 1. + slope(:) * (t_maint_radia(:,k)-ZeroCelsius) ), zero ) 
     177               ( un + slope(:) * (t_maint_radia(:,k)-ZeroCelsius) ), zero ) 
    177178 
    178179       ENDDO 
    … …  
    214215!!$                                 ( .3*lai(i,j) + 1.4 ) / lai(i,j) 
    215216!!$                         ENDIF 
    216 !!$                   resp_maint_part_radia(i,j,k) = coeff_maint(i,j,k) * biomass(i,j,k) * & 
    217 !!$                        ( .3*lai(i,j) + 1.4*(1.-exp(-.5*lai(i,j))) ) / lai(i,j) 
    218  
    219217                   resp_maint_part_radia(i,j,k) = coeff_maint(i,j,k) * biomass(i,j,k) * & 
    220218                        ( maint_resp_min_vmax*lai(i,j) + maint_resp_coeff*(1.-exp(-ext_coeff(j)*lai(i,j))) ) / lai(i,j) 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_season.f90

    r135 r257  
    174174    ! residence time of green tissue (years) 
    175175    REAL(r_std), DIMENSION(npts,nvm)                            :: green_age 
    176  
    177 ! ds 04/03    Old formulation for herbivores 
    178 !!$    ! weights 
    179 !!$    REAL(r_std), DIMENSION(npts)                            :: weighttot 
    180 !!$    ! natural long-term leaf NPP ( gC/m**2/year) 
    181 !!$    REAL(r_std), DIMENSION(npts)                            :: nlflong_nat 
    182 !!$    ! residence time of green tissue (years) 
    183 !!$    REAL(r_std), DIMENSION(npts)                            :: green_age 
    184  
    185176    ! herbivore consumption (gC/m**2/day) 
    186177    REAL(r_std), DIMENSION(npts)                            :: consumption 
     178    ! fraction of each gridcell occupied by natural vegetation 
     179    REAL(r_std), DIMENSION(npts)                            :: fracnat 
    187180 
    188181    ! ========================================================================= 
    … …  
    225218 
    226219       ! 1.2.1.1 "monthly" 
    227 !MM PAS PARALLELISE!! 
     220       !MM PAS PARALLELISE!! 
    228221       IF ( ABS( SUM( moiavail_month(:,2:nvm) ) ) .LT. min_stomate ) THEN 
    229222 
    … …  
    277270 
    278271       ! 1.2.3 "monthly" soil temperatures 
    279 !MM PAS PARALLELISE!! 
     272       !MM PAS PARALLELISE!! 
    280273       IF ( ABS( SUM( tsoil_month(:,:) ) ) .LT. min_stomate ) THEN 
    281274 
    … …  
    464457    !         detect a beginning of the growing season by declaring it dormant 
    465458    ! 
    466 !NVMODIF 
     459    !NVMODIF 
    467460    DO j = 2,nvm 
    468461       WHERE ( ( gpp_week(:,j) .LT. min_gpp_allowed ) .OR. &  
    … …  
    470463            ( ( when_growthinit(:,j) .GT. 2.*one_year ) .AND. & 
    471464            ( biomass(:,j,icarbres) .GT. biomass(:,j,ileaf)*4. ) ) ) 
    472 !       WHERE ( ( gpp_week(:,j) .EQ. zero ) .OR. &  
    473 !            ( gpp_week(:,j) .LT. gppfrac_dormance * maxgppweek_lastyear(:,j) ) .OR. & 
    474 !            ( ( when_growthinit(:,j) .GT. 2.*one_year ) .AND. & 
    475 !            ( biomass(:,j,icarbres) .GT. biomass(:,j,ileaf)*4. ) ) ) 
    476            
     465       !       WHERE ( ( gpp_week(:,j) .EQ. zero ) .OR. &  
     466       !            ( gpp_week(:,j) .LT. gppfrac_dormance * maxgppweek_lastyear(:,j) ) .OR. & 
     467       !            ( ( when_growthinit(:,j) .GT. 2.*one_year ) .AND. & 
     468       !            ( biomass(:,j,icarbres) .GT. biomass(:,j,ileaf)*4. ) ) ) 
     469        
    477470          time_lowgpp(:,j) = time_lowgpp(:,j) + dt 
    478471           
    … …  
    816809    ! 
    817810 
     811    IF(control%ok_dgvm ) THEN 
     812 
     813       fracnat(:) = un 
     814       DO j = 2,nvm 
     815          IF ( .NOT. natural(j) ) THEN 
     816             fracnat(:) = fracnat(:) - veget_max(:,j) 
     817          ENDIF 
     818       ENDDO 
     819 
     820    ENDIF 
     821 
    818822    IF ( control%ok_stomate ) THEN 
    819  
    820        DO j = 2,nvm 
    821           WHERE ( biomass(:,j,ileaf) .GT. lm_thisyearmax(:,j) ) 
    822              lm_thisyearmax(:,j) = biomass(:,j,ileaf) 
    823           ENDWHERE 
    824        ENDDO 
    825  
     823       IF(control%ok_dgvm ) THEN 
     824          DO j=2,nvm 
     825 
     826             IF ( natural(j) .AND. control%ok_dgvm ) THEN 
     827 
     828                WHERE ( fracnat(:) .GT. min_stomate .AND. biomass(:,j,ileaf).GT. lm_lastyearmax(:,j)*0.75 ) 
     829                   maxfpc_lastyear(:,j) = ( maxfpc_lastyear(:,j) * ( one_year/leaflife_tab(j)- dt ) + & 
     830                        veget(:,j) / fracnat(:) * dt ) / (one_year/leaflife_tab(j)) 
     831                ENDWHERE 
     832                maxfpc_thisyear(:,j) = maxfpc_lastyear(:,j) ! just to initialise value 
     833 
     834             ENDIF 
     835 
     836!NV : correct initialization 
     837!!$             WHERE(biomass(:,j,ileaf).GT. lm_lastyearmax(:,j)*0.75) 
     838!!$                lm_lastyearmax(:,j) = ( lm_lastyearmax(:,j) * ( one_year/leaflife_tab(j)- dt ) + & 
     839!!$                     biomass(:,j,ileaf) * dt ) / (one_year/leaflife_tab(j)) 
     840!!$             ENDWHERE 
     841!!$             lm_thisyearmax(:,j)=lm_lastyearmax(:,j) ! just to initialise value 
     842             WHERE (lm_thisyearmax(:,j) .GT. min_stomate) 
     843                WHERE(biomass(:,j,ileaf).GT. lm_thisyearmax(:,j)*0.75) 
     844                   lm_thisyearmax(:,j) = ( lm_thisyearmax(:,j) * ( one_year/leaflife_tab(j)- dt ) + & 
     845                        biomass(:,j,ileaf) * dt ) / (one_year/leaflife_tab(j)) 
     846                ENDWHERE 
     847             ELSEWHERE 
     848                lm_thisyearmax(:,j) =biomass(:,j,ileaf) 
     849             ENDWHERE 
     850 
     851          ENDDO 
     852 
     853       ELSE 
     854 
     855          DO j = 2,nvm 
     856             WHERE ( biomass(:,j,ileaf) .GT. lm_thisyearmax(:,j) ) 
     857                lm_thisyearmax(:,j) = biomass(:,j,ileaf) 
     858             ENDWHERE 
     859          ENDDO 
     860 
     861       ENDIF 
    826862    ELSE 
    827863 
    … …  
    851887       ! 21.1 replace old values 
    852888       ! 
    853 !NVMODIF 
    854       maxmoiavail_lastyear(:,:) = (maxmoiavail_lastyear(:,:)*(tau_climatology-1)+ maxmoiavail_thisyear(:,:))/tau_climatology 
    855       minmoiavail_lastyear(:,:) = (minmoiavail_lastyear(:,:)*(tau_climatology-1)+ minmoiavail_thisyear(:,:))/tau_climatology 
    856       maxgppweek_lastyear(:,:) =( maxgppweek_lastyear(:,:)*(tau_climatology-1)+ maxgppweek_thisyear(:,:))/tau_climatology 
    857 !       maxmoiavail_lastyear(:,:) = maxmoiavail_thisyear(:,:) 
    858 !       minmoiavail_lastyear(:,:) = minmoiavail_thisyear(:,:) 
    859 !       maxgppweek_lastyear(:,:) = maxgppweek_thisyear(:,:) 
    860  
     889       !NVMODIF 
     890       maxmoiavail_lastyear(:,:) = (maxmoiavail_lastyear(:,:)*(tau_climatology-1)+ maxmoiavail_thisyear(:,:))/tau_climatology 
     891       minmoiavail_lastyear(:,:) = (minmoiavail_lastyear(:,:)*(tau_climatology-1)+ minmoiavail_thisyear(:,:))/tau_climatology 
     892       maxgppweek_lastyear(:,:) =( maxgppweek_lastyear(:,:)*(tau_climatology-1)+ maxgppweek_thisyear(:,:))/tau_climatology 
     893       !       maxmoiavail_lastyear(:,:) = maxmoiavail_thisyear(:,:) 
     894       !       minmoiavail_lastyear(:,:) = minmoiavail_thisyear(:,:) 
     895       !       maxgppweek_lastyear(:,:) = maxgppweek_thisyear(:,:) 
     896        
    861897       gdd0_lastyear(:) = gdd0_thisyear(:) 
    862898 
    … …  
    909945       !        fpc_crit. 
    910946 
    911        ! calculate the sum of maxfpc_lastyear 
    912        sumfpc_nat(:) = zero 
    913        DO j = 2,nvm 
    914           sumfpc_nat(:) = sumfpc_nat(:) + maxfpc_lastyear(:,j) 
    915        ENDDO 
    916  
    917        ! scale so that the new sum is fpc_crit 
    918        DO j = 2,nvm  
    919           WHERE ( sumfpc_nat(:) .GT. fpc_crit ) 
    920              maxfpc_lastyear(:,j) = maxfpc_lastyear(:,j) * (fpc_crit/sumfpc_nat(:)) 
    921           ENDWHERE 
    922        ENDDO 
     947!!$       ! calculate the sum of maxfpc_lastyear 
     948!!$       sumfpc_nat(:) = zero 
     949!!$       DO j = 2,nvm 
     950!!$          sumfpc_nat(:) = sumfpc_nat(:) + maxfpc_lastyear(:,j) 
     951!!$       ENDDO 
     952!!$ 
     953!!$       ! scale so that the new sum is fpc_crit 
     954!!$       DO j = 2,nvm  
     955!!$          WHERE ( sumfpc_nat(:) .GT. fpc_crit ) 
     956!!$             maxfpc_lastyear(:,j) = maxfpc_lastyear(:,j) * (fpc_crit/sumfpc_nat(:)) 
     957!!$          ENDWHERE 
     958!!$       ENDDO 
    923959 
    924960    ENDIF  ! EndOfYear 
    … …  
    941977!!$ nlflong_nat, green_age are pft-dependants 
    942978 
    943 !!$    nlflong_nat(:) = zero 
    944 !!$    weighttot(:) = zero 
    945 !!$    green_age(:) = zero 
    946 !!$    ! 
    947 !!$    DO j = 2,nvm 
    948 !!$       ! 
    949 !!$       IF ( natural(j) ) THEN 
    950 !!$          ! 
    951 !!$          weighttot(:) = weighttot(:) + lm_lastyearmax(:,j) 
    952 !!$          nlflong_nat(:) = nlflong_nat(:) + npp_longterm(:,j) * leaf_frac_hvc 
    953 !!$          ! 
    954 !!$          IF ( pheno_model(j) .EQ. 'none' ) THEN 
    955 !!$             green_age(:) = green_age(:) + green_age_ever * lm_lastyearmax(:,j) 
    956 !!$          ELSE 
    957 !!$             green_age(:) = green_age(:) + green_age_dec * lm_lastyearmax(:,j) 
    958 !!$          ENDIF 
    959 !!$          ! 
    960 !!$       ENDIF 
    961 !!$       ! 
    962 !!$    ENDDO 
    963 !!$    ! 
    964 !!$    WHERE ( weighttot(:) .GT. zero ) 
    965 !!$       green_age(:) = green_age(:) / weighttot(:) 
    966 !!$    ELSEWHERE 
    967 !!$       green_age(:) = 1. 
    968 !!$    ENDWHERE 
    969 !!$ 
    970 !!$    ! 
    971 !!$    ! 22.2 McNaughton et al. give herbivore consumption as a function of annual leaf NPP. 
    972 !!$    !      The annual leaf NPP can give us an idea about the edible biomass: 
    973 !!$    ! 
    974 !!$ 
    975 !!$    DO j = 2,nvm 
    976 !!$       ! 
    977 !!$       IF ( natural(j) ) THEN 
    978 !!$          ! 
    979 !!$          WHERE ( nlflong_nat(:) .GT. zero ) 
    980 !!$             consumption(:) = hvc1 * nlflong_nat(:) ** hvc2 
    981 !!$             herbivores(:,j) = one_year * green_age(:) * nlflong_nat(:) / consumption(:) 
    982 !!$          ELSEWHERE 
    983 !!$             herbivores(:,j) = 100000. 
    984 !!$          ENDWHERE 
    985 !!$          ! 
    986 !!$       ELSE 
    987 !!$          ! 
    988 !!$          herbivores(:,j) = 100000. 
    989 !!$          ! 
    990 !!$       ENDIF 
    991 !!$       ! 
    992 !!$    ENDDO 
    993 !!$    herbivores(:,ibare_sechiba) = zero 
    994  
    995979    nlflong_nat(:,:) = zero 
    996980    weighttot(:,:) = zero 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_soilcarbon.f90

    r108 r257  
    112112    frac_carb(:,islow,ipassive) = frac_carb_sp 
    113113 
    114  
    115114    ! 1.1.1.3 from passive pool 
    116115 
    … …  
    118117    frac_carb(:,ipassive,iactive) = frac_carb_pa 
    119118    frac_carb(:,ipassive,islow) = frac_carb_ps 
    120  
    121119 
    122120 
    … …  
    154152    ! 
    155153 
    156     resp_hetero_soil(:,:) = 0.0 
     154    resp_hetero_soil(:,:) = zero 
    157155 
    158156    ! 
    … …  
    173171    ! 
    174172 
    175     frac_resp(:,:) = 1. - frac_carb(:,:,iactive) - frac_carb(:,:,islow) - & 
     173    frac_resp(:,:) = un - frac_carb(:,:,iactive) - frac_carb(:,:,islow) - & 
    176174         frac_carb(:,:,ipassive)  
    177175 
    … …  
    191189             fluxtot(:,k) = dt/carbon_tau(k) * carbon(:,k,m) * & 
    192190                  control_moist(:,ibelow) * control_temp(:,ibelow) 
    193 !!$   DS       ELSEIF ( PFT_name(m)=='          C3           agriculture' ) THEN 
    194191          ELSEIF ( (.NOT. natural(m)) .AND. (.NOT. is_c4(m)) ) THEN 
    195192             fluxtot(:,k) = dt/carbon_tau(k) * carbon(:,k,m) * & 
    196193                  control_moist(:,ibelow) * control_temp(:,ibelow) * flux_tot_coeff(1) 
    197 !!$  DS         ELSEIF ( PFT_name(m)=='          C4           agriculture' ) THEN 
    198194          ELSEIF ( (.NOT. natural(m)) .AND. is_c4(m) ) THEN 
    199195             fluxtot(:,k) = dt/carbon_tau(k) * carbon(:,k,m) * & 

  • branches/ORCHIDEE_EXT/ORCHIDEE/src_stomate/stomate_turnover.f90

    r64 r257  
    196196               tl(:)*tl(:) * senescence_temp(j,3) 
    197197 
    198           WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. & 
     198          WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. & 
    199199               ( leaf_meanage(:,j) .GT. min_leaf_age_for_senescence(j) ) .AND. & 
    200200               ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) ) 
    … …  
    215215               nosenescence_hum(j) ) 
    216216 
    217           WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. & 
     217          WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. & 
    218218               ( leaf_meanage(:,j) .GT. min_leaf_age_for_senescence(j) ) .AND. & 
    219219               ( moiavail_week(:,j) .LT. moiavail_crit(:) ) ) 
    … …  
    240240 
    241241             ! critical temperature for senescence may depend on long term annual mean temperature 
    242              WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. & 
     242             WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. & 
    243243                  ( leaf_meanage(:,j) .GT. min_leaf_age_for_senescence(j) ) .AND. & 
    244244                  ( ( moiavail_week(:,j) .LT. moiavail_crit(:) ) .OR. & 
    … …  
    319319             turnover(:,j,ifruit) = biomass(:,j,ifruit) * dt / turnover_time(:,j) 
    320320          ELSEWHERE 
    321              turnover(:,j,ileaf)=0.0 
    322              turnover(:,j,isapabove) =0.0 
    323              turnover(:,j,iroot) = 0.0 
    324              turnover(:,j,ifruit) =0.0 
     321             turnover(:,j,ileaf)= zero 
     322             turnover(:,j,isapabove) = zero 
     323             turnover(:,j,iroot) = zero 
     324             turnover(:,j,ifruit) = zero 
    325325          ENDWHERE 
    326326          biomass(:,j,ileaf) = biomass(:,j,ileaf) - turnover(:,j,ileaf) 
    … …  
    364364 
    365365          DO m = 1, nleafages 
    366              turnover_rate(:) =0  
     366             turnover_rate(:) = zero 
    367367             WHERE ( leaf_age(:,j,m) .GT. leaf_age_crit(:,j)/2. ) 
    368368 
    … …  
    454454             leaf_frac(:,j,m) = ( leaf_frac(:,j,m)*lm_old(:) + delta_lm(:,m) ) / biomass(:,j,ileaf) 
    455455          ELSEWHERE 
    456              leaf_frac(:,j,m) = 0.0 
     456             leaf_frac(:,j,m) = zero 
    457457          ENDWHERE 
    458458 
    … …  
    489489          ! check whether we shed the remaining leaves 
    490490 
    491           WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. senescence(:,j) .AND. & 
     491          WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. senescence(:,j) .AND. & 
    492492               ( biomass(:,j,ileaf) .LT. (lai_initmin(j) / 2.)/sla(j) )             ) 
    493493 
    … …  
    498498             turnover(:,j,ifruit) = turnover(:,j,ifruit) + biomass(:,j,ifruit) 
    499499 
    500              biomass(:,j,ileaf) = 0.0 
    501              biomass(:,j,iroot) = 0.0 
    502              biomass(:,j,ifruit) = 0.0 
     500             biomass(:,j,ileaf) = zero 
     501             biomass(:,j,iroot) = zero 
     502             biomass(:,j,ifruit) = zero 
    503503 
    504504 
    505505 
    506506             ! reset leaf age 
    507              leaf_meanage(:,j) = 0.0 
     507             leaf_meanage(:,j) = zero 
    508508 
    509509          ENDWHERE 
    … …  
    519519          ! Shed the remaining leaves if LAI very low. 
    520520 
    521           WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. senescence(:,j) .AND. & 
     521          WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. senescence(:,j) .AND. & 
    522522               (  biomass(:,j,ileaf) .LT. (lai_initmin(j) / 2.)/sla(j) )) 
    523523 
    … …  
    529529             turnover(:,j,ifruit) = turnover(:,j,ifruit) + biomass(:,j,ifruit) 
    530530 
    531              biomass(:,j,ileaf) = 0.0 
    532              biomass(:,j,isapabove) = 0.0 
    533              biomass(:,j,iroot) = 0.0 
    534              biomass(:,j,ifruit) = 0.0 
     531             biomass(:,j,ileaf) = zero 
     532             biomass(:,j,isapabove) = zero 
     533             biomass(:,j,iroot) = zero 
     534             biomass(:,j,ifruit) = zero 
    535535 
    536536 
    537537 
    538538             ! reset leaf age 
    539              leaf_meanage(:,j) = 0.0 
     539             leaf_meanage(:,j) = zero 
    540540 
    541541          ENDWHERE 
    … …  
    551551          WHERE ( shed_rest(:) ) 
    552552 
    553              leaf_age(:,j,m) = 0.0 
    554              leaf_frac(:,j,m) = 0.0 
     553             leaf_age(:,j,m) = zero 
     554             leaf_frac(:,j,m) = zero 
    555555 
    556556          ENDWHERE 
    … …  
    679679             hw_new(:) = biomass(:,j,iheartabove) + biomass(:,j,iheartbelow) 
    680680 
    681              WHERE ( hw_new(:) .GT. 0.0 ) 
     681             WHERE ( hw_new(:) .GT. zero ) 
    682682 
    683683                age(:,j) = age(:,j) * hw_old(:)/hw_new(:) 
Note: See TracChangeset for help on using the changeset viewer.