ORCHIDEE/ 0000754 0103600 0005670 00000000000 11164403473 011722 5 ustar acamlmd lmdjus ORCHIDEE/CVS/ 0000754 0103600 0005670 00000000000 11164403473 012355 5 ustar acamlmd lmdjus ORCHIDEE/CVS/Root 0000754 0103600 0005670 00000000071 11164403473 013224 0 ustar acamlmd lmdjus :pserver:sechiba@cvs.ipsl.jussieu.fr:/home/ssipsl/CVSREP
ORCHIDEE/CVS/Repository 0000754 0103600 0005670 00000000011 11164403473 014452 0 ustar acamlmd lmdjus ORCHIDEE
ORCHIDEE/CVS/Entries 0000754 0103600 0005670 00000000415 11164403473 013714 0 ustar acamlmd lmdjus /AA_make/1.3/Thu Jun 21 16:55:26 2007//Torchidee_1_9
/AA_make.ldef/1.1/Thu Jun 21 09:11:58 2007//Torchidee_1_9
/ORCHIDEE_CeCILL.LIC/1.2/Mon May 28 15:07:24 2007//Torchidee_1_9
D/src_global////
D/src_parallel////
D/src_parameters////
D/src_sechiba////
D/src_stomate////
ORCHIDEE/CVS/Tag 0000754 0103600 0005670 00000000016 11164403473 013013 0 ustar acamlmd lmdjus Norchidee_1_9
ORCHIDEE/CVS/Template 0000754 0103600 0005670 00000000000 11164403473 014044 0 ustar acamlmd lmdjus ORCHIDEE/AA_make 0000754 0103600 0005670 00000001064 11164403473 013127 0 ustar acamlmd lmdjus #- $Id: AA_make,v 1.4 2007/09/20 13:32:32 ssipsl Exp $
all : libparameters libparallel liborglob libstomate libsechiba
libparameters :
(cd src_parameters ; $(M_K) -f Makefile)
libparallel :
(cd ../../modeles/ORCHIDEE/src_parallel ; $(M_K) -f Makefile)
liborglob :
(cd src_global ; $(M_K) -f Makefile)
libstomate :
(cd src_stomate ; $(M_K) -f Makefile)
libsechiba :
(cd src_sechiba ; $(M_K) -f Makefile)
config :
(cd src_parameters; $(M_K) -f Makefile config)
(cd src_sechiba; $(M_K) -f Makefile config)
(cd src_stomate; $(M_K) -f Makefile config)
ORCHIDEE/AA_make.ldef 0000754 0103600 0005670 00000000206 11164403473 014035 0 ustar acamlmd lmdjus #- $Id: AA_make.ldef,v 1.1 2007/06/21 09:11:58 ssipsl Exp $
#---------------------------------------------------------------------
#-
ORCHIDEE/ORCHIDEE_CeCILL.LIC 0000754 0103600 0005670 00000004114 11164403473 014513 0 ustar acamlmd lmdjus The following licence information concerns ONLY the ORCHIDEE MODEL
==================================================================
Copyright © Centre National de la Recherche Scientifique CNRS
Commissariat à l'Énergie Atomique CEA
ORCHIDEE : Organizing Carbon and Hydrology In Dynamic EcosystEms.
The purpose of this software is to simulate a number of exchanges
occurring at the interface between the continental biosphere and the
atmosphere, as well as the state of the biosphere (soil water and
carbon content, living biomass, fluxes of latent, sensible heat, net
CO2 flux, .....). It includes physical, biogeochemical and chemical
processes at varying time scales (minutes to centuries).
This software is governed by the CeCILL license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/ or redistribute the software under the terms of the CeCILL
license as circulated by CEA, CNRS and INRIA at the following URL
"http://www.cecill.info".
As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided only
with a limited warranty and the software's author, the holder of the
economic rights, and the successive licensors have only limited
liability.
In this respect, the user's attention is drawn to the risks associated
with loading, using, modifying and/or developing or reproducing the
software by the user in light of its specific status of free software,
that may mean that it is complicated to manipulate, and that also
therefore means that it is reserved for developers and experienced
professionals having in-depth computer knowledge. Users are therefore
encouraged to load and test the software's suitability as regards their
requirements in conditions enabling the security of their systems and/or
data to be ensured and, more generally, to use and operate it in the
same conditions as regards security.
The fact that you are presently reading this means that you have had
knowledge of the CeCILL license and that you accept its terms.
ORCHIDEE/src_global/ 0000754 0103600 0005670 00000000000 11202267312 014022 5 ustar acamlmd lmdjus ORCHIDEE/src_global/CVS/ 0000754 0103600 0005670 00000000000 11164403473 014464 5 ustar acamlmd lmdjus ORCHIDEE/src_global/CVS/Root 0000754 0103600 0005670 00000000071 11164403473 015333 0 ustar acamlmd lmdjus :pserver:sechiba@cvs.ipsl.jussieu.fr:/home/ssipsl/CVSREP
ORCHIDEE/src_global/CVS/Repository 0000754 0103600 0005670 00000000024 11164403473 016565 0 ustar acamlmd lmdjus ORCHIDEE/src_global
ORCHIDEE/src_global/CVS/Entries 0000754 0103600 0005670 00000000324 11164403473 016022 0 ustar acamlmd lmdjus /AA_make/1.1/Mon May 28 09:13:36 2007//Torchidee_1_9
/AA_make.ldef/1.1/Mon May 28 09:13:36 2007//Torchidee_1_9
/interpol_help.f90/1.5/Tue Jun 12 19:17:28 2007//Torchidee_1_9
/grid.f90/1.7/Result of merge//T1.7
D
ORCHIDEE/src_global/CVS/Tag 0000754 0103600 0005670 00000000016 11164403473 015122 0 ustar acamlmd lmdjus Norchidee_1_9
ORCHIDEE/src_global/CVS/Template 0000754 0103600 0005670 00000000000 11164403473 016153 0 ustar acamlmd lmdjus ORCHIDEE/src_global/AA_make 0000754 0103600 0005670 00000002704 11164403473 015240 0 ustar acamlmd lmdjus #-
#- $Id: AA_make,v 1.4 2008/01/08 11:49:07 ssipsl Exp $
#-
PARAM_LIB = $(LIBDIR)/libparameters.a
SXPARAM_LIB = $(PARAM_LIB)
#-Q- sxnec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-Q- sx6nec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-Q- eshpux SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-Q- sx8brodie SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-
MODS1 = grid.f90 \
interpol_help.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-Q- sxnec .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
#-
all:
$(M_K) libparameters
$(M_K) m_all
@echo orglob is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
libparameters:
(cd ../src_parameters; $(M_K) -f Makefile)
$(MODEL_LIB)(%.o) : %.f90
$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
$(A_C) $(MODEL_LIB) $*.o
#-Q- sxnec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sxnec mv $*.mod $(MODDIR)
#-Q- sx6nec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx6nec mv $*.mod $(MODDIR)
#-Q- eshpux $(A_X) $(SXMODEL_LIB) $*.o
#-Q- eshpux mv $*.mod $(MODDIR)
#-Q- sx8mercure mv $*.mod $(MODDIR)
#-Q- sx8brodie $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx8brodie mv $*.mod $(MODDIR)
#-Q- solaris mv $*.mod $(MODDIR)
$(RM) $*.o
config :
$(BINDIR)/Fparser -name ORGLOB $(MODS1)
echo 'Configuration of ORGLOB done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(grid.o): \
$(PARAM_LIB)(constantes.o)
$(MODEL_LIB)(interpol_help.o): \
$(PARAM_LIB)(constantes_veg.o)
ORCHIDEE/src_global/AA_make.ldef 0000754 0103600 0005670 00000001340 11164403473 016144 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.2 2008/01/08 11:49:07 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a ORGLOB
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/liborglob.a
SXMODEL_LIB = $(MODEL_LIB)
#-Q- sxnec SXMODEL_LIB = $(LIBDIR)/libsxorglob.a
#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxorglob.a
#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxorglob.a
#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxorglob.a
ORCHIDEE/src_global/grid.f90 0000754 0103600 0005670 00000041050 11164403473 015301 0 ustar acamlmd lmdjus
!! This module define variables for the grid to gathered points.
!!
!! @call sechiba_main
!! @Version : $Revision: 1.7 $, $Date: 2008/04/02 13:02:25 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_global/grid.f90,v 1.7 2008/04/02 13:02:25 ssipsl Exp $
!!
!! @author Marie-Alice Foujols, Jan Polcher and Martial Mancip
!!
!!
!f90doc MODULEgrid
MODULE grid
USE defprec
USE constantes
USE parallel
IMPLICIT NONE
!
! PARAMETERS
! default resolution (m)
REAL(r_std), PARAMETER :: default_resolution = 250000.
!
! earth radius
REAL(r_std), PARAMETER :: R_Earth = 6378000.
!
! VARIABLES
!
! Global map or not.
! There is little change that if iim <=2 and jjm <= 2 that we have global grid.
! Furthermore using the second line allows to avoid pole problems for global grids
LOGICAL, SAVE :: global = .FALSE.
!
!-
!- Variable to help describe the grid
!- once the points are gathered.
!-
!! Limits of the domain
REAL(r_std), SAVE :: limit_west, limit_east, &
& limit_north, limit_south
!-
!! Geographical coordinates
REAL(r_std), ALLOCATABLE, DIMENSION (:,:), SAVE :: lalo
!! index of land points
INTEGER, ALLOCATABLE, DIMENSION (:), SAVE :: ilandindex,jlandindex
!-
!! Fraction of continents.
REAL(r_std), ALLOCATABLE, DIMENSION (:), SAVE :: contfrac
!
! indices of the 4 neighbours of each grid point (1=N, 2=E, 3=S, 4=W)
! a zero or negative index means that this neighbour is not a land point
INTEGER(i_std), ALLOCATABLE, DIMENSION (:,:), SAVE :: neighbours
!
! resolution at each grid point in m (1=E-W, 2=N-S)
! (size in x an y of the grid)
REAL(r_std), ALLOCATABLE, DIMENSION (:,:), SAVE :: resolution
REAL(r_std), DIMENSION(2), SAVE :: min_resol,max_resol
REAL(r_std), ALLOCATABLE, DIMENSION (:), SAVE :: area
!
!
! Get the direction of the grid
!
CHARACTER(LEN=2), DIMENSION(2), SAVE, PRIVATE :: grid_dir
!
! Rose gives the geographical direction for the various index increments
! The following corespondences exist
! WE&NS WE&SN and so on !
! rose(1) = i+0 & j-1 NN SS
! rose(2) = i+1 & j-1 NE SE
! rose(3) = i+1 & j+0 EE EE
! rose(4) = i+1 & j+1 SE NE
! rose(5) = i+0 & j+1 SS NN
! rose(6) = i-1 & j+1 SW NW
! rose(7) = i-1 & j+0 WW WW
! rose(8) = i-1 & j-1 NW SW
INTEGER(i_std), DIMENSION(8), SAVE, PRIVATE :: rose
!
CONTAINS
!
!f90doc CONTAINS
!
!
SUBROUTINE init_grid ( npts )
!
! 0 interface
!
IMPLICIT NONE
!
! 0.1 input !
! Domain size
INTEGER(i_std), INTENT(in) :: npts !! Number of local continental points
!
! Create the internal coordinate table
!
IF ( (.NOT.ALLOCATED(lalo))) THEN
ALLOCATE(lalo(npts,2))
lalo(:,:) = val_exp
ENDIF
!-
!- Store variable to help describe the grid
!- once the points are gathered.
!-
IF ( (.NOT.ALLOCATED(neighbours))) THEN
ALLOCATE(neighbours(npts,8))
neighbours(:,:) = -999999
ENDIF
IF ( (.NOT.ALLOCATED(resolution))) THEN
ALLOCATE(resolution(npts,2))
resolution(:,:) = val_exp
ENDIF
IF ( (.NOT.ALLOCATED(area))) THEN
ALLOCATE(area(npts))
area(:) = val_exp
ENDIF
!
!- Store the fraction of the continents only once so that the user
!- does not change them afterwards.
!
IF ( (.NOT.ALLOCATED(contfrac))) THEN
ALLOCATE(contfrac(npts))
contfrac(:) = val_exp
ENDIF
!
! Allocation of index coordinates
IF (.NOT. ALLOCATED(ilandindex)) THEN
ALLOCATE(ilandindex(npts),jlandindex(npts))
ilandindex(:) = -10000000
jlandindex(:) = -10000000
ENDIF
!
END SUBROUTINE init_grid
SUBROUTINE grid_stuff (npts_glo, iim, jjm, grid_lon, grid_lat, kindex)
!
! 0 interface
!
IMPLICIT NONE
!
! 0.1 input !
! Domain size
INTEGER(i_std), INTENT(in) :: npts_glo
! Size of cartesian grid
INTEGER(i_std), INTENT(in) :: iim, jjm
! Longitudes on cartesian grid
REAL(r_std), DIMENSION(iim,jjm), INTENT(in) :: grid_lon
! Latitudes on cartesian grid
REAL(r_std), DIMENSION(iim,jjm), INTENT(in) :: grid_lat
! Index of land point on 2D map (in local position)
INTEGER(i_std), DIMENSION(:), INTENT(in) :: kindex
!
! 0.3 local
!
! Index of land point on 2D map (in global position)
INTEGER, ALLOCATABLE, DIMENSION (:) :: index_p
!
! which STOMATE point corresponds to the given point on the cartesian grid
INTEGER(i_std), DIMENSION(iim,jjm) :: correspondance
! cosine of the latitude
REAL(r_std) :: coslat
! number of points where default resolution is used
INTEGER(i_std) :: ndefault_lon, ndefault_lat
! Indices
INTEGER(i_std) :: i,ip,jp, imm1, imp1, imm1l, imp1l, ii
!
INTEGER(i_std), SAVE :: bavard=2
REAL(r_std), PARAMETER :: min_stomate = 1.E-8
REAL(r_std), SAVE :: pi
! =========================================================================
pi = 4. * ATAN(1.)
IF ( bavard .GE. 4 ) WRITE(numout,*) 'Entering grid_stuff'
! default resolution
IF ( bavard .GT. 1 ) WRITE(numout,*) 'grid stuff: default resolution (m): ',default_resolution
!
!-
IF (is_root_prc) THEN
! Check if we have a global map or not.
! There is little change that if iim <=2 and jjm <= 2 that we have global grid.
! Furthermore using the second line allows to avoid pole problems for global grids
IF (iim <= 2 .OR. jjm <= 2) THEN
global = .FALSE.
ELSE
! We assume here that the longitude is in increasing order and in degrees.
IF ( grid_lon(iim,2)-grid_lon(1,2) >= 360. - (grid_lon(2,2)-grid_lon(1,2)) ) THEN
global = .TRUE.
ENDIF
ENDIF
!
! Get the direction of the grid
!
IF ( iim > 1 ) THEN
IF ( grid_lon(1,1) <= grid_lon(2,1) ) THEN
grid_dir(1) = 'WE'
ELSE
grid_dir(1) = 'EW'
ENDIF
ELSE
grid_dir(1) = 'WE'
ENDIF
!
IF ( jjm > 1 ) THEN
IF ( grid_lat(1,1) >= grid_lat(1,2) ) THEN
grid_dir(2) = 'NS'
ELSE
grid_dir(2) = 'SN'
ENDIF
ELSE
grid_dir(2) = 'NS'
ENDIF
!
!! WRITE(numout,*) 'Longitude direction :', grid_dir(1)
!! WRITE(numout,*) 'Latitude direction :', grid_dir(2)
!
ndefault_lon = 0
ndefault_lat = 0
! initialize output
neighbours_g(:,:) = -1
resolution_g(:,:) = 0.
min_resol(:) = 1.e6
max_resol(:) = -1.
correspondance(:,:) = -1
DO i = 1, npts_glo
!
! 1 find numbers of the latitude and longitude of each point
!
! index of latitude
jp = INT( (index_g(i)-1) /iim ) + 1
! index of longitude
ip = index_g(i) - ( jp-1 ) * iim
!
!correspondance(ip,jp) = kindex(i)
!
correspondance(ip,jp) = i
ENDDO
!
! Get the "wind rose" for the various orientation of the grid
!
IF ( grid_dir(1) .EQ. 'WE' .AND. grid_dir(2) .EQ. 'NS' ) THEN
rose(1) = 1
rose(2) = 2
rose(3) = 3
rose(4) = 4
rose(5) = 5
rose(6) = 6
rose(7) = 7
rose(8) = 8
ELSE IF ( grid_dir(1) .EQ. 'EW' .AND. grid_dir(2) .EQ. 'NS' ) THEN
rose(1) = 1
rose(2) = 8
rose(3) = 7
rose(4) = 6
rose(5) = 5
rose(6) = 4
rose(7) = 3
rose(8) = 2
ELSE IF ( grid_dir(1) .EQ. 'WE' .AND. grid_dir(2) .EQ. 'SN' ) THEN
rose(1) = 5
rose(2) = 4
rose(3) = 3
rose(4) = 2
rose(5) = 1
rose(6) = 8
rose(7) = 7
rose(8) = 6
ELSE IF ( grid_dir(1) .EQ. 'EW' .AND. grid_dir(2) .EQ. 'SN' ) THEN
rose(1) = 5
rose(2) = 6
rose(3) = 7
rose(4) = 8
rose(5) = 1
rose(6) = 2
rose(7) = 3
rose(8) = 4
ELSE
WRITE(numout,*) 'We can not be here'
STOP 'grid_stuff'
ENDIF
DO i = 1, npts_glo
! index of latitude
jp = INT( (index_g(i)-1) /iim ) + 1
! index of longitude
ip = index_g(i) - ( jp-1 ) * iim
!
! 2 resolution
!
!
! 2.1 longitude
!
! prevent infinite resolution at the pole
coslat = MAX( COS( grid_lat(ip,jp) * pi/180. ), 0.001 )
IF ( iim .GT. 1 ) THEN
IF ( ip .EQ. 1 ) THEN
resolution_g(i,1) = &
ABS( grid_lon(ip+1,jp) - grid_lon(ip,jp) ) * &
pi/180. * R_Earth * coslat
ELSEIF ( ip .EQ. iim ) THEN
resolution_g(i,1) = &
ABS( grid_lon(ip,jp) - grid_lon(ip-1,jp) ) * &
pi/180. * R_Earth * coslat
ELSE
resolution_g(i,1) = &
ABS( grid_lon(ip+1,jp) - grid_lon(ip-1,jp) )/2. *&
pi/180. * R_Earth * coslat
ENDIF
ELSE
resolution_g(i,1) = default_resolution
ndefault_lon = ndefault_lon + 1
ENDIF
!
! 2.2 latitude
!
IF ( jjm .GT. 1 ) THEN
IF ( jp .EQ. 1 ) THEN
resolution_g(i,2) = &
ABS( grid_lat(ip,jp) - grid_lat(ip,jp+1) ) * &
pi/180. * R_Earth
ELSEIF ( jp .EQ. jjm ) THEN
resolution_g(i,2) = &
ABS( grid_lat(ip,jp-1) - grid_lat(ip,jp) ) * &
pi/180. * R_Earth
ELSE
resolution_g(i,2) = &
ABS( grid_lat(ip,jp-1) - grid_lat(ip,jp+1) )/2. *&
pi/180. * R_Earth
ENDIF
ELSE
resolution_g(i,2) = default_resolution
ndefault_lat = ndefault_lat + 1
ENDIF
min_resol(1) = MIN(resolution_g(i,1),min_resol(1))
min_resol(2) = MIN(resolution_g(i,2),min_resol(2))
max_resol(1) = MAX(resolution_g(i,1),max_resol(1))
max_resol(2) = MAX(resolution_g(i,2),max_resol(2))
area_g(i) = resolution_g(i,1)*resolution_g(i,2)
!
! 3 find neighbours
!
imm1 = 0
IF ( ip .GT. 1 ) THEN
imm1 = ip - 1
ELSEIF ( global ) THEN
imm1 = iim
ENDIF
imp1 = 0
IF ( ip .LT. iim ) THEN
imp1 = ip + 1
ELSEIF ( global ) THEN
imp1 = 1
ENDIF
!
! East and West
!
IF ( imp1 > 0 ) THEN
neighbours_g(i,rose(3)) = correspondance(imp1,jp)
ELSE
neighbours_g(i,rose(3)) = -1
ENDIF
IF ( imm1 > 0 ) THEN
neighbours_g(i,rose(7)) = correspondance(imm1,jp)
ELSE
neighbours_g(i,rose(7)) = -1
ENDIF
!
! North
!
IF ( jp .GT. 1 ) THEN
neighbours_g(i,rose(1)) = correspondance(ip,jp-1)
IF ( imp1 > 0 ) THEN
neighbours_g(i,rose(2)) = correspondance(imp1,jp-1)
ELSE
neighbours_g(i,rose(2)) = -1
ENDIF
IF ( imm1 > 0 ) THEN
neighbours_g(i,rose(8)) = correspondance(imm1,jp-1)
ELSE
neighbours_g(i,rose(8)) = -1
ENDIF
ELSE
IF ( global ) THEN
! special treatment for the pole if we are really in a 2d grid
IF ( ( iim .GT. 1 ) .AND. ( jjm .GT. 1 ) ) THEN
!
ii = MOD(ip+iim/2-1,iim)+1
imm1l = ii - 1
IF ( imm1l .LT. 1 ) imm1l = iim
imp1l = ii + 1
IF ( imp1l .GT. iim ) imp1l = 1
!
IF ( ABS( ( grid_lat(ip,jp) ) - 90. ) .LT. min_sechiba ) THEN
! the grid point sits exactly on the pole. The neighbour is situated
! at a lower latitude.
neighbours_g(i,rose(1)) = correspondance( ii, jp+1 )
neighbours_g(i,rose(2)) = correspondance( imm1l, jp+1 )
neighbours_g(i,rose(8)) = correspondance( imp1l, jp+1 )
ELSE
! look across the North Pole
neighbours_g(i,rose(1)) = correspondance( ii, jp )
neighbours_g(i,rose(2)) = correspondance( imm1l, jp )
neighbours_g(i,rose(8)) = correspondance( imp1l, jp )
ENDIF
ENDIF
ELSE
neighbours_g(i,rose(1)) = -1
neighbours_g(i,rose(2)) = -1
neighbours_g(i,rose(8)) = -1
ENDIF
ENDIF
! South
IF ( jp .LT. jjm ) THEN
neighbours_g(i,rose(5)) = correspondance(ip,jp+1)
IF ( imp1 > 0 ) THEN
neighbours_g(i,rose(4)) = correspondance(imp1,jp+1)
ELSE
neighbours_g(i,rose(4)) = -1
ENDIF
IF ( imm1 > 0 ) THEN
neighbours_g(i,rose(6)) = correspondance(imm1,jp+1)
ELSE
neighbours_g(i,rose(6)) = -1
ENDIF
ELSE
IF ( global ) THEN
! special treatment for the pole if we are really in a 2d grid
IF ( ( iim .GT. 1 ) .AND. ( jjm .GT. 1 ) ) THEN
!
ii = MOD(ip+iim/2-1,iim)+1
imm1l = ii - 1
IF ( imm1l .LT. 1 ) imm1l = iim
imp1l = ii + 1
IF ( imp1l .GT. iim ) imp1l = 1
!
IF ( ( ABS( grid_lat(ip,jp) ) - 90. ) .LT. min_sechiba ) THEN
! the grid point sits exactly on the pole. The neighbour is situated
! at a lower latitude.
neighbours_g(i,rose(5)) = correspondance( ii, jp-1 )
neighbours_g(i,rose(4)) = correspondance( imm1l, jp-1 )
neighbours_g(i,rose(6)) = correspondance( imp1l, jp-1 )
ELSE
! look across the South Pole
neighbours_g(i,rose(5)) = correspondance( ii, jp )
neighbours_g(i,rose(4)) = correspondance( imm1l, jp )
neighbours_g(i,rose(6)) = correspondance( imp1l, jp )
ENDIF
ENDIF
ELSE
neighbours_g(i,rose(5)) = -1
neighbours_g(i,rose(4)) = -1
neighbours_g(i,rose(6)) = -1
ENDIF
ENDIF
ENDDO
IF ( bavard .GT. 1 ) THEN
WRITE(numout,*) ' > Total number of points: ',npts_glo
WRITE(numout,*) ' > Using default zonal resolution at',ndefault_lon,' points.'
WRITE(numout,*) ' > Using default meridional resolution at',ndefault_lat,' points.'
ENDIF
!
ENDIF ! (root_prc)
CALL scatter(neighbours_g,neighbours)
CALL scatter(resolution_g,resolution)
CALL scatter(area_g,area)
CALL bcast(min_resol)
CALL bcast(max_resol)
IF ( bavard .EQ. 5 ) THEN
WRITE(numout,*) ' > resolution = ',resolution
WRITE(numout,*) ' > rose = ',rose
WRITE(numout,*) ' > neighbours = ',neighbours
ENDIF
IF ( bavard .GT. 1 ) WRITE(numout,*) 'Leaving grid_stuff'
END SUBROUTINE grid_stuff
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END MODULE grid
ORCHIDEE/src_global/interpol_help.f90 0000754 0103600 0005670 00000100416 11164403473 017222 0 ustar acamlmd lmdjus !
! Aggregation routines. These routines allow to interpolate from the finer grid on which the
! surface parameter is available to the coarser one of the model.
!
! The routines work for the fine data on a regular lat/lon grid. This grid can come in as either
! a rank2 array or a vector. Two procedure exist which require slightly different input fields.
!
!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_global/interpol_help.f90,v 1.5 2007/06/12 19:17:28 ssipsl Exp $
!
!
MODULE interpol_help
! Modules used :
USE IOIPSL, ONLY : ipslerr
USE constantes
USE constantes_veg
USE parallel
IMPLICIT NONE
PRIVATE
PUBLIC aggregate, aggregate_p
!
INTERFACE aggregate
MODULE PROCEDURE aggregate_2d, aggregate_vec
END INTERFACE
!
INTERFACE aggregate_p
MODULE PROCEDURE aggregate_2d_p, aggregate_vec_p
END INTERFACE
!
REAL(r_std), PARAMETER :: R_Earth = 6378000.
REAL(r_std), PARAMETER :: mincos = 0.0001
!
LOGICAL, PARAMETER :: check_grid=.FALSE.
!
CONTAINS
!
! This routing will get for each point of the coarse grid the
! indexes of the finer grid and the area of overlap.
! This routine is designed for a fine grid which is regular in lat/lon.
!
SUBROUTINE aggregate_2d (nbpt, lalo, neighbours, resolution, contfrac, &
& iml, jml, lon_rel, lat_rel, mask, callsign, &
& incmax, indinc, areaoverlap, ok)
!
! INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box.
INTEGER(i_std), INTENT(in) :: iml, jml ! Size of the finer grid
REAL(r_std), INTENT(in) :: lon_rel(iml, jml) ! Longitudes for the finer grid
REAL(r_std), INTENT(in) :: lat_rel(iml, jml) ! Latitudes for the finer grid
INTEGER(i_std), INTENT(in) :: mask(iml, jml) ! Mask which retains only the significative points
! of the fine grid.
CHARACTER(LEN=*), INTENT(in) :: callsign ! Allows to specify which variable is beeing treated
INTEGER(i_std), INTENT(in) :: incmax ! Maximum point of the fine grid we can store.
!
! Output
!
INTEGER(i_std), INTENT(out) :: indinc(nbpt,incmax,2)
REAL(r_std), INTENT(out) :: areaoverlap(nbpt,incmax)
LOGICAL, OPTIONAL, INTENT(out) :: ok ! return code
!
! Local Variables
!
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_ful, lon_ful
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: loup_rel, lolow_rel, laup_rel, lalow_rel
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: searchind
REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
REAL(r_std) :: coslat, ax, ay, sgn, lonrel, lolowrel, louprel
INTEGER(i_std) :: fopt, fopt_max, ip, jp, ib, i, itmp, iprog, nbind
REAL(r_std) :: domain_minlon,domain_maxlon,domain_minlat,domain_maxlat
INTEGER(i_std) :: minLon(1), maxLon(1)
!
! Some inital assignmens
!
areaoverlap(:,:) = moins_un
indinc(:,:,:) = zero
!
ALLOCATE (laup_rel(iml,jml))
ALLOCATE (loup_rel(iml,jml))
ALLOCATE (lalow_rel(iml,jml))
ALLOCATE (lolow_rel(iml,jml))
ALLOCATE (lat_ful(iml+2,jml+2))
ALLOCATE (lon_ful(iml+2,jml+2))
ALLOCATE (searchind(iml*jml,2))
!
IF (PRESENT(ok)) ok = .TRUE.
!
! Duplicate the border assuming we have a global grid going from west to east
!
lon_ful(2:iml+1,2:jml+1) = lon_rel(1:iml,1:jml)
lat_ful(2:iml+1,2:jml+1) = lat_rel(1:iml,1:jml)
!
IF ( lon_rel(iml,1) .LT. lon_ful(2,2)) THEN
lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)
lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
ELSE
lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)-360
lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
ENDIF
IF ( lon_rel(1,1) .GT. lon_ful(iml+1,2)) THEN
lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)
lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
ELSE
lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)+360
lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
ENDIF
!
sgn = lat_rel(1,1)/ABS(lat_rel(1,1))
lat_ful(2:iml+1,1) = sgn*180 - lat_rel(1:iml,1)
sgn = lat_rel(1,jml)/ABS(lat_rel(1,jml))
lat_ful(2:iml+1,jml+2) = sgn*180 - lat_rel(1:iml,jml)
lat_ful(1,1) = lat_ful(iml+1,1)
lat_ful(iml+2,1) = lat_ful(2,1)
lat_ful(1,jml+2) = lat_ful(iml+1,jml+2)
lat_ful(iml+2,jml+2) = lat_ful(2,jml+2)
!
! Add the longitude lines to the top and bottom
!
lon_ful(:,1) = lon_ful(:,2)
lon_ful(:,jml+2) = lon_ful(:,jml+1)
!
! Get the upper and lower limits of each grid box
!
DO ip=1,iml
DO jp=1,jml
!
loup_rel(ip,jp) =MAX(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)),&
& 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
lolow_rel(ip,jp) =MIN(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)),&
& 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
laup_rel(ip,jp) =MAX(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)),&
& 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
lalow_rel(ip,jp) =MIN(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)),&
& 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
!
ENDDO
ENDDO
IF (check_grid) THEN
WRITE(numout,*) "================================"
WRITE(numout,*) "interpol_aggrgate_2d : Map meshes :"
WRITE(numout,*) "lat read(1,:) :",lat_rel(1,:)
WRITE(numout,*) "lat_ful(1,:) :",lat_ful(1,:)
WRITE(numout,*) "lat_ful(2,:) :",lat_ful(2,:)
WRITE(numout,*) "lalow_rel(1,:) :",lalow_rel(1,:)
WRITE(numout,*) "laup_rel(1,:) :",laup_rel(1,:)
WRITE(numout,*) "================================"
WRITE(numout,*) "lon read(:,1) :",lon_rel(:,1)
WRITE(numout,*) "lon_ful(:,1) :",lon_ful(:,1)
WRITE(numout,*) "lon_ful(:,2) :",lon_ful(:,2)
WRITE(numout,*) "lolow_rel(:,1) :",lolow_rel(:,1)
WRITE(numout,*) "loup_rel(:,1) :",loup_rel(:,1)
WRITE(numout,*) "================================"
ENDIF
!
!
! To speedup calculations we will get the limits of the domain of the
! coarse grid and select all the points of the fine grid which are potentialy
! in this domain.
!
!
minLon = MINLOC(lalo(:,2))
coslat = MAX(COS(lalo(minLon(1),1) * pi/180. ), mincos )*pi/180. * R_Earth
domain_minlon = lalo(minLon(1),2) - resolution(minLon(1),1)/(2.0*coslat)
maxLon = MAXLOC(lalo(:,2))
coslat = MAX(COS(lalo(maxLon(1),1) * pi/180. ), mincos )*pi/180. * R_Earth
domain_maxlon = lalo(maxLon(1),2) + resolution(maxLon(1),1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
domain_minlat = MINVAL(lalo(:,1)) - resolution(maxLon(1),2)/(2.0*coslat)
domain_maxlat = MAXVAL(lalo(:,1)) + resolution(maxLon(1),2)/(2.0*coslat)
!
IF (check_grid) THEN
WRITE(numout,*) "indices min/max of longitude :",minLon,maxLon
WRITE(numout,*) "Domain for coarse grid :"
WRITE(numout,*) '(',domain_minlat,',',domain_minlon,')',&
& '(',domain_maxlat,',',domain_maxlon,')'
WRITE(numout,*) "================================"
ENDIF
!
! we list a first approximation of all point we will need to
! scan to fill our coarse grid.
!
IF ( domain_minlon <= -179.5 .AND. domain_maxlon >= 179.5 .AND. &
& domain_minlat <= -89.5 .AND. domain_maxlat >= 89.5 ) THEN
! Here we do the entire globe
nbind=0
DO ip=1,iml
DO jp=1,jml
IF (mask(ip,jp) == 1 ) THEN
nbind = nbind + 1
searchind(nbind,1) = ip
searchind(nbind,2) = jp
ENDIF
ENDDO
ENDDO
!
ELSE
! Now we get a limited number of points
nbind=0
DO ip=1,iml
DO jp=1,jml
IF ( loup_rel(ip,jp) >= domain_minlon .AND. lolow_rel(ip,jp) <= domain_maxlon .AND.&
& laup_rel(ip,jp) >= domain_minlat .AND. lalow_rel(ip,jp) <= domain_maxlat ) THEN
IF (mask(ip,jp) == 1 ) THEN
nbind = nbind + 1
searchind(nbind,1) = ip
searchind(nbind,2) = jp
ENDIF
ENDIF
ENDDO
ENDDO
ENDIF
!
WRITE(numout,*) 'We will work with ', nbind, ' points of the fine grid'
!
WRITE(numout,*) 'Aggregate_2d : ', callsign
WRITE(numout,'(2a40)')'0%--------------------------------------', &
& '------------------------------------100%'
!
! Now we take each grid point and find out which values from the forcing we need to average
!
fopt_max = -1
DO ib =1, nbpt
!
! Give a progress meter
!
iprog = NINT(REAL(ib,r_std)/REAL(nbpt,r_std)*79.) - NINT(REAL(ib-1,r_std)/REAL(nbpt,r_std)*79.)
IF ( iprog .NE. 0 ) THEN
WRITE(numout,'(a1,$)') 'x'
ENDIF
!
! We find the 4 limits of the grid-box. As we transform the resolution of the model
! into longitudes and latitudes we do not have the problem of periodicity.
! coslat is a help variable here !
!
coslat = MAX(COS(lalo(ib,1) * pi/180. ), mincos )*pi/180. * R_Earth
!
lon_up = lalo(ib,2) + resolution(ib,1)/(2.0*coslat)
lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
!
lat_up =lalo(ib,1) + resolution(ib,2)/(2.0*coslat)
lat_low =lalo(ib,1) - resolution(ib,2)/(2.0*coslat)
!
! Find the grid boxes from the data that go into the model's boxes
! We still work as if we had a regular grid ! Well it needs to be localy regular so
! so that the longitude at the latitude of the last found point is close to the one
! of the next point.
!
fopt = zero
!
DO i=1,nbind
!
ip = searchind(i,1)
jp = searchind(i,2)
!
! Either the center of the data grid point is in the interval of the model grid or
! the East and West limits of the data grid point are on either sides of the border of
! the data grid.
!
! To do that correctly we have to check if the grid box sits on the date-line.
!
IF ( lon_low < -180.0 ) THEN
! -179 -> -179
! 179 -> -181
lonrel = MOD( lon_rel(ip,jp) - 360.0, 360.0)
lolowrel = MOD( lolow_rel(ip,jp) - 360.0, 360.0)
louprel = MOD( loup_rel(ip,jp) - 360.0, 360.0)
!
ELSE IF ( lon_up > 180.0 ) THEN
! -179 -> 181
! 179 -> 179
lonrel = MOD( lon_rel(ip,jp) + 360., 360.0)
lolowrel = MOD( lolow_rel(ip,jp) + 360., 360.0)
louprel = MOD( loup_rel(ip,jp) + 360., 360.0)
ELSE
lonrel = lon_rel(ip,jp)
lolowrel = lolow_rel(ip,jp)
louprel = loup_rel(ip,jp)
ENDIF
!
!
!
IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
& lolowrel < lon_low .AND. louprel > lon_low .OR. &
& lolowrel < lon_up .AND. louprel > lon_up ) THEN
!
! Now that we have the longitude let us find the latitude
!
IF ( lat_rel(ip,jp) > lat_low .AND. lat_rel(ip,jp) < lat_up .OR. &
& lalow_rel(ip,jp) < lat_low .AND. laup_rel(ip,jp) > lat_low .OR.&
& lalow_rel(ip,jp) < lat_up .AND. laup_rel(ip,jp) > lat_up) THEN
!
fopt = fopt + 1
IF ( fopt > incmax) THEN
WRITE(numout,*) 'Working on variable :', callsign
WRITE(numout,*) 'Reached value ', fopt,' for fopt on point', ib
CALL ipslerr(2,'aggregate_2d', &
'Working on variable :'//callsign, &
'Reached incmax value for fopt.',&
'Please increase incmax in subroutine calling aggregate')
IF (PRESENT(ok)) THEN
ok = .FALSE.
RETURN
ELSE
STOP "aggregate_2d"
ENDIF
ELSE
!
! If we sit on the date line we need to do the same transformations as above.
!
IF ( lon_low < -180.0 ) THEN
lolowrel = MOD( lolow_rel(ip,jp) - 360.0, 360.0)
louprel = MOD( loup_rel(ip,jp) - 360.0, 360.0)
!
ELSE IF ( lon_up > 180.0 ) THEN
lolowrel = MOD( lolow_rel(ip,jp) + 360., 360.0)
louprel = MOD( loup_rel(ip,jp) + 360., 360.0)
ELSE
lolowrel = lolow_rel(ip,jp)
louprel = loup_rel(ip,jp)
ENDIF
!
! Get the area of the fine grid in the model grid
!
coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )
ax = (MIN(lon_up,louprel)-MAX(lon_low, lolowrel))*pi/180. * R_Earth * coslat
ay = (MIN(lat_up, laup_rel(ip,jp))-MAX(lat_low,lalow_rel(ip,jp)))*pi/180. * R_Earth
!
areaoverlap(ib, fopt) = ax*ay
indinc(ib, fopt, 1) = ip
indinc(ib, fopt, 2) = jp
!
! If this point was 100% within the grid then we can de-select it from our
! list as it can not be in another mesh of the coarse grid.
!
IF ( louprel < lon_up .AND. lolowrel > lon_low .AND. &
& laup_rel(ip,jp) < lat_up .AND. lalow_rel(ip,jp) > lat_low ) THEN
searchind(i,1) = 0
searchind(i,2) = 0
ENDIF
!
ENDIF
ENDIF ! IF lat
ENDIF ! IF lon
ENDDO
fopt_max = MAX ( fopt, fopt_max )
!
! De-select the marked points
!
itmp = nbind
nbind = 0
DO i=1,itmp
IF ( searchind(i,1) > 0 .AND. searchind(i,2) > 0 ) THEN
nbind = nbind + 1
searchind(nbind,1) = searchind(i,1)
searchind(nbind,2) = searchind(i,2)
ENDIF
ENDDO
!
ENDDO
WRITE(numout,*) ""
WRITE(numout,*) "aggregate_2D nbvmax = ",incmax, "max used = ",fopt_max
!
! Do some memory management.
!
DEALLOCATE (laup_rel)
DEALLOCATE (loup_rel)
DEALLOCATE (lalow_rel)
DEALLOCATE (lolow_rel)
DEALLOCATE (lat_ful)
DEALLOCATE (lon_ful)
DEALLOCATE (searchind)
!
! Close the progress meter
!
WRITE(numout,*) ' '
!
END SUBROUTINE aggregate_2d
!
! This routing will get for each point of the coarse grid the
! indexes of the finer grid and the area of overlap.
! This routine is designed for a fine grid which is regular in meters along lat lon axes.
!
SUBROUTINE aggregate_vec (nbpt, lalo, neighbours, resolution, contfrac, &
& iml, lon_rel, lat_rel, resol_lon, resol_lat, callsign, &
& incmax, indinc, areaoverlap, ok)
!
! INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box.
INTEGER(i_std), INTENT(in) :: iml ! Size of the finer grid
REAL(r_std), INTENT(in) :: lon_rel(iml) ! Longitudes for the finer grid
REAL(r_std), INTENT(in) :: lat_rel(iml) ! Latitudes for the finer grid
REAL(r_std), INTENT(in) :: resol_lon, resol_lat ! Resolution in meters of the fine grid
CHARACTER(LEN=*), INTENT(in) :: callsign ! Allows to specify which variable is beeing treated
INTEGER(i_std), INTENT(in) :: incmax ! Maximum point of the fine grid we can store.
!
! Output
!
INTEGER(i_std), INTENT(out) :: indinc(nbpt,incmax)
REAL(r_std), INTENT(out) :: areaoverlap(nbpt,incmax)
LOGICAL, OPTIONAL, INTENT(out) :: ok ! return code
!
! Local Variables
!
INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: searchind
REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
REAL(r_std) :: coslat, ax, ay, lonrel, lolowrel, louprel
REAL(r_std) :: latrel, lauprel, lalowrel
INTEGER(i_std), DIMENSION(nbpt) :: fopt
INTEGER(i_std) :: fopt_max
INTEGER(i_std) :: ip, ib, i, j, itmp, iprog, nbind
REAL(r_std) :: domain_minlon,domain_maxlon,domain_minlat,domain_maxlat
INTEGER(i_std) :: ff(1)
LOGICAL :: found
!
! Some inital assignmens
!
areaoverlap(:,:) = moins_un
indinc(:,:) = zero
!
ALLOCATE (searchind(iml))
!
IF (PRESENT(ok)) ok = .TRUE.
!
! To speedup calculations we will get the limits of the domain of the
! coarse grid and select all the points of the fine grid which are potentialy
! in this domain.
!
!
ff = MINLOC(lalo(:,2))
coslat = MAX(COS(lalo(ff(1),1) * pi/180. ), mincos )*pi/180. * R_Earth
domain_minlon = lalo(ff(1),2) - resolution(ff(1),1)/(2.0*coslat)
ff = MAXLOC(lalo(:,2))
coslat = MAX(COS(lalo(ff(1),1) * pi/180. ), mincos )*pi/180. * R_Earth
domain_maxlon = lalo(ff(1),2) + resolution(ff(1),1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
domain_minlat = MINVAL(lalo(:,1)) - resolution(ff(1),2)/(2.0*coslat)
domain_maxlat = MAXVAL(lalo(:,1)) + resolution(ff(1),2)/(2.0*coslat)
!
! we list a first approximation of all point we will need to
! scan to fill our coarse grid.
!
IF ( domain_minlon <= -179.5 .AND. domain_maxlon >= 179.5 .AND. &
& domain_minlat <= -89.5 .AND. domain_maxlat >= 89.5 ) THEN
! Here we do the entire globe
nbind=0
DO ip=1,iml
nbind = nbind + 1
searchind(nbind) = ip
ENDDO
!
ELSE
! Now we get a limited number of points
nbind=0
DO ip=1,iml
! Compute the limits of the meshes of the fine grid
coslat = MAX(COS(lat_rel(ip) * pi/180. ), mincos )*pi/180. * R_Earth
louprel = lon_rel(ip) + resol_lon/(2.0*coslat)
lolowrel = lon_rel(ip) - resol_lon/(2.0*coslat)
coslat = pi/180. * R_Earth
lauprel = lat_rel(ip) + resol_lat/(2.0*coslat)
lalowrel = lat_rel(ip) - resol_lat/(2.0*coslat)
!
IF ( louprel >= domain_minlon .AND. lolowrel <= domain_maxlon .AND.&
& lauprel >= domain_minlat .AND. lalowrel <= domain_maxlat ) THEN
nbind = nbind + 1
searchind(nbind) = ip
ENDIF
ENDDO
ENDIF
!
WRITE(numout,*) 'We will work with ', nbind, ' points of the fine grid'
!
WRITE(numout,*) 'Aggregate_vec : ', callsign
WRITE(numout,'(2a40)')'0%--------------------------------------', &
& '------------------------------------100%'
!
! Now we take each grid point and find out which values from the forcing we need to average
!
fopt(:) = zero
fopt_max = -1
!
! We select here the case which is fastest, i.e. when the smaller loop is inside
!
IF ( nbpt > nbind ) THEN
!
DO ib =1, nbpt
!
! Give a progress meter
!
iprog = NINT(REAL(ib,r_std)/REAL(nbpt,r_std)*79.) - NINT(REAL(ib-1,r_std)/REAL(nbpt,r_std)*79.)
IF ( iprog .NE. 0 ) THEN
WRITE(numout,'(a1,$)') 'x'
ENDIF
!
! We find the 4 limits of the grid-box. As we transform the resolution of the model
! into longitudes and latitudes we do not have the problem of periodicity.
! coslat is a help variable here !
!
coslat = MAX(COS(lalo(ib,1) * pi/180. ), mincos )*pi/180. * R_Earth
!
lon_up = lalo(ib,2) + resolution(ib,1)/(2.0*coslat)
lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
!
lat_up =lalo(ib,1) + resolution(ib,2)/(2.0*coslat)
lat_low =lalo(ib,1) - resolution(ib,2)/(2.0*coslat)
!
! Find the grid boxes from the data that go into the model's boxes
! We still work as if we had a regular grid ! Well it needs to be localy regular so
! so that the longitude at the latitude of the last found point is close to the one
! of the next point.
!
DO i=1,nbind
!
ip = searchind(i)
!
! Either the center of the data grid point is in the interval of the model grid or
! the East and West limits of the data grid point are on either sides of the border of
! the data grid.
!
lonrel = lon_rel(ip)
coslat = MAX(COS(lat_rel(ip) * pi/180. ), mincos )*pi/180. * R_Earth
louprel = lon_rel(ip) + resol_lon/(2.0*coslat)
lolowrel = lon_rel(ip) - resol_lon/(2.0*coslat)
!
latrel = lat_rel(ip)
coslat = pi/180. * R_Earth
lauprel = lat_rel(ip) + resol_lat/(2.0*coslat)
lalowrel = lat_rel(ip) - resol_lat/(2.0*coslat)
!
!
IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
& lolowrel < lon_low .AND. louprel > lon_low .OR. &
& lolowrel < lon_up .AND. louprel > lon_up ) THEN
!
! Now that we have the longitude let us find the latitude
!
IF ( latrel > lat_low .AND. latrel < lat_up .OR. &
& lalowrel < lat_low .AND. lauprel > lat_low .OR.&
& lalowrel < lat_up .AND. lauprel > lat_up) THEN
!
fopt(ib) = fopt(ib) + 1
fopt_max = MAX ( fopt(ib), fopt_max )
IF ( fopt(ib) > incmax) THEN
WRITE(numout,*) 'Reached value ', fopt(ib),' for fopt on point', ib
CALL ipslerr(2,'aggregate_vec (nbpt > nbind)', &
'Working on variable :'//callsign, &
'Reached incmax value for fopt.',&
'Please increase incmax in subroutine calling aggregate')
IF (PRESENT(ok)) THEN
ok = .FALSE.
RETURN
ELSE
STOP "aggregate_vec"
ENDIF
ELSE
!
! Get the area of the fine grid in the model grid
!
coslat = MAX( COS( lat_rel(ip) * pi/180. ), mincos )
ax = (MIN(lon_up,louprel)-MAX(lon_low, lolowrel))*pi/180. * R_Earth * coslat
ay = (MIN(lat_up, lauprel)-MAX(lat_low,lalowrel))*pi/180. * R_Earth
!
areaoverlap(ib, fopt(ib)) = ax*ay
indinc(ib, fopt(ib)) = ip
!
! If this point was 100% within the grid then we can de-select it from our
! list as it can not be in another mesh of the coarse grid.
!
IF ( louprel < lon_up .AND. lolowrel > lon_low .AND. &
& lauprel < lat_up .AND. lalowrel > lat_low ) THEN
searchind(i) = 0
ENDIF
!
ENDIF
ENDIF ! IF lat
ENDIF ! IF lon
ENDDO
!
! De-select the marked points
!
itmp = nbind
nbind = 0
DO i=1,itmp
IF ( searchind(i) > 0 ) THEN
nbind = nbind + 1
searchind(nbind) = searchind(i)
ENDIF
ENDDO
!
ENDDO
!
ELSE
!
ib = 1
!
DO i=1,nbind
!
!
! Give a progress meter
!
iprog = NINT(REAL(i,r_std)/REAL(nbind,r_std)*79.) - NINT(REAL(i-1,r_std)/REAL(nbind,r_std)*79.)
IF ( iprog .NE. 0 ) THEN
WRITE(numout,'(a1,$)') 'y'
ENDIF
!
ip = searchind(i)
!
! Either the center of the data grid point is in the interval of the model grid or
! the East and West limits of the data grid point are on either sides of the border of
! the data grid.
!
lonrel = lon_rel(ip)
coslat = MAX(COS(lat_rel(ip) * pi/180. ), mincos )*pi/180. * R_Earth
louprel = lon_rel(ip) + resol_lon/(2.0*coslat)
lolowrel = lon_rel(ip) - resol_lon/(2.0*coslat)
!
latrel = lat_rel(ip)
coslat = pi/180. * R_Earth
lauprel = lat_rel(ip) + resol_lat/(2.0*coslat)
lalowrel = lat_rel(ip) - resol_lat/(2.0*coslat)
!
!
found = .FALSE.
j = 1
!
DO WHILE ( .NOT. found .AND. j <= nbpt )
! Just count the number of time we were through
j = j+1
!
! We find the 4 limits of the grid-box. As we transform the resolution of the model
! into longitudes and latitudes we do not have the problem of periodicity.
! coslat is a help variable here !
!
coslat = MAX(COS(lalo(ib,1) * pi/180. ), mincos )*pi/180. * R_Earth
!
lon_up = lalo(ib,2) + resolution(ib,1)/(2.0*coslat)
lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
!
lat_up =lalo(ib,1) + resolution(ib,2)/(2.0*coslat)
lat_low =lalo(ib,1) - resolution(ib,2)/(2.0*coslat)
!
IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
& lolowrel < lon_low .AND. louprel > lon_low .OR. &
& lolowrel < lon_up .AND. louprel > lon_up ) THEN
!
! Now that we have the longitude let us find the latitude
!
IF ( latrel > lat_low .AND. latrel < lat_up .OR. &
& lalowrel < lat_low .AND. lauprel > lat_low .OR.&
& lalowrel < lat_up .AND. lauprel > lat_up) THEN
!
fopt(ib) = fopt(ib) + 1
fopt_max = MAX ( fopt(ib), fopt_max )
IF ( fopt(ib) > incmax) THEN
WRITE(numout,*) 'Reached value ', fopt(ib),' for fopt on point', ib
CALL ipslerr(2,'aggregate_vec (nbpt < nbind)', &
'Working on variable :'//callsign, &
'Reached incmax value for fopt.',&
'Please increase incmax in subroutine calling aggregate')
IF (PRESENT(ok)) THEN
ok = .FALSE.
RETURN
ELSE
STOP "aggregate_vec"
ENDIF
ELSE
!
! Get the area of the fine grid in the model grid
!
coslat = MAX( COS( lat_rel(ip) * pi/180. ), mincos )
ax = (MIN(lon_up,louprel)-MAX(lon_low,lolowrel))*pi/180. * R_Earth * coslat
ay = (MIN(lat_up,lauprel)-MAX(lat_low,lalowrel))*pi/180. * R_Earth
!
areaoverlap(ib, fopt(ib)) = ax*ay
indinc(ib, fopt(ib)) = ip
found = .TRUE.
!
ENDIF
ENDIF ! IF lat
ENDIF ! IF lon
!
IF ( .NOT. found ) THEN
! We need to step on in the coarse grid
ib = ib + 1
IF ( ib > nbpt ) ib = ib-nbpt
!
ENDIF
ENDDO ! While loop
ENDDO
ENDIF
WRITE(numout,*)
WRITE(numout,*) "aggregate_vec nbvmax = ",incmax, "max used = ",fopt_max
!
! Do some memory management.
!
DEALLOCATE (searchind)
!
! Close the progress meter
!
WRITE(numout,*) ' '
!
END SUBROUTINE aggregate_vec
!
!
SUBROUTINE aggregate_vec_p(nbpt, lalo, neighbours, resolution, contfrac, &
& iml, lon_ful, lat_ful, resol_lon, resol_lat, callsign, &
& nbvmax, sub_index, sub_area, ok)
IMPLICIT NONE
INTEGER(i_std), INTENT(in) :: nbpt
REAL(r_std), INTENT(in) :: lalo(nbpt,2)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8)
REAL(r_std), INTENT(in) :: resolution(nbpt,2)
REAL(r_std), INTENT(in) :: contfrac(nbpt)
INTEGER(i_std), INTENT(in) :: iml
REAL(r_std), INTENT(in) :: lon_ful(iml)
REAL(r_std), INTENT(in) :: lat_ful(iml)
REAL(r_std), INTENT(in) :: resol_lon, resol_lat
CHARACTER(LEN=*), INTENT(in) :: callsign
INTEGER(i_std), INTENT(in) :: nbvmax
INTEGER(i_std), INTENT(out) :: sub_index(nbpt,nbvmax)
REAL(r_std), INTENT(out) :: sub_area(nbpt,nbvmax)
LOGICAL, OPTIONAL, INTENT(out) :: ok ! return code
INTEGER(i_std) :: sub_index_g(nbp_glo,nbvmax)
REAL(r_std) :: sub_area_g(nbp_glo,nbvmax)
IF (is_root_prc) CALL aggregate(nbp_glo, lalo_g, neighbours_g, resolution_g, contfrac_g, &
& iml, lon_ful, lat_ful, resol_lon, resol_lat, callsign, &
& nbvmax, sub_index_g, sub_area_g, ok)
CALL BCAST(ok)
CALL scatter(sub_index_g,sub_index)
CALL scatter(sub_area_g,sub_area)
END SUBROUTINE aggregate_vec_p
SUBROUTINE aggregate_2d_p(nbpt, lalo, neighbours, resolution, contfrac, &
& iml, jml, lon_ful, lat_ful, mask, callsign, &
& nbvmax, sub_index, sub_area, ok)
IMPLICIT NONE
INTEGER(i_std), INTENT(in) :: nbpt
REAL(r_std), INTENT(in) :: lalo(nbpt,2)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8)
REAL(r_std), INTENT(in) :: resolution(nbpt,2)
REAL(r_std), INTENT(in) :: contfrac(nbpt)
INTEGER(i_std), INTENT(in) :: iml,jml
REAL(r_std), INTENT(in) :: lon_ful(iml,jml)
REAL(r_std), INTENT(in) :: lat_ful(iml,jml)
INTEGER(i_std), INTENT(in) :: mask(iml, jml)
CHARACTER(LEN=*), INTENT(in) :: callsign
INTEGER(i_std), INTENT(in) :: nbvmax
INTEGER(i_std), INTENT(out) :: sub_index(nbpt,nbvmax,2)
REAL(r_std), INTENT(out) :: sub_area(nbpt,nbvmax)
LOGICAL, OPTIONAL, INTENT(out) :: ok ! return code
INTEGER(i_std) :: sub_index_g(nbp_glo,nbvmax,2)
REAL(r_std) :: sub_area_g(nbp_glo,nbvmax)
IF (is_root_prc) CALL aggregate_2d(nbp_glo, lalo_g, neighbours_g, resolution_g, contfrac_g, &
& iml, jml, lon_ful, lat_ful, mask, callsign, &
& nbvmax, sub_index_g, sub_area_g, ok)
CALL BCAST(ok)
CALL scatter(sub_index_g,sub_index)
CALL scatter(sub_area_g,sub_area)
END SUBROUTINE aggregate_2d_p
!
END MODULE interpol_help
ORCHIDEE/src_global/Makefile 0000754 0103600 0005670 00000003551 11164403473 015500 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.2 2008/01/08 11:49:07 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a ORGLOB
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/liborglob.a
SXMODEL_LIB = $(MODEL_LIB)
#-
#- $Id: AA_make.gdef 578 2009-03-13 14:05:38Z bellier $
#-
#- Global definitions for gnu g95 compiler
M_K = gmake
P_C = cpp
P_O = -P -C -traditional $(P_P)
F_C = g95 -c
F_D =
F_P = -i4 -r8
w_w = -O5 -cpp -funroll-all-loops $(F_D) $(F_P) -I$(MODDIR)
#####################################-Q- g95 F_O = $(w_w) -fmod=$(MODDIR) -fno-second-underscore
F_O = $(w_w) -fmod=$(MODDIR)
F_L = g95
M_M = 0
L_X = 0
L_O =
A_C = ar -r
A_G = ar -x
C_C = cc -c
C_O =
C_L = cc
#-
NCDF_INC = /d4/acamlmd/LMDZ4V4/netcdf-3.6.1/include
NCDF_LIB = -L/d4/acamlmd/LMDZ4V4/netcdf-3.6.1/lib -lnetcdf
#-
RM = rm -f
STRIP = strip
SIZE = size
#-
#- $Id: AA_make,v 1.4 2008/01/08 11:49:07 ssipsl Exp $
#-
PARAM_LIB = $(LIBDIR)/libparameters.a
SXPARAM_LIB = $(PARAM_LIB)
#-
MODS1 = grid.f90 \
interpol_help.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-
all:
$(M_K) libparameters
$(M_K) m_all
@echo orglob is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
libparameters:
(cd ../src_parameters; $(M_K) -f Makefile)
$(MODEL_LIB)(%.o) : %.f90
$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
$(A_C) $(MODEL_LIB) $*.o
$(RM) $*.o
config :
$(BINDIR)/Fparser -name ORGLOB $(MODS1)
echo 'Configuration of ORGLOB done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(grid.o): \
$(PARAM_LIB)(constantes.o)
$(MODEL_LIB)(interpol_help.o): \
$(PARAM_LIB)(constantes_veg.o)
ORCHIDEE/src_parallel/ 0000754 0103600 0005670 00000000000 11200051615 014351 5 ustar acamlmd lmdjus ORCHIDEE/src_parallel/CVS/ 0000754 0103600 0005670 00000000000 11164403473 015020 5 ustar acamlmd lmdjus ORCHIDEE/src_parallel/CVS/Root 0000754 0103600 0005670 00000000071 11164403473 015667 0 ustar acamlmd lmdjus :pserver:sechiba@cvs.ipsl.jussieu.fr:/home/ssipsl/CVSREP
ORCHIDEE/src_parallel/CVS/Repository 0000754 0103600 0005670 00000000026 11164403473 017123 0 ustar acamlmd lmdjus ORCHIDEE/src_parallel
ORCHIDEE/src_parallel/CVS/Entries 0000754 0103600 0005670 00000001551 11164403473 016361 0 ustar acamlmd lmdjus /AA_make/1.5/Tue Jan 8 11:49:07 2008//Torchidee_1_9_2
/AA_make.ldef/1.3/Tue Jan 8 11:49:07 2008//Torchidee_1_9_2
/data_para.f90/1.4/Wed Apr 2 13:02:25 2008//Torchidee_1_9_2
/ioipsl_para.f90/1.4/Tue Jan 8 11:52:35 2008//Torchidee_1_9_2
/mpi_dummy.h/1.2/Tue Jun 12 08:04:26 2007//Torchidee_1_9_2
/orch_write_field.f90/1.3/Fri Sep 21 14:13:21 2007//Torchidee_1_9_2
/orch_write_field_p.f90/1.3/Fri Sep 21 14:13:21 2007//Torchidee_1_9_2
/parallel.f90/1.2/Tue Jun 12 08:04:26 2007//Torchidee_1_9_2
/src_parallel.h/1.2/Tue Jun 12 08:04:26 2007//Torchidee_1_9_2
/timer.f90/1.2/Tue Jun 12 08:04:26 2007//Torchidee_1_9_2
/tools_para.f90/1.2/Tue Jun 12 08:04:26 2007//Torchidee_1_9_2
/transfert_para.f90/1.5/Thu Oct 18 12:56:33 2007//Torchidee_1_9_2
/write_field.f90/1.2/Tue Jun 12 08:04:26 2007//Torchidee_1_9_2
/write_field_p.f90/1.2/Tue Jun 12 08:04:26 2007//Torchidee_1_9_2
D
ORCHIDEE/src_parallel/CVS/Tag 0000754 0103600 0005670 00000000020 11164403473 015451 0 ustar acamlmd lmdjus Norchidee_1_9_2
ORCHIDEE/src_parallel/CVS/Template 0000754 0103600 0005670 00000000000 11164403473 016507 0 ustar acamlmd lmdjus ORCHIDEE/src_parallel/AA_make 0000754 0103600 0005670 00000004266 11164403473 015601 0 ustar acamlmd lmdjus #-
#- $Id: AA_make,v 1.5 2008/01/08 11:49:07 ssipsl Exp $
#-
MODS1 = timer.f90 \
data_para.f90 \
transfert_para.f90 \
ioipsl_para.f90 \
tools_para.f90 \
parallel.f90
#\
# orch_write_field.f90 \
# write_field.f90 \
# orch_write_field_p.f90\
# write_field_p.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-Q- sxnec .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
#-
all:
$(M_K) m_all
@echo parallel is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
#-Q- intel m_all: WORK_MOD $(MODEL_LIB)($(OBJSMODS1))
$(MODEL_LIB)(%.o) : %.f90
$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
$(A_C) $(MODEL_LIB) $*.o
#-Q- sxnec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sxnec mv $*.mod $(MODDIR)
#-Q- sx6nec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx6nec mv $*.mod $(MODDIR)
#-Q- eshpux $(A_X) $(SXMODEL_LIB) $*.o
#-Q- eshpux mv $*.mod $(MODDIR)
#-Q- sx8mercure mv $*.mod $(MODDIR)
#-Q- sx8brodie $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx8brodie mv $*.mod $(MODDIR)
#-Q- solaris mv $*.mod $(MODDIR)
$(RM) $*.o
#-Q- intel
#-Q- intel WORK_MOD :
#-Q- intel $(RM) work.pcl
#-Q- intel @echo "work.pc" > work.pcl
#-Q- intel @echo "../src_parameters/work.pc" >> work.pcl
#-Q- intel @echo "../src_stomate/work.pc" >> work.pcl
#-Q- intel @echo "../../IOIPSL/src/work.pc" >> work.pcl
config :
$(BINDIR)/Fparser -name PARALLEL $(MODS1)
echo 'Configuration of PARALLEL done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(mpi_dummy.o):
$(MODEL_LIB)(timer.o):
$(MODEL_LIB)(data_para.o):
$(MODEL_LIB)(orch_write_field.o):
$(MODEL_LIB)(write_field_p.o): \
$(MODEL_LIB)(orch_write_field.o)
$(MODEL_LIB)(transfert_para.o): \
$(MODEL_LIB)(timer.o) \
$(MODEL_LIB)(data_para.o) \
$(MODEL_LIB)(ioipsl_para.o): \
$(MODEL_LIB)(transfert_para.o) \
$(MODEL_LIB)(data_para.o)
$(MODEL_LIB)(tools_para.o): \
$(MODEL_LIB)(timer.o) \
$(MODEL_LIB)(data_para.o)
$(MODEL_LIB)(orch_write_field_p.o): \
$(MODEL_LIB)(parallel.o)
$(MODEL_LIB)(write_field_p.o): \
$(MODEL_LIB)(parallel.o) \
$(MODEL_LIB)(orch_write_field_p.o)
$(MODEL_LIB)(parallel.o): \
$(MODEL_LIB)(data_para.o) \
$(MODEL_LIB)(transfert_para.o) \
$(MODEL_LIB)(ioipsl_para.o)
ORCHIDEE/src_parallel/AA_make.ldef 0000754 0103600 0005670 00000001370 11164403473 016503 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.3 2008/01/08 11:49:07 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a PARALLEL
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
ORDIR = ..
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/libparallel.a
SXMODEL_LIB = $(MODEL_LIB)
#-Q- sxnec SXMODEL_LIB = $(LIBDIR)/libsxparallel.a
#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxparallel.a
#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxparallel.a
#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxparallel.a
ORCHIDEE/src_parallel/data_para.f90 0000754 0103600 0005670 00000036653 11164403473 016641 0 ustar acamlmd lmdjus ! Definition and allocation of parallel datas.
! Initialization of parallel or sequentiel IOs.
! Definition of Load Balancing functions.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/data_para.f90,v 1.4 2008/04/02 13:02:25 ssipsl Exp $
!-
MODULE data_para
!-
USE defprec
USE constantes
USE ioipsl
!-
#include "src_parallel.h"
!-
INTEGER, SAVE :: mpi_size !! Number of parallel processes
INTEGER, SAVE :: mpi_rank !! my rank num
INTEGER, SAVE :: root_prc !! rank of root proc
LOGICAL, SAVE :: is_root_prc !! Only root proc is true
INTEGER, SAVE :: nbp_loc !! number of local continental points
INTEGER, SAVE :: nbp_glo !! number of global continental points
INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: nbp_para_nb
INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: nbp_para_begin
INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: nbp_para_end
INTEGER,SAVE :: iim_g, jjm_g !! Dimension of global fields
INTEGER,SAVE,allocatable,dimension(:) :: jj_para_nb
INTEGER,SAVE,allocatable,dimension(:) :: jj_para_begin
INTEGER,SAVE,allocatable,dimension(:) :: jj_para_end
INTEGER,SAVE,allocatable,dimension(:) :: ii_para_begin
INTEGER,SAVE,allocatable,dimension(:) :: ii_para_end
INTEGER,SAVE,allocatable,dimension(:) :: ij_para_nb
INTEGER,SAVE,allocatable,dimension(:) :: ij_para_begin
INTEGER,SAVE,allocatable,dimension(:) :: ij_para_end
INTEGER,SAVE :: ii_begin
INTEGER,SAVE :: ii_end
INTEGER,SAVE :: jj_begin
INTEGER,SAVE :: jj_end
INTEGER,SAVE :: jj_nb
INTEGER,SAVE :: ij_begin
INTEGER,SAVE :: ij_end
INTEGER,SAVE :: ij_nb
!! Global array used by stomate and sechiba
!-
!! index of land points on the 2D map
INTEGER(i_std),ALLOCATABLE,DIMENSION(:),SAVE :: index_g
!-
!! indices of the 4 neighbours of each grid point (1=N, 2=E, 3=S, 4=W)
INTEGER(i_std),ALLOCATABLE,DIMENSION(:,:),SAVE :: neighbours_g
!-
!! resolution at each grid point in m (1=E-W, 2=N-S)
REAL(r_std),ALLOCATABLE,DIMENSION(:,:),SAVE :: resolution_g
REAL(r_std),ALLOCATABLE,DIMENSION(:),SAVE :: area_g
!-
!! Geographical coordinates
REAL(r_std),ALLOCATABLE,DIMENSION(:,:),SAVE :: lalo_g
! Global grid, for all process
REAL(r_std), ALLOCATABLE, DIMENSION(:,:), SAVE :: lon_g, lat_g, zlev_g
!-
!! Fraction of continents
REAL(r_std),ALLOCATABLE,DIMENSION(:),SAVE :: contfrac_g
INTEGER, SAVE :: MPI_COMM_ORCH
INTEGER, SAVE :: MPI_REAL_ORCH
INTEGER, SAVE :: MPI_INT_ORCH
LOGICAL, SAVE :: cpl_lmdz
INTEGER, SAVE :: orch_domain_id
CONTAINS
SUBROUTINE init_para(cpl_lmdz_x, communicator)
IMPLICIT NONE
#ifdef CPP_PARA
INCLUDE 'mpif.h'
#endif
LOGICAL :: cpl_lmdz_x
INTEGER,OPTIONAL :: communicator
INTEGER :: ierr
CHARACTER(LEN=20) :: filename
INTEGER :: i, div
CHARACTER(LEN=4) :: num
LOGICAL, PARAMETER :: check = .FALSE.
cpl_lmdz=cpl_lmdz_x
#ifdef CPP_PARA
! Orchidee communicator :
IF (.NOT. cpl_lmdz) THEN
CALL MPI_INIT(ierr)
IF (ierr /= 0) THEN
WRITE(*,*) 'INIT_PARA : MPI_INIT failed with ',ierr
STOP "INIT_PARA"
ENDIF
MPI_COMM_ORCH=MPI_COMM_WORLD
ELSE
MPI_COMM_ORCH=communicator
ENDIF
! Int and real precision
IF (MPI_VERSION == 1) THEN
! Version MPI 1.x
IF (i_std==i_4) THEN
MPI_INT_ORCH=MPI_INTEGER
ELSEIF (i_std==i_8) THEN
MPI_INT_ORCH=MPI_INTEGER
ELSE
MPI_INT_ORCH=MPI_INTEGER
ENDIF
IF (r_std==r_4) THEN
MPI_REAL_ORCH=MPI_REAL
ELSEIF (r_std==r_8) THEN
MPI_REAL_ORCH=MPI_DOUBLE_PRECISION
ELSE
MPI_REAL_ORCH=MPI_REAL
ENDIF
ELSE
! Others MPI
IF (i_std==i_4) THEN
MPI_INT_ORCH=MPI_INTEGER4
ELSEIF (i_std==i_8) THEN
MPI_INT_ORCH=MPI_INTEGER8
ELSE
MPI_INT_ORCH=MPI_INTEGER
ENDIF
IF (r_std==r_4) THEN
MPI_REAL_ORCH=MPI_REAL4
ELSEIF (r_std==r_8) THEN
MPI_REAL_ORCH=MPI_REAL8
ELSE
MPI_REAL_ORCH=MPI_REAL
ENDIF
ENDIF
CALL MPI_COMM_SIZE(MPI_COMM_ORCH,mpi_size,ierr)
IF (ierr /= 0) THEN
WRITE(*,*) 'INIT_PARA : MPI_COMM_SIZE failed with ',ierr
STOP "INIT_PARA"
ENDIF
CALL MPI_COMM_RANK(MPI_COMM_ORCH,mpi_rank,ierr)
IF (ierr /= 0) THEN
WRITE(*,*) 'INIT_PARA : MPI_COMM_RANK failed with ',ierr
STOP "INIT_PARA"
ENDIF
#else
mpi_rank=0
mpi_size=1
#endif
root_prc=0
IF (mpi_rank==0) THEN
is_root_prc=.TRUE.
ELSE
is_root_prc=.FALSE.
ENDIF
! Open mpi_rank outputs or select stdout
IF (mpi_size > 1) THEN
write(num,'(I4)') mpi_rank
div=1000
DO i=1,3
IF (mpi_rank/1000==0) THEN
num(i:i)='0'
div=div/10
ELSE
exit
ENDIF
ENDDO
numout = 100
filename = 'out_orchidee_'//num
OPEN(UNIT=numout,FILE=trim(filename),STATUS='unknown',FORM='formatted',IOSTAT=ierr)
IF (ierr /= 0) THEN
#ifdef CPP_PARA
CALL MPI_FINALIZE(ierr)
#endif
WRITE(*,*) "Erreur can't open file ", filename
STOP "INIT_PARA"
ENDIF
ELSE
numout = 6
ENDIF
IF (check) THEN
#ifdef CPP_PARA
WRITE(numout,*) 'version MPI ', MPI_VERSION, MPI_SUBVERSION
WRITE(numout,*) 'INTEGERS ',MPI_INTEGER4,MPI_INTEGER8,MPI_INTEGER,MPI_INT_ORCH
WRITE(numout,*) 'REALS ',MPI_REAL4,MPI_REAL8,MPI_REAL,MPI_REAL_ORCH
#endif
WRITE(numout,*) 'RANK ',mpi_rank,' SIZE ',mpi_size
WRITE(numout,*) "Am I root process ?",is_root_prc
WRITE(numout,*) "Init_para : For process number ",mpi_rank, "output file = ",filename
ENDIF
END SUBROUTINE init_para
SUBROUTINE init_data_para(iim,jjm,nbpoints,index_x)
USE constantes
IMPLICIT NONE
#ifdef CPP_PARA
INCLUDE 'mpif.h'
#endif
INTEGER,INTENT(IN) :: iim
INTEGER,INTENT(IN) :: jjm
INTEGER,INTENT(IN) :: nbpoints
INTEGER,INTENT(IN) :: index_x(nbpoints)
INTEGER,ALLOCATABLE, dimension(:) :: index_l
INTEGER,ALLOCATABLE,DIMENSION(:) :: displs
#ifdef CPP_PARA
INTEGER :: ierr
#endif
INTEGER :: i
LOGICAL, PARAMETER :: check=.FALSE.
IF (check) WRITE(numout,*) 'INIT_DATA_PARA',iim,jjm,nbpoints,index_x
ALLOCATE(nbp_para_nb(0:mpi_size-1))
ALLOCATE(nbp_para_begin(0:mpi_size-1))
ALLOCATE(nbp_para_end(0:mpi_size-1))
ALLOCATE(jj_para_nb(0:mpi_size-1))
ALLOCATE(jj_para_begin(0:mpi_size-1))
ALLOCATE(jj_para_end(0:mpi_size-1))
ALLOCATE(ii_para_begin(0:mpi_size-1))
ALLOCATE(ii_para_end(0:mpi_size-1))
ALLOCATE(ij_para_nb(0:mpi_size-1))
ALLOCATE(ij_para_begin(0:mpi_size-1))
ALLOCATE(ij_para_end(0:mpi_size-1))
IF (cpl_lmdz) THEN
#ifdef CPP_PARA
CALL MPI_GATHER(nbpoints,1,MPI_INT_ORCH,nbp_para_nb,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
#else
nbp_para_nb(0)=nbpoints
#endif
IF (is_root_prc) THEN
nbp_glo=sum(nbp_para_nb)
ALLOCATE(displs(0:mpi_size-1))
ALLOCATE(index_l(nbp_glo))
displs(0)=0
DO i=1,mpi_size-1
displs(i)=displs(i-1)+nbp_para_nb(i-1)
ENDDO
ENDIF
#ifdef CPP_PARA
CALL MPI_BCAST(nbp_glo,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_GATHERV(index_x,nbpoints,MPI_INT_ORCH,index_l,nbp_para_nb,displs,&
MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
#else
! if not parallized, nb_glo=nbpoints=nbp_para_nb
IF (is_root_prc) index_l(:)=index_x(1:nbp_glo)
#endif
ELSE
IF (is_root_prc) THEN
nbp_glo=nbpoints
ALLOCATE(index_l(nbp_glo))
index_l(:)=index_x(1:nbp_glo)
CALL Read_Load_Balance(nbpoints,nbp_para_nb)
ENDIF
ENDIF
IF (is_root_prc) THEN
IF (check) WRITE(numout,*) '==== DISTRIB ====',nbpoints,nbp_para_nb
nbp_para_begin(0)=1
nbp_para_end(0)=nbp_para_nb(0)
DO i=1,mpi_size-1
nbp_para_begin(i)=nbp_para_end(i-1)+1
nbp_para_end(i)=nbp_para_begin(i)+nbp_para_nb(i)-1
ENDDO
nbp_loc=nbp_para_nb(mpi_rank)
iim_g=iim
jjm_g=jjm
ij_para_begin(0)=1
ij_para_end(0)=index_l(nbp_para_end(0))
ij_para_nb(0)=ij_para_end(0)-ij_para_begin(0)+1
DO i=1,mpi_size-1
ij_para_begin(i)=ij_para_end(i-1)+1
ij_para_end(i)=index_l(nbp_para_end(i))
ij_para_nb(i)=ij_para_end(i)-ij_para_begin(i)+1
ENDDO
ij_para_end(mpi_size-1)=iim*jjm
ij_para_nb(mpi_size-1)=ij_para_end(mpi_size-1)-ij_para_begin(mpi_size-1)+1
DO i=0,mpi_size-1
jj_para_begin(i)=(ij_para_begin(i)-1)/iim + 1
jj_para_end(i)=(ij_para_end(i)-1)/iim + 1
jj_para_nb(i)=jj_para_end(i)-jj_para_begin(i)+1
ii_para_begin(i)=MOD(ij_para_begin(i)-1,iim)+1
ii_para_end(i)=MOD(ij_para_end(i)-1,iim)+1
ENDDO
IF (check) THEN
WRITE(numout,*) '==== DECOUP ===='
WRITE(numout,*) 'nbp_para_begin=',nbp_para_begin
WRITE(numout,*) 'nbp_para_end =',nbp_para_end
WRITE(numout,*) 'nbp_loc=',nbp_loc
WRITE(numout,*) 'ij_para_begin=',ij_para_begin
WRITE(numout,*) 'ij_para_end=',ij_para_end
WRITE(numout,*) 'ij_para_nb=',ij_para_nb
WRITE(numout,*) 'jj_para_begin=',jj_para_begin
WRITE(numout,*) 'jj_para_end=',jj_para_end
WRITE(numout,*) 'jj_para_nb=',jj_para_nb
WRITE(numout,*) 'ii_para_begin=',ii_para_begin
WRITE(numout,*) 'ii_para_end=',ii_para_end
ENDIF
!
!- Root need the global variables
!-
ALLOCATE(resolution_g(nbp_glo,2),area_g(nbp_glo),lalo_g(nbp_glo,2))
ALLOCATE(neighbours_g(nbp_glo,8),contfrac_g(nbp_glo),index_g(nbp_glo))
ALLOCATE(lon_g(iim_g, jjm_g), lat_g(iim_g, jjm_g), zlev_g(iim_g, jjm_g))
index_g(:)=index_l(1:nbp_glo)
ENDIF
#ifdef CPP_PARA
IF (is_root_prc) WRITE(numout,*) 'nbp_para_nb =',nbp_para_nb
CALL MPI_BCAST(nbp_para_nb,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(nbp_para_begin,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(nbp_para_end,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(jj_para_nb,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(jj_para_begin,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(jj_para_end,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(ii_para_begin,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(ii_para_end,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(ij_para_nb,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(ij_para_begin,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(ij_para_end,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(iim_g,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(jjm_g,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
CALL MPI_BCAST(nbp_glo,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
#endif
nbp_loc=nbp_para_nb(mpi_rank)
ij_nb=ij_para_nb(mpi_rank)
ij_begin=ij_para_begin(mpi_rank)
ij_end=ij_para_end(mpi_rank)
jj_nb=jj_para_nb(mpi_rank)
jj_begin=jj_para_begin(mpi_rank)
jj_end=jj_para_end(mpi_rank)
ii_begin=ii_para_begin(mpi_rank)
ii_end=ii_para_end(mpi_rank)
CALL Init_io_para
IF (is_root_prc ) THEN
DEALLOCATE(index_l)
IF ( cpl_lmdz) THEN
DEALLOCATE(displs)
ENDIF
ENDIF
IF (check) &
WRITE(numout,*) 'DATA PARA',nbp_loc,nbp_glo,jj_begin,jj_end,ii_begin,ii_end
END SUBROUTINE init_data_para
SUBROUTINE Init_io_para
USE ioipsl
IMPLICIT NONE
INTEGER,DIMENSION(2) :: ddid
INTEGER,DIMENSION(2) :: dsg
INTEGER,DIMENSION(2) :: dsl
INTEGER,DIMENSION(2) :: dpf
INTEGER,DIMENSION(2) :: dpl
INTEGER,DIMENSION(2) :: dhs
INTEGER,DIMENSION(2) :: dhe
ddid=(/ 1,2 /)
dsg=(/ iim_g, jjm_g /)
dsl=(/ iim_g, jj_nb /)
dpf=(/ 1,jj_begin /)
dpl=(/ iim_g, jj_end /)
dhs=(/ ii_begin-1,0 /)
if (mpi_rank==mpi_size-1) then
dhe=(/0,0/)
else
dhe=(/ iim_g-ii_end,0 /)
endif
call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
'APPLE',orch_domain_id)
END SUBROUTINE Init_io_para
SUBROUTINE Read_Load_balance(NbPoints,Nbpoints_loc)
IMPLICIT NONE
INTEGER,INTENT(IN) :: NbPoints
INTEGER,INTENT(OUT) :: Nbpoints_loc(0:mpi_size-1)
#ifdef CPP_PARA
INTEGER :: unit_number=10
CHARACTER(len=255) :: filename='Load_balance_orchidee.dat'
INTEGER :: j
#endif
INTEGER :: i,s,ierr
Nbpoints_loc(:) = 0
#ifdef CPP_PARA
OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr)
#else
ierr=1
#endif
s=0
#ifdef CPP_PARA
IF (ierr==0) THEN
i=0
!- Reading for any balancing file (even with a bad structure)
DO WHILE (i < mpi_size .AND. ierr == 0)
READ (unit_number,*,IOSTAT=ierr) j,Nbpoints_loc(i)
s=s+Nbpoints_loc(i)
i=i+1
ENDDO
CLOSE(unit_number)
ENDIF
#endif
!- Correction of bad balancing file (or an empty file) => same nb of points for each procs
IF (ierr/=0 .OR. s/=Nbpoints) THEN
DO i=0,mpi_size-1
Nbpoints_loc(i)=Nbpoints/mpi_size
IF (MOD(Nbpoints,mpi_size) > i) Nbpoints_loc(i)=Nbpoints_loc(i)+1
ENDDO
ENDIF
END SUBROUTINE Read_Load_balance
SUBROUTINE Write_Load_balance(times)
IMPLICIT NONE
REAL,INTENT(IN) :: times
#ifdef CPP_PARA
CHARACTER(len=255) :: filename='Load_balance_orchidee.dat'
INTEGER :: unit_number=10
INTEGER :: i,ierr
REAL :: All_Times(0:mpi_size-1)
REAL :: average
REAL :: efficiency
INTEGER :: dp,S
INTEGER :: New_nbpoints(0:mpi_size-1)
#endif
WRITE(numout,*) 'time',times
#ifndef CPP_PARA
RETURN
#else
CALL MPI_GATHER(times,1,MPI_REAL_ORCH,All_times,1,MPI_REAL_ORCH,root_prc,MPI_COMM_ORCH,ierr)
IF (is_root_prc) WRITE(numout,*) 'ALL_times',All_times
IF (is_root_prc) THEN
OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr)
average=sum(All_times(:))/mpi_size
DO i=0,mpi_size-1
efficiency=All_times(i)/Nbp_para_nb(i)
New_nbpoints(i)=Nbp_para_nb(i)-(All_times(i)-average)/efficiency
ENDDO
S=sum(new_nbpoints(:))
dp=nbp_glo-S
IF ( dp > 0 ) THEN
DO WHILE ( dp > 0 )
New_nbpoints(MOD(dp,mpi_size))=New_nbpoints(MOD(dp,mpi_size))+1
dp=dp-1
ENDDO
ELSE
dp=-dp
DO WHILE ( dp > 0 )
New_nbpoints(MOD(dp,mpi_size))=New_nbpoints(MOD(dp,mpi_size))-1
dp=dp-1
ENDDO
ENDIF
DO i=0,mpi_size-1
WRITE(Unit_number,*) i,New_nbpoints(i)
ENDDO
CLOSE(Unit_number)
ENDIF
#endif
END SUBROUTINE Write_Load_Balance
END MODULE data_para
#include "mpi_dummy.h"
ORCHIDEE/src_parallel/ioipsl_para.f90 0000754 0103600 0005670 00000023423 11164403473 017216 0 ustar acamlmd lmdjus ! Overlap of IOIPSL functions for specific parallel use in ORCHIDEE.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/ioipsl_para.f90,v 1.4 2008/01/08 11:52:35 ssipsl Exp $
!-
MODULE ioipsl_para
USE ioipsl
USE data_para
USE transfert_para
USE constantes
!-
IMPLICIT NONE
!-
#include "src_parallel.h"
!-
INTERFACE getin_p
MODULE PROCEDURE getin_p_c, &
getin_p_i,getin_p_i1,getin_p_i2,&
getin_p_r,getin_p_r1,getin_p_r2,&
getin_p_l,getin_p_l1,getin_p_l2
END INTERFACE
!-
INTERFACE restput_p
MODULE PROCEDURE &
restput_p_r3d, restput_p_r2d, restput_p_r1d, &
restput_p_opp_r2d, restput_p_opp_r1d
END INTERFACE
!-
INTERFACE restget_p
MODULE PROCEDURE &
restget_p_r3d, restget_p_r2d, restget_p_r1d, &
restget_p_opp_r2d, restget_p_opp_r1d
END INTERFACE
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Definition des getin -> bcast !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! -- Les chaines de caracteres -- !!
SUBROUTINE getin_p_c(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
CHARACTER(LEN=*),INTENT(INOUT) :: VarOut
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_c
!! -- Les entiers -- !!
SUBROUTINE getin_p_i(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
INTEGER,INTENT(INOUT) :: VarOut
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_i
SUBROUTINE getin_p_i1(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
INTEGER,INTENT(INOUT) :: VarOut(:)
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_i1
SUBROUTINE getin_p_i2(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
INTEGER,INTENT(INOUT) :: VarOut(:,:)
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_i2
!! -- Les flottants -- !!
SUBROUTINE getin_p_r(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
REAL,INTENT(INOUT) :: VarOut
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_r
SUBROUTINE getin_p_r1(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
REAL,INTENT(INOUT) :: VarOut(:)
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_r1
SUBROUTINE getin_p_r2(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
REAL,INTENT(INOUT) :: VarOut(:,:)
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_r2
!! -- Les Booleens -- !!
SUBROUTINE getin_p_l(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
LOGICAL,INTENT(INOUT) :: VarOut
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_l
SUBROUTINE getin_p_l1(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
LOGICAL,INTENT(INOUT) :: VarOut(:)
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_l1
SUBROUTINE getin_p_l2(VarIn,VarOut)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: VarIn
LOGICAL,INTENT(INOUT) :: VarOut(:,:)
IF (is_root_prc) CALL getin(VarIn,VarOut)
CALL bcast(VarOut)
END SUBROUTINE getin_p_l2
!-
!-----------------------------
!-----------------------------
!-----------------------------
!-
SUBROUTINE restget_p_opp_r1d &
(fid, vname_q, iim, jjm, llm, itau, def_beha, &
var, MY_OPERATOR, nbindex, ijndex)
! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
LOGICAL def_beha
REAL :: var(:)
CHARACTER(LEN=*) :: MY_OPERATOR
INTEGER :: nbindex, ijndex(nbindex)
!-----------------------------
REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
IF (is_root_prc) THEN
ALLOCATE( temp_g(iim*jjm*llm) )
CALL restget &
(fid, vname_q, iim, jjm, llm, itau, def_beha, &
temp_g, MY_OPERATOR, nbindex, ijndex)
ENDIF
CALL scatter(temp_g,var)
IF (is_root_prc) DEALLOCATE(temp_g)
END SUBROUTINE restget_p_opp_r1d
!-
!===
!-
SUBROUTINE restget_p_opp_r2d &
(fid, vname_q, iim, jjm, llm, itau, def_beha, &
var, MY_OPERATOR, nbindex, ijndex)
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
LOGICAL def_beha
REAL :: var(:,:)
CHARACTER(LEN=*) :: MY_OPERATOR
INTEGER :: nbindex, ijndex(nbindex)
!-----------------------------
REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
IF (is_root_prc) THEN
ALLOCATE( temp_g(iim,jjm) )
CALL restget &
(fid, vname_q, iim, jjm, llm, itau, def_beha, &
temp_g, MY_OPERATOR, nbindex, ijndex)
ENDIF
CALL scatter(temp_g,var)
IF (is_root_prc) DEALLOCATE(temp_g)
END SUBROUTINE restget_p_opp_r2d
!-
!===
!-
SUBROUTINE restget_p_r1d &
(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
LOGICAL :: def_beha
REAL :: var(:)
!-------------------------
REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
IF (is_root_prc) THEN
ALLOCATE( temp_g(iim*jjm*llm) )
CALL restget &
(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
ENDIF
CALL scatter(temp_g,var)
IF (is_root_prc) DEALLOCATE(temp_g)
END SUBROUTINE restget_p_r1d
!-
!===
!-
SUBROUTINE restget_p_r2d &
(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
LOGICAL :: def_beha
REAL :: var(:,:)
!-------------------------
REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
IF (is_root_prc) THEN
ALLOCATE( temp_g(iim,jjm) )
CALL restget &
(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
ENDIF
CALL scatter(temp_g,var)
IF (is_root_prc) DEALLOCATE(temp_g)
END SUBROUTINE restget_p_r2d
!-
!===
!-
SUBROUTINE restget_p_r3d &
(fid,vname_q,iim,jjm,llm,itau,def_beha,var)
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
LOGICAL def_beha
REAL :: var(:,:,:)
!-------------------------
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
IF (is_root_prc) THEN
ALLOCATE( temp_g(iim,jjm,llm) )
CALL restget &
(fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
ENDIF
CALL scatter(temp_g,var)
IF (is_root_prc) DEALLOCATE(temp_g)
END SUBROUTINE restget_p_r3d
!-
!-----------------------------
!-----------------------------
!-
SUBROUTINE restput_p_opp_r1d &
(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
REAL :: var(:)
CHARACTER(LEN=*) :: MY_OPERATOR
INTEGER :: nbindex, ijndex(nbindex)
!-----------------------------
REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
IF (is_root_prc) ALLOCATE( temp_g(iim*jjm*llm) )
CALL gather(var,temp_g)
IF (is_root_prc) THEN
CALL restput &
(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
DEALLOCATE( temp_g )
ENDIF
END SUBROUTINE restput_p_opp_r1d
!-
!===
!-
SUBROUTINE restput_p_opp_r2d &
(fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
REAL :: var(:,:)
CHARACTER(LEN=*) :: MY_OPERATOR
INTEGER :: nbindex, ijndex(nbindex)
!-----------------------------
REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
IF (is_root_prc) ALLOCATE( temp_g(iim,jjm) )
CALL gather(var,temp_g)
IF (is_root_prc) THEN
CALL restput &
(fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
DEALLOCATE( temp_g )
ENDIF
END SUBROUTINE restput_p_opp_r2d
!-
!===
!-
SUBROUTINE restput_p_r1d (fid,vname_q,iim,jjm,llm,itau,var)
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
REAL :: var(:)
!-----------------------------
REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
IF (is_root_prc) ALLOCATE( temp_g(iim*jjm*llm) )
CALL gather(var,temp_g)
IF (is_root_prc) THEN
CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
DEALLOCATE( temp_g )
ENDIF
END SUBROUTINE restput_p_r1d
!-
!===
!-
SUBROUTINE restput_p_r2d (fid,vname_q,iim,jjm,llm,itau,var)
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
REAL :: var(:,:)
!-------------------------
REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
IF (is_root_prc) ALLOCATE( temp_g(iim,jjm) )
CALL gather(var,temp_g)
IF (is_root_prc) THEN
CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
DEALLOCATE( temp_g )
ENDIF
END SUBROUTINE restput_p_r2d
!-
!===
!-
SUBROUTINE restput_p_r3d (fid,vname_q,iim,jjm,llm,itau,var)
IMPLICIT NONE
!-
INTEGER :: fid
CHARACTER(LEN=*) :: vname_q
INTEGER :: iim, jjm, llm, itau
REAL :: var(:,:,:)
!-------------------------
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
IF (is_root_prc) ALLOCATE( temp_g(iim,jjm,llm) )
CALL gather(var,temp_g)
IF (is_root_prc) THEN
CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
DEALLOCATE( temp_g )
ENDIF
END SUBROUTINE restput_p_r3d
END MODULE ioipsl_para
ORCHIDEE/src_parallel/mpi_dummy.h 0000754 0103600 0005670 00000002440 11164403473 016541 0 ustar acamlmd lmdjus ! Overlapp of MPI functions not present in some MPI implementations.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/mpi_dummy.h,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
!-
#ifdef MPI_SECOND__
SUBROUTINE MPI_NULL_COPY_FN
END SUBROUTINE MPI_NULL_COPY_FN
SUBROUTINE MPI_NULL_DELETE_FN
END SUBROUTINE MPI_NULL_DELETE_FN
SUBROUTINE MPI_COMM_NULL_COPY_FN
END SUBROUTINE MPI_COMM_NULL_COPY_FN
SUBROUTINE MPI_COMM_NULL_DELETE_FN
END SUBROUTINE MPI_COMM_NULL_DELETE_FN
SUBROUTINE MPI_TYPE_NULL_COPY_FN
END SUBROUTINE MPI_TYPE_NULL_COPY_FN
SUBROUTINE MPI_TYPE_NULL_DELETE_FN
END SUBROUTINE MPI_TYPE_NULL_DELETE_FN
SUBROUTINE MPI_WIN_NULL_COPY_FN
END SUBROUTINE MPI_WIN_NULL_COPY_FN
SUBROUTINE MPI_WIN_NULL_DELETE_FN
END SUBROUTINE MPI_WIN_NULL_DELETE_FN
SUBROUTINE MPI_DUP_FN
END SUBROUTINE MPI_DUP_FN
SUBROUTINE MPI_COMM_DUP_FN
END SUBROUTINE MPI_COMM_DUP_FN
SUBROUTINE MPI_TYPE_DUP_FN
END SUBROUTINE MPI_TYPE_DUP_FN
SUBROUTINE MPI_WIN_DUP_FN
END SUBROUTINE MPI_WIN_DUP_FN
FUNCTION MPI_WTIME () RESULT (R)
DOUBLE PRECISION R
END FUNCTION MPI_WTIME
FUNCTION MPI_WTICK () RESULT (R)
DOUBLE PRECISION :: R
END FUNCTION MPI_WTICK
FUNCTION PMPI_WTIME () RESULT (R)
DOUBLE PRECISION R
END FUNCTION PMPI_WTIME
FUNCTION PMPI_WTICK () RESULT (R)
DOUBLE PRECISION R
END FUNCTION PMPI_WTICK
#endif
ORCHIDEE/src_parallel/orch_write_field.f90 0000754 0103600 0005670 00000016370 11164403473 020227 0 ustar acamlmd lmdjus ! Yann Meurdesoif functions for sequentiel tests.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/orch_write_field.f90,v 1.3 2007/09/21 14:13:21 ssipsl Exp $
!-
module orch_Write_Field
USE constantes
IMPLICIT NONE
integer, parameter :: MaxWriteField = 100
integer, dimension(MaxWriteField),save :: FieldId
integer, dimension(MaxWriteField),save :: FieldVarId
integer, dimension(MaxWriteField),save :: FieldIndex
character(len=255), dimension(MaxWriteField) :: FieldName
integer, save,dimension(:), allocatable :: Index_Write_Field
integer,save :: iim
integer,save :: jjm
integer,save :: NbPoint
real, parameter :: undef_var=0.
integer,save :: NbField = 0
interface WriteField
module procedure WriteField_4d,WriteField_3d,WriteField_2d,WriteField_1d
end interface WriteField
interface WriteFieldI
module procedure WriteFieldI_3d,WriteFieldI_2d,WriteFieldI_1d
end interface WriteFieldI
private :: iim,jjm,NbPoint
contains
subroutine Init_WriteField(iim0,jjm0,NbPoint0,Index0)
implicit none
integer,intent(in) :: iim0
integer,intent(in) :: jjm0
integer,intent(in) :: NbPoint0
integer,intent(in) :: Index0(NbPoint0)
iim=iim0
jjm=jjm0
Nbpoint=Nbpoint0
ALLOCATE(Index_Write_Field(NbPoint))
Index_Write_Field(:)=Index0(:)
end subroutine Init_WriteField
function GetFieldIndex(name)
implicit none
integer :: GetFieldindex
character(len=*) :: name
character(len=255) :: TrueName
integer :: i
TrueName=TRIM(ADJUSTL(name))
GetFieldIndex=-1
do i=1,NbField
if (TrueName==FieldName(i)) then
GetFieldIndex=i
exit
endif
enddo
end function GetFieldIndex
subroutine WriteFieldI_3d(name,Field)
implicit none
character(len=*) :: name
real, dimension(:,:,:) :: Field
integer, dimension(3) :: Dim
integer,dimension(4) :: Dim_tmp
integer :: i
real, allocatable, dimension(:,:,:) :: Field_tmp
Dim=shape(Field)
allocate(Field_tmp(iim*jjm,Dim(2),dim(3)))
field_tmp(:,:,:)=undef_var
do i=1,NbPoint
field_tmp(Index_Write_Field(i),:,:)=Field(i,:,:)
enddo
Dim_tmp(1)=iim
Dim_tmp(2)=jjm
Dim_tmp(3)=dim(2)
Dim_tmp(4)=dim(3)
call WriteField_gen(name,Field_tmp,4,Dim_tmp)
deallocate(Field_tmp)
end subroutine WriteFieldI_3d
subroutine WriteFieldI_2d(name,Field)
implicit none
character(len=*) :: name
real, dimension(:,:) :: Field
integer, dimension(2) :: Dim
integer,dimension(3) :: Dim_tmp
integer :: i
real, allocatable, dimension(:,:) :: Field_tmp
Dim=shape(Field)
allocate(Field_tmp(iim*jjm,Dim(2)))
field_tmp(:,:)=undef_var
do i=1,NbPoint
field_tmp(Index_Write_Field(i),:)=Field(i,:)
enddo
Dim_tmp(1)=iim
Dim_tmp(2)=jjm
Dim_tmp(3)=dim(2)
call WriteField_gen(name,Field_tmp,3,Dim_tmp)
deallocate(Field_tmp)
end subroutine WriteFieldI_2d
subroutine WriteFieldI_1d(name,Field)
implicit none
character(len=*) :: name
real, dimension(:) :: Field
integer, dimension(1) :: Dim
integer,dimension(2) :: Dim_tmp
integer :: i
real, allocatable, dimension(:) :: Field_tmp
Dim=shape(Field)
allocate(Field_tmp(iim*jjm))
field_tmp(:)=undef_var
do i=1,NbPoint
field_tmp(Index_Write_Field(i))=Field(i)
enddo
Dim_tmp(1)=iim
Dim_tmp(2)=jjm
call WriteField_gen(name,Field_tmp,2,Dim_tmp)
deallocate(Field_tmp)
end subroutine WriteFieldI_1d
subroutine WriteField_4d(name,Field)
implicit none
character(len=*) :: name
real, dimension(:,:,:,:) :: Field
integer, dimension(4) :: Dim
Dim=shape(Field)
call WriteField_gen(name,Field,4,Dim)
end subroutine WriteField_4d
subroutine WriteField_3d(name,Field)
implicit none
character(len=*) :: name
real, dimension(:,:,:) :: Field
integer, dimension(3) :: Dim
Dim=shape(Field)
call WriteField_gen(name,Field,3,Dim)
end subroutine WriteField_3d
subroutine WriteField_2d(name,Field)
implicit none
character(len=*) :: name
real, dimension(:,:) :: Field
integer, dimension(2) :: Dim
Dim=shape(Field)
call WriteField_gen(name,Field,2,Dim)
end subroutine WriteField_2d
subroutine WriteField_1d(name,Field)
implicit none
character(len=*) :: name
real, dimension(:) :: Field
integer, dimension(1) :: Dim
Dim=shape(Field)
call WriteField_gen(name,Field,1,Dim)
end subroutine WriteField_1d
subroutine CreateNewField(name,NbDim,DimSize)
USE ioipsl
implicit none
include 'netcdf.inc'
character(len=*) :: name
integer :: NbDim
integer :: DimSize(NbDim)
integer :: TabDim(NbDim+1)
integer :: status
NbField=NbField+1
FieldName(NbField)=TRIM(ADJUSTL(name))
FieldIndex(NbField)=1
WRITE(numout,*) 'CREATE_NEW_FIELD ',name,NbDim,DimSize
CALL flush(6)
status = NF_CREATE(TRIM(ADJUSTL(name))//'.nc', NF_CLOBBER, FieldId(NbField))
if (NbDim>=1) status = NF_DEF_DIM(FieldId(NbField),'I',DimSize(1),TabDim(1))
if (NbDim>=2) status = NF_DEF_DIM(FieldId(NbField),'J',DimSize(2),TabDim(2))
if (NbDim>=3) status = NF_DEF_DIM(FieldId(NbField),'K',DimSize(3),TabDim(3))
if (NbDim>=4) status = NF_DEF_DIM(FieldId(NbField),'L',DimSize(4),TabDim(4))
status = NF_DEF_DIM(FieldId(NbField),'iter',NF_UNLIMITED,TabDim(NbDim+1))
status = NF_DEF_VAR(FieldId(NbField),FieldName(NbField),NF_DOUBLE,NbDim+1,TabDim,FieldVarId(NbField))
status = NF_ENDDEF(FieldId(NbField))
end subroutine CreateNewField
function int2str(int)
implicit none
integer, parameter :: MaxLen=10
integer,intent(in) :: int
character(len=MaxLen) :: int2str
logical :: flag
integer :: i
flag=.true.
i=int
int2str=''
do while (flag)
int2str=CHAR(MOD(i,10)+48)//int2str
i=i/10
if (i==0) flag=.false.
enddo
end function int2str
end module Orch_Write_Field
subroutine WriteField_gen(name,Field,NbDim,DimSize)
use orch_write_field
implicit none
include 'netcdf.inc'
character(len=*) :: name
integer :: NbDim
integer,dimension(NbDim) :: DimSize
real,dimension(*) :: Field
integer :: status
integer :: ind
integer :: start(NbDim+1)
integer :: count(NbDim+1)
integer :: i
Ind=GetFieldIndex(name)
if (Ind==-1) then
call CreateNewField(name,NbDim,DimSize)
Ind=GetFieldIndex(name)
else
FieldIndex(Ind)=FieldIndex(Ind)+1
endif
do i=1,NbDim
start(i)=1
count(i)=DimSize(i)
enddo
start(NbDim+1)=FieldIndex(Ind)
count(NbDim+1)=1
status = NF_PUT_VARA_DOUBLE(FieldId(Ind),FieldVarId(Ind),start,count,Field)
status = NF_SYNC(FieldId(Ind))
end subroutine WriteField_gen
ORCHIDEE/src_parallel/orch_write_field_p.f90 0000754 0103600 0005670 00000007603 11164403473 020545 0 ustar acamlmd lmdjus ! Yann Meurdesoif functions for parallel tests.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/orch_write_field_p.f90,v 1.3 2007/09/21 14:13:21 ssipsl Exp $
!-
MODULE Orch_Write_field_p
interface WriteField_p
module procedure WriteField_4d_p,WriteField_3d_p,WriteField_2d_p
end interface WriteField_p
interface WriteFieldI_p
module procedure WriteFieldI_3d_p,WriteFieldI_2d_p,WriteFieldI_1d_p
end interface WriteFieldI_p
CONTAINS
SUBROUTINE init_WriteField_p(index_Write_Field_p)
USE parallel
USE Write_Field, only : Init_WriteField
IMPLICIT NONE
INTEGER,INTENT(in) :: index_Write_Field_p(nbp_loc)
IF (is_root_prc) CALL Init_WriteField(iim_g,jjm_g,nbp_glo,index_g)
END SUBROUTINE init_WriteField_p
SUBROUTINE WriteField_4d_p(name,Field)
USE parallel
USE Write_field, only : WriteField
IMPLICIT NONE
CHARACTER(len=*) :: name
REAL, DIMENSION(:,:,:,:) :: Field
INTEGER, DIMENSION(4) :: Dim
REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: Field_g
Dim=shape(Field)
ALLOCATE(Field_g(iim_g,jjm_g,Dim(3),Dim(4)))
CALL Gather2D(Field,Field_g)
IF (is_root_prc) CALL WriteField(name,Field_g)
DEALLOCATE(Field_g)
END SUBROUTINE WriteField_4d_p
SUBROUTINE WriteField_3d_p(name,Field)
USE parallel
USE Write_field, only : WriteField
IMPLICIT NONE
CHARACTER(len=*) :: name
REAL, DIMENSION(:,:,:) :: Field
INTEGER, DIMENSION(3) :: Dim
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: Field_g
Dim=shape(Field)
ALLOCATE(Field_g(iim_g,jjm_g,Dim(3)))
CALL Gather2D(Field,Field_g)
IF (is_root_prc) CALL WriteField(name,Field_g)
DEALLOCATE(Field_g)
END SUBROUTINE WriteField_3d_p
SUBROUTINE WriteField_2d_p(name,Field)
USE parallel
USE Write_field, only : WriteField
IMPLICIT NONE
CHARACTER(len=*) :: name
REAL, DIMENSION(:,:) :: Field
INTEGER, DIMENSION(2) :: Dim
REAL, ALLOCATABLE, DIMENSION(:,:) :: Field_g
Dim=shape(Field)
ALLOCATE(Field_g(iim_g,jjm_g))
CALL Gather2D(Field,Field_g)
IF (is_root_prc) CALL WriteField_gen(name,Field_g)
DEALLOCATE(Field_g)
END SUBROUTINE WriteField_2d_p
SUBROUTINE WriteFieldI_3d_p(name,Field)
USE parallel
USE Write_field, only : WriteFieldI
IMPLICIT NONE
CHARACTER(len=*) :: name
REAL, DIMENSION(:,:,:) :: Field
INTEGER, DIMENSION(3) :: Dim
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: Field_g
Dim=shape(Field)
ALLOCATE(Field_g(nbp_glo,Dim(2),Dim(3)))
CALL gather(Field,Field_g)
IF (is_root_prc) CALL WriteFieldI(name,Field_g)
DEALLOCATE(Field_g)
END SUBROUTINE WriteFieldI_3d_p
SUBROUTINE WriteFieldI_2d_p(name,Field)
USE parallel
USE Write_field, only : WriteFieldI
IMPLICIT NONE
CHARACTER(len=*) :: name
REAL, DIMENSION(:,:) :: Field
INTEGER, DIMENSION(2) :: Dim
REAL, ALLOCATABLE, DIMENSION(:,:) :: Field_g
Dim=shape(Field)
ALLOCATE(Field_g(nbp_glo,Dim(2)))
CALL gather(Field,Field_g)
IF (is_root_prc) CALL WriteFieldI(name,Field_g)
DEALLOCATE(Field_g)
END SUBROUTINE WriteFieldI_2d_p
SUBROUTINE WriteFieldI_1d_p(name,Field)
USE parallel
USE Write_field, only : WriteFieldI
IMPLICIT NONE
CHARACTER(len=*) :: name
REAL, DIMENSION(:) :: Field
INTEGER, DIMENSION(1) :: Dim
REAL, ALLOCATABLE, DIMENSION(:) :: Field_g
Dim=shape(Field)
ALLOCATE(Field_g(nbp_glo))
CALL gather(Field,Field_g)
IF (is_root_prc) CALL WriteFieldI(name,Field_g)
DEALLOCATE(Field_g)
END SUBROUTINE WriteFieldI_1d_p
END MODULE Orch_Write_field_p
ORCHIDEE/src_parallel/parallel.f90 0000754 0103600 0005670 00000000412 11164403473 016501 0 ustar acamlmd lmdjus ! Global module for all parallel modules.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/parallel.f90,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
!-
MODULE PARALLEL
USE data_para
USE transfert_para
USE ioipsl_para
USE tools_para
END MODULE PARALLEL
ORCHIDEE/src_parallel/src_parallel.h 0000754 0103600 0005670 00000001160 11164403473 017202 0 ustar acamlmd lmdjus ! Redefinition of MPI function if not second underscore in MPI library.
! One must use -DMPI_SECOND__ in precompilation to activate those definitions.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/src_parallel.h,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
!-
#ifdef MPI_SECOND__
#define MPI_BARRIER MPI_BARRIER_
#define MPI_FINALIZE MPI_FINALIZE_
#define MPI_COMM_SIZE MPI_COMM_SIZE_
#define MPI_INIT MPI_INIT_
#define MPI_COMM_RANK MPI_COMM_RANK_
#define MPI_GATHER MPI_GATHER_
#define MPI_GATHERV MPI_GATHERV_
#define MPI_BCAST MPI_BCAST_
#define MPI_SCATTERV MPI_SCATTERV_
#define MPI_REDUCE MPI_REDUCE_
#endif
ORCHIDEE/src_parallel/timer.f90 0000754 0103600 0005670 00000010045 11164403473 016030 0 ustar acamlmd lmdjus ! Timer functions to calculate MPI use speed up.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/timer.f90,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
!-
MODULE timer
USE constantes
INTEGER, PARAMETER :: nb_timer=2
INTEGER, PARAMETER :: timer_global=1
INTEGER, PARAMETER :: timer_mpi=2
INTEGER, PARAMETER :: stopped = 1
INTEGER, PARAMETER :: running = 2
INTEGER, PARAMETER :: suspended = 3
DOUBLE PRECISION, DIMENSION(nb_timer),SAVE :: cpu_timer
DOUBLE PRECISION, DIMENSION(nb_timer),SAVE :: real_timer
INTEGER, DIMENSION(nb_timer),SAVE :: timer_state
DOUBLE PRECISION, DIMENSION(nb_timer),SAVE :: last_cpu_time
INTEGER, DIMENSION(nb_timer),SAVE :: last_real_time
CONTAINS
SUBROUTINE init_timer
IMPLICIT NONE
cpu_timer(:)=0.
real_timer(:)=0.
timer_state(:)=stopped
last_cpu_time(:)=0.
last_real_time(:)=0
END SUBROUTINE init_timer
SUBROUTINE start_timer(no_timer)
IMPLICIT NONE
INTEGER :: no_timer
DOUBLE PRECISION :: x
IF (timer_state(no_timer)/=stopped) THEN
STOP 'start_timer :: timer is already running or suspended'
ELSE
timer_state(no_timer)=running
ENDIF
cpu_timer(no_timer)=0.
real_timer(no_timer)=0.
x=Diff_real_time(no_timer)
x=Diff_cpu_time(no_timer)
END SUBROUTINE start_timer
SUBROUTINE stop_timer(no_timer)
IMPLICIT NONE
INTEGER :: no_timer
IF (timer_state(no_timer)==running) THEN
CALL suspend_timer(no_timer)
ELSE IF (timer_state(no_timer)==stopped) THEN
WRITE(numout,*) 'stop_timer :: timer is already stopped'
ENDIF
timer_state(no_timer)=stopped
END SUBROUTINE stop_timer
SUBROUTINE resume_timer(no_timer)
IMPLICIT NONE
INTEGER :: no_timer
DOUBLE PRECISION :: x
IF (timer_state(no_timer)/=suspended) THEN
STOP 'resume_timer :: timer is not suspended'
ELSE
timer_state(no_timer)=running
ENDIF
x=Diff_cpu_time(no_timer)
x=Diff_real_time(no_timer)
END SUBROUTINE resume_timer
SUBROUTINE suspend_timer(no_timer)
IMPLICIT NONE
INTEGER :: no_timer
IF (timer_state(no_timer)/=running) THEN
STOP 'suspend_timer :: timer is not running'
ELSE
timer_state(no_timer)=suspended
ENDIF
cpu_timer(no_timer)=cpu_timer(no_timer)+Diff_cpu_time(no_timer)
real_timer(no_timer)=real_timer(no_timer)+Diff_real_time(no_timer)
END SUBROUTINE suspend_timer
FUNCTION diff_real_time(no_timer)
IMPLICIT NONE
INTEGER :: no_timer
DOUBLE PRECISION :: Diff_real_Time
integer :: Last_Count,count,count_rate,count_max
Last_Count=Last_real_time(no_timer)
call system_clock(count,count_rate,count_max)
if (Count>=Last_Count) then
Diff_real_time=(1.*(Count-last_Count))/count_rate
else
Diff_real_time=(1.*(Count-last_Count+Count_max))/count_rate
endif
Last_real_time(no_timer)=Count
END FUNCTION diff_real_time
function Diff_Cpu_Time(no_timer)
implicit none
INTEGER :: no_timer
DOUBLE PRECISION :: Diff_Cpu_Time
DOUBLE PRECISION :: Last_Count,Count
Last_Count=Last_cpu_time(no_timer)
call cpu_time(Count)
Diff_Cpu_Time=Count-Last_Count
Last_cpu_time(no_timer)=Count
end function Diff_Cpu_Time
FUNCTION Get_cpu_time(no_timer)
IMPLICIT NONE
INTEGER :: no_timer
DOUBLE PRECISION :: Get_cpu_time
IF (timer_state(no_timer)==running) THEN
CALL suspend_timer(no_timer)
Get_cpu_time=cpu_timer(no_timer)
CALL resume_timer(no_timer)
ELSE
Get_cpu_time=cpu_timer(no_timer)
ENDIF
END FUNCTION Get_cpu_time
FUNCTION Get_real_time(no_timer)
IMPLICIT NONE
INTEGER :: no_timer
DOUBLE PRECISION :: Get_real_time
IF (timer_state(no_timer)==running) THEN
CALL suspend_timer(no_timer)
Get_real_time=real_timer(no_timer)
CALL resume_timer(no_timer)
ELSE
Get_real_time=real_timer(no_timer)
ENDIF
END FUNCTION Get_real_time
END MODULE Timer
ORCHIDEE/src_parallel/tools_para.f90 0000754 0103600 0005670 00000002760 11164403473 017060 0 ustar acamlmd lmdjus ! Parallel tools : Barrier and Finalize.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/tools_para.f90,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
!-
MODULE tools_para
!-
USE ioipsl
USE defprec
USE timer
USE data_para
USE constantes
!-
#include "src_parallel.h"
!-
CONTAINS
SUBROUTINE stop_mpi()
#ifdef CPP_PARA
CALL MPI_COMM_FREE(MPI_COMM_ORCH,ierr)
CALL MPI_FINALIZE(ierr)
#endif
CALL ipslerr(3,'STOP_MPI','MPI has been stopped in ORCHIDEE.',&
& "Don't know the reason","Please verify output.")
ENd subroutine stop_mpi
SUBROUTINE barrier_para()
#ifdef CPP_PARA
CALL MPI_BARRIER(MPI_COMM_ORCH,ierr)
#endif
END SUBROUTINE barrier_para
SUBROUTINE finalize_para(timer_global,timer_mpi)
INTEGER, INTENT(IN) :: timer_global, timer_mpi
WRITE(numout,*) '*********************************************************'
WRITE(numout,*) ' TEMPS GLOBAL ---> REAL TIME :',Get_real_time(timer_global)
WRITE(numout,*) ' TEMPS GLOBAL ---> CPU TIME :',Get_cpu_time(timer_global)
WRITE(numout,*) ' TEMPS HORS MPI ---> REAL TIME :',Get_real_time(timer_mpi)
WRITE(numout,*) ' TEMPS HORS MPI ---> CPU TIME :',Get_cpu_time(timer_mpi)
WRITE(numout,*) '*********************************************************'
WRITE(numout,*) 'END OF RUN.'
CALL Write_Load_Balance(Get_cpu_time(timer_mpi))
#ifdef CPP_PARA
! CALL MPI_COMM_FREE(MPI_COMM_ORCH,ierr)
CALL MPI_FINALIZE(ierr)
#endif
END SUBROUTINE finalize_para
END MODULE tools_para
ORCHIDEE/src_parallel/transfert_para.f90 0000754 0103600 0005670 00000175446 11164403473 017744 0 ustar acamlmd lmdjus ! Low level parallel communication encapsulations for ORCHIDEE.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/transfert_para.f90,v 1.5 2007/10/18 12:56:33 ssipsl Exp $
!-
MODULE transfert_para
USE data_para
USE timer
USE constantes
!-
IMPLICIT NONE
!-
#include "src_parallel.h"
!-
INTERFACE bcast
MODULE PROCEDURE bcast_c, &
bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, &
bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, &
bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4
END INTERFACE
INTERFACE scatter
MODULE PROCEDURE scatter_i,scatter_i1,scatter_i2,scatter_i3, &
scatter_r,scatter_r1,scatter_r2,scatter_r3, &
scatter_l,scatter_l1,scatter_l2,scatter_l3
END INTERFACE
INTERFACE gather_s
MODULE PROCEDURE gather_is, &
gather_rs, &
gather_ls
END INTERFACE
INTERFACE gather
MODULE PROCEDURE gather_i,gather_i1,gather_i2,gather_i3, &
gather_r,gather_r1,gather_r2,gather_r3, &
gather_l,gather_l1,gather_l2,gather_l3
END INTERFACE
INTERFACE scatter2D
MODULE PROCEDURE scatter2D_i,scatter2D_i1,scatter2D_i2,scatter2D_i3, &
scatter2D_r,scatter2D_r1,scatter2D_r2,scatter2D_r3, &
scatter2D_l,scatter2D_l1,scatter2D_l2,scatter2D_l3
END INTERFACE
INTERFACE gather2D
MODULE PROCEDURE gather2D_i,gather2D_i1,gather2D_i2,gather2D_i3, &
gather2D_r,gather2D_r1,gather2D_r2,gather2D_r3, &
gather2D_l,gather2D_l1,gather2D_l2,gather2D_l3
END INTERFACE
INTERFACE reduce_sum
MODULE PROCEDURE reduce_sum_i,reduce_sum_i1,reduce_sum_i2,reduce_sum_i3,reduce_sum_i4, &
reduce_sum_r,reduce_sum_r1,reduce_sum_r2,reduce_sum_r3,reduce_sum_r4
END INTERFACE
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Definition des Broadcast --> 4D !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! -- Les chaine de charactère -- !!
SUBROUTINE bcast_c(var1)
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(INOUT) :: Var1
#ifndef CPP_PARA
RETURN
#else
CALL bcast_cgen(Var1,len(Var1))
#endif
END SUBROUTINE bcast_c
!! -- Les entiers -- !!
SUBROUTINE bcast_i(var1)
IMPLICIT NONE
INTEGER,INTENT(INOUT) :: Var1
#ifndef CPP_PARA
RETURN
#else
CALL bcast_igen(Var1,1)
#endif
END SUBROUTINE bcast_i
SUBROUTINE bcast_i1(var)
IMPLICIT NONE
INTEGER,INTENT(INOUT) :: Var(:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_igen(Var,size(Var))
#endif
END SUBROUTINE bcast_i1
SUBROUTINE bcast_i2(var)
IMPLICIT NONE
INTEGER,INTENT(INOUT) :: Var(:,:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_igen(Var,size(Var))
#endif
END SUBROUTINE bcast_i2
SUBROUTINE bcast_i3(var)
IMPLICIT NONE
INTEGER,INTENT(INOUT) :: Var(:,:,:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_igen(Var,size(Var))
#endif
END SUBROUTINE bcast_i3
SUBROUTINE bcast_i4(var)
IMPLICIT NONE
INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_igen(Var,size(Var))
#endif
END SUBROUTINE bcast_i4
!! -- Les reels -- !!
SUBROUTINE bcast_r(var)
IMPLICIT NONE
REAL,INTENT(INOUT) :: Var
#ifndef CPP_PARA
RETURN
#else
CALL bcast_rgen(Var,1)
#endif
END SUBROUTINE bcast_r
SUBROUTINE bcast_r1(var)
IMPLICIT NONE
REAL,INTENT(INOUT) :: Var(:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_rgen(Var,size(Var))
#endif
END SUBROUTINE bcast_r1
SUBROUTINE bcast_r2(var)
IMPLICIT NONE
REAL,INTENT(INOUT) :: Var(:,:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_rgen(Var,size(Var))
#endif
END SUBROUTINE bcast_r2
SUBROUTINE bcast_r3(var)
IMPLICIT NONE
REAL,INTENT(INOUT) :: Var(:,:,:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_rgen(Var,size(Var))
#endif
END SUBROUTINE bcast_r3
SUBROUTINE bcast_r4(var)
IMPLICIT NONE
REAL,INTENT(INOUT) :: Var(:,:,:,:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_rgen(Var,size(Var))
#endif
END SUBROUTINE bcast_r4
!! -- Les booleans -- !!
SUBROUTINE bcast_l(var)
IMPLICIT NONE
LOGICAL,INTENT(INOUT) :: Var
#ifndef CPP_PARA
RETURN
#else
CALL bcast_lgen(Var,1)
#endif
END SUBROUTINE bcast_l
SUBROUTINE bcast_l1(var)
IMPLICIT NONE
LOGICAL,INTENT(INOUT) :: Var(:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_lgen(Var,size(Var))
#endif
END SUBROUTINE bcast_l1
SUBROUTINE bcast_l2(var)
IMPLICIT NONE
LOGICAL,INTENT(INOUT) :: Var(:,:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_lgen(Var,size(Var))
#endif
END SUBROUTINE bcast_l2
SUBROUTINE bcast_l3(var)
IMPLICIT NONE
LOGICAL,INTENT(INOUT) :: Var(:,:,:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_lgen(Var,size(Var))
#endif
END SUBROUTINE bcast_l3
SUBROUTINE bcast_l4(var)
IMPLICIT NONE
LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
#ifndef CPP_PARA
RETURN
#else
CALL bcast_lgen(Var,size(Var))
#endif
END SUBROUTINE bcast_l4
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Definition des Scatter --> 4D !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE scatter_i(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(nbp_glo) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(nbp_loc) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn(:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_igen(VarIn,Varout,1)
ELSE
CALL scatter_igen(dummy,Varout,1)
ENDIF
#endif
END SUBROUTINE scatter_i
SUBROUTINE scatter_i1(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_igen(VarIn,Varout,Size(VarOut,2))
ELSE
CALL scatter_igen(dummy,Varout,Size(VarOut,2))
ENDIF
#endif
END SUBROUTINE scatter_i1
SUBROUTINE scatter_i2(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
ELSE
CALL scatter_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
ENDIF
#endif
END SUBROUTINE scatter_i2
SUBROUTINE scatter_i3(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
ELSE
CALL scatter_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
ENDIF
#endif
END SUBROUTINE scatter_i3
SUBROUTINE scatter_r(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn(:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_rgen(VarIn,Varout,1)
ELSE
CALL scatter_rgen(dummy,Varout,1)
ENDIF
#endif
END SUBROUTINE scatter_r
SUBROUTINE scatter_r1(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_rgen(VarIn,Varout,Size(VarOut,2))
ELSE
CALL scatter_rgen(dummy,Varout,Size(VarOut,2))
ENDIF
#endif
END SUBROUTINE scatter_r1
SUBROUTINE scatter_r2(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
ELSE
CALL scatter_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
ENDIF
#endif
END SUBROUTINE scatter_r2
SUBROUTINE scatter_r3(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
ELSE
CALL scatter_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
ENDIF
#endif
END SUBROUTINE scatter_r3
SUBROUTINE scatter_l(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn(:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_lgen(VarIn,Varout,1)
ELSE
CALL scatter_lgen(dummy,Varout,1)
ENDIF
#endif
END SUBROUTINE scatter_l
SUBROUTINE scatter_l1(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_lgen(VarIn,Varout,Size(VarOut,2))
ELSE
CALL scatter_lgen(dummy,Varout,Size(VarOut,2))
ENDIF
#endif
END SUBROUTINE scatter_l1
SUBROUTINE scatter_l2(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
ELSE
CALL scatter_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
ENDIF
#endif
END SUBROUTINE scatter_l2
SUBROUTINE scatter_l3(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
ELSE
CALL scatter_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
ENDIF
#endif
END SUBROUTINE scatter_l3
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Definition des Gather --> 4D !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE gather_is(VarIn, VarOut)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
#ifdef CPP_PARA
INCLUDE 'mpif.h'
#endif
INTEGER,INTENT(IN) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
INTEGER :: nb,i,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn
RETURN
#else
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "gather_rgen VarIn=",VarIn
#ifdef CPP_PARA
CALL MPI_GATHER(VarIn,1,MPI_INT_ORCH,VarOut,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
#endif
IF (check) &
WRITE(numout,*) "gather_rgen VarOut=",VarOut
IF (flag) CALL resume_timer(timer_mpi)
#endif
END SUBROUTINE gather_is
SUBROUTINE gather_rs(VarIn, VarOut)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
#ifdef CPP_PARA
INCLUDE 'mpif.h'
#endif
REAL,INTENT(IN) :: VarIn
REAL,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
INTEGER :: nb,i,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn
RETURN
#else
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "gather_rgen VarIn=",VarIn
#ifdef CPP_PARA
CALL MPI_GATHER(VarIn,1,MPI_REAL_ORCH,VarOut,1,MPI_REAL_ORCH,root_prc,MPI_COMM_ORCH,ierr)
#endif
IF (check) &
WRITE(numout,*) "gather_rgen VarOut=",VarOut
IF (flag) CALL resume_timer(timer_mpi)
#endif
END SUBROUTINE gather_rs
SUBROUTINE gather_ls(VarIn, VarOut)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
#ifdef CPP_PARA
INCLUDE 'mpif.h'
#endif
LOGICAL,INTENT(IN) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
INTEGER :: nb,i,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn
RETURN
#else
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "gather_rgen VarIn=",VarIn
#ifdef CPP_PARA
CALL MPI_GATHER(VarIn,1,MPI_LOGICAL,VarOut,1,MPI_LOGICAL,root_prc,MPI_COMM_ORCH,ierr)
#endif
IF (check) &
WRITE(numout,*) "gather_rgen VarOut=",VarOut
IF (flag) CALL resume_timer(timer_mpi)
#endif
END SUBROUTINE gather_ls
!!!!! --> Les entiers
SUBROUTINE gather_i(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn(:)
RETURN
#else
! if (SIZE(VarIn) == 1) call stopit
IF (is_root_prc) THEN
CALL gather_igen(VarIn,VarOut,1)
ELSE
CALL gather_igen(VarIn,dummy,1)
ENDIF
#endif
END SUBROUTINE gather_i
!!!!!
SUBROUTINE gather_i1(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
! if (SIZE(VarIn) == 1) stop
IF (is_root_prc) THEN
CALL gather_igen(VarIn,VarOut,Size(VarIn,2))
ELSE
CALL gather_igen(VarIn,dummy,Size(VarIn,2))
ENDIF
#endif
END SUBROUTINE gather_i1
!!!!!
SUBROUTINE gather_i2(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
ELSE
CALL gather_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
ENDIF
#endif
END SUBROUTINE gather_i2
!!!!!
SUBROUTINE gather_i3(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
ELSE
CALL gather_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
ENDIF
#endif
END SUBROUTINE gather_i3
!!!!! --> Les reels
SUBROUTINE gather_r(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn(:)
RETURN
#else
! if (SIZE(VarIn) == 1) call stopit
IF (is_root_prc) THEN
CALL gather_rgen(VarIn,VarOut,1)
ELSE
CALL gather_rgen(VarIn,dummy,1)
ENDIF
#endif
END SUBROUTINE gather_r
!!!!!
SUBROUTINE gather_r1(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather_rgen(VarIn,VarOut,Size(VarIn,2))
ELSE
CALL gather_rgen(VarIn,dummy,Size(VarIn,2))
ENDIF
#endif
END SUBROUTINE gather_r1
!!!!!
SUBROUTINE gather_r2(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
ELSE
CALL gather_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
ENDIF
#endif
END SUBROUTINE gather_r2
!!!!!
SUBROUTINE gather_r3(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
ELSE
CALL gather_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
ENDIF
#endif
END SUBROUTINE gather_r3
!!!!! --> Les booleen
SUBROUTINE gather_l(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn(:)
RETURN
#else
! if (SIZE(VarIn) == 1) call stopit
IF (is_root_prc) THEN
CALL gather_lgen(VarIn,VarOut,1)
ELSE
CALL gather_lgen(VarIn,dummy,1)
ENDIF
#endif
END SUBROUTINE gather_l
!!!!!
SUBROUTINE gather_l1(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather_lgen(VarIn,VarOut,Size(VarIn,2))
ELSE
CALL gather_lgen(VarIn,dummy,Size(VarIn,2))
ENDIF
#endif
END SUBROUTINE gather_l1
!!!!!
SUBROUTINE gather_l2(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
ELSE
CALL gather_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
ENDIF
#endif
END SUBROUTINE gather_l2
!!!!!
SUBROUTINE gather_l3(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
ELSE
CALL gather_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
ENDIF
#endif
END SUBROUTINE gather_l3
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Definition des Scatter2D --> 4D !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE scatter2D_i(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_igen(VarIn,VarOut,1)
ELSE
CALL scatter2D_igen(dummy,VarOut,1)
ENDIF
#endif
END SUBROUTINE scatter2D_i
SUBROUTINE scatter2D_i1(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_igen(VarIn,VarOut,SIZE(VarOut,3))
ELSE
CALL scatter2D_igen(dummy,VarOut,SIZE(VarOut,3))
ENDIF
#endif
END SUBROUTINE scatter2D_i1
SUBROUTINE scatter2D_i2(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_igen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
ELSE
CALL scatter2D_igen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
ENDIF
#endif
END SUBROUTINE scatter2D_i2
SUBROUTINE scatter2D_i3(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_igen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
ELSE
CALL scatter2D_igen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
ENDIF
#endif
END SUBROUTINE scatter2D_i3
SUBROUTINE scatter2D_r(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_rgen(VarIn,VarOut,1)
ELSE
CALL scatter2D_rgen(dummy,VarOut,1)
ENDIF
#endif
END SUBROUTINE scatter2D_r
SUBROUTINE scatter2D_r1(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_rgen(VarIn,VarOut,SIZE(VarOut,3))
ELSE
CALL scatter2D_rgen(dummy,VarOut,SIZE(VarOut,3))
ENDIF
#endif
END SUBROUTINE scatter2D_r1
SUBROUTINE scatter2D_r2(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_rgen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
ELSE
CALL scatter2D_rgen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
ENDIF
#endif
END SUBROUTINE scatter2D_r2
SUBROUTINE scatter2D_r3(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_rgen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
ELSE
CALL scatter2D_rgen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
ENDIF
#endif
END SUBROUTINE scatter2D_r3
SUBROUTINE scatter2D_l(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_lgen(VarIn,VarOut,1)
ELSE
CALL scatter2D_lgen(dummy,VarOut,1)
ENDIF
#endif
END SUBROUTINE scatter2D_l
SUBROUTINE scatter2D_l1(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_lgen(VarIn,VarOut,SIZE(VarOut,3))
ELSE
CALL scatter2D_lgen(dummy,VarOut,SIZE(VarOut,3))
ENDIF
#endif
END SUBROUTINE scatter2D_l1
SUBROUTINE scatter2D_l2(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_lgen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
ELSE
CALL scatter2D_lgen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
ENDIF
#endif
END SUBROUTINE scatter2D_l2
SUBROUTINE scatter2D_l3(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL scatter2D_lgen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
ELSE
CALL scatter2D_lgen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
ENDIF
#endif
END SUBROUTINE scatter2D_l3
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Definition des Gather2D --> 4D !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE gather2D_i(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_igen(VarIn,VarOut,1)
ELSE
CALL gather2D_igen(VarIn,dummy,1)
ENDIF
#endif
END SUBROUTINE gather2D_i
SUBROUTINE gather2D_i1(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_igen(VarIn,VarOut,SIZE(VarIn,3))
ELSE
CALL gather2D_igen(VarIn,dummy,SIZE(VarIn,3))
ENDIF
#endif
END SUBROUTINE gather2D_i1
SUBROUTINE gather2D_i2(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_igen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4))
ELSE
CALL gather2D_igen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4))
ENDIF
#endif
END SUBROUTINE gather2D_i2
SUBROUTINE gather2D_i3(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_igen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
ELSE
CALL gather2D_igen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
ENDIF
#endif
END SUBROUTINE gather2D_i3
SUBROUTINE gather2D_r(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_rgen(VarIn,VarOut,1)
ELSE
CALL gather2D_rgen(VarIn,dummy,1)
ENDIF
#endif
END SUBROUTINE gather2D_r
SUBROUTINE gather2D_r1(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_rgen(VarIn,VarOut,SIZE(VarIn,3))
ELSE
CALL gather2D_rgen(VarIn,dummy,SIZE(VarIn,3))
ENDIF
#endif
END SUBROUTINE gather2D_r1
SUBROUTINE gather2D_r2(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_rgen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4))
ELSE
CALL gather2D_rgen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4))
ENDIF
#endif
END SUBROUTINE gather2D_r2
SUBROUTINE gather2D_r3(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_rgen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
ELSE
CALL gather2D_rgen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
ENDIF
#endif
END SUBROUTINE gather2D_r3
SUBROUTINE gather2D_l(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_lgen(VarIn,VarOut,1)
ELSE
CALL gather2D_lgen(VarIn,dummy,1)
ENDIF
#endif
END SUBROUTINE gather2D_l
SUBROUTINE gather2D_l1(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_lgen(VarIn,VarOut,SIZE(VarIn,3))
ELSE
CALL gather2D_lgen(VarIn,dummy,SIZE(VarIn,3))
ENDIF
#endif
END SUBROUTINE gather2D_l1
SUBROUTINE gather2D_l2(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_lgen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4))
ELSE
CALL gather2D_lgen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4))
ENDIF
#endif
END SUBROUTINE gather2D_l2
SUBROUTINE gather2D_l3(VarIn, VarOut)
IMPLICIT NONE
LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
#ifdef CPP_PARA
LOGICAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL gather2D_lgen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
ELSE
CALL gather2D_lgen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
ENDIF
#endif
END SUBROUTINE gather2D_l3
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Definition des reduce_sum --> 4D !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE reduce_sum_i(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN) :: VarIn
INTEGER,INTENT(OUT) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut=VarIn
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_igen(VarIn,Varout,1)
ELSE
CALL reduce_sum_igen(VarIn,dummy,1)
ENDIF
#endif
END SUBROUTINE reduce_sum_i
SUBROUTINE reduce_sum_i1(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn(:)
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_igen(VarIn,Varout,SIZE(VarIn))
ELSE
CALL reduce_sum_igen(VarIn,dummy,SIZE(VarIn))
ENDIF
#endif
END SUBROUTINE reduce_sum_i1
SUBROUTINE reduce_sum_i2(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_igen(VarIn,Varout,SIZE(VarIn))
ELSE
CALL reduce_sum_igen(VarIn,dummy,SIZE(VarIn))
ENDIF
#endif
END SUBROUTINE reduce_sum_i2
SUBROUTINE reduce_sum_i3(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_igen(VarIn,Varout,SIZE(VarIn))
ELSE
CALL reduce_sum_igen(VarIn,dummy,SIZE(VarIn))
ENDIF
#endif
END SUBROUTINE reduce_sum_i3
SUBROUTINE reduce_sum_i4(VarIn, VarOut)
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
INTEGER :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_igen(VarIn,Varout,SIZE(VarIn))
ELSE
CALL reduce_sum_igen(VarIn,dummy,SIZE(VarIn))
ENDIF
#endif
END SUBROUTINE reduce_sum_i4
SUBROUTINE reduce_sum_r(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN) :: VarIn
REAL,INTENT(OUT) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut=VarIn
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_rgen(VarIn,Varout,1)
ELSE
CALL reduce_sum_rgen(VarIn,dummy,1)
ENDIF
#endif
END SUBROUTINE reduce_sum_r
SUBROUTINE reduce_sum_r1(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:)=VarIn(:)
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_rgen(VarIn,Varout,SIZE(VarIn))
ELSE
CALL reduce_sum_rgen(VarIn,dummy,SIZE(VarIn))
ENDIF
#endif
END SUBROUTINE reduce_sum_r1
SUBROUTINE reduce_sum_r2(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:)=VarIn(:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_rgen(VarIn,Varout,SIZE(VarIn))
ELSE
CALL reduce_sum_rgen(VarIn,dummy,SIZE(VarIn))
ENDIF
#endif
END SUBROUTINE reduce_sum_r2
SUBROUTINE reduce_sum_r3(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:)=VarIn(:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_rgen(VarIn,Varout,SIZE(VarIn))
ELSE
CALL reduce_sum_rgen(VarIn,dummy,SIZE(VarIn))
ENDIF
#endif
END SUBROUTINE reduce_sum_r3
SUBROUTINE reduce_sum_r4(VarIn, VarOut)
IMPLICIT NONE
REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
#ifdef CPP_PARA
REAL :: dummy
#endif
#ifndef CPP_PARA
VarOut(:,:,:,:)=VarIn(:,:,:,:)
RETURN
#else
IF (is_root_prc) THEN
CALL reduce_sum_rgen(VarIn,Varout,SIZE(VarIn))
ELSE
CALL reduce_sum_rgen(VarIn,dummy,SIZE(VarIn))
ENDIF
#endif
END SUBROUTINE reduce_sum_r4
END MODULE transfert_para
#ifdef CPP_PARA
SUBROUTINE bcast_cgen(var,nb)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(INOUT) :: Var
INTEGER,INTENT(IN) :: nb
INCLUDE 'mpif.h'
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (check) &
WRITE(numout,*) "bcast_cgen before bcast Var",Var
IF (flag) CALL suspend_timer(timer_mpi)
CALL MPI_BCAST(Var,nb,MPI_CHARACTER,root_prc,MPI_COMM_ORCH,ierr)
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "bcast_cgen after bcast Var",Var
END SUBROUTINE bcast_cgen
SUBROUTINE bcast_igen(var,nb)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
INTEGER,INTENT(IN) :: nb
INCLUDE 'mpif.h'
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "bcast_igen before bcast Var",Var
CALL MPI_BCAST(Var,nb,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "bcast_igen after bcast Var",Var
END SUBROUTINE bcast_igen
SUBROUTINE bcast_rgen(var,nb)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
REAL,DIMENSION(nb),INTENT(INOUT) :: Var
INTEGER,INTENT(IN) :: nb
INCLUDE 'mpif.h'
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (check) &
WRITE(numout,*) "bcast_rgen before bcast Var",Var
IF (flag) CALL suspend_timer(timer_mpi)
CALL MPI_BCAST(Var,nb,MPI_REAL_ORCH,root_prc,MPI_COMM_ORCH,ierr)
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "bcast_rgen after bcast Var",Var
END SUBROUTINE bcast_rgen
SUBROUTINE bcast_lgen(var,nb)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
INTEGER,INTENT(IN) :: nb
INCLUDE 'mpif.h'
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (check) &
WRITE(numout,*) "bcast_lgen before bcast Var",Var
IF (flag) CALL suspend_timer(timer_mpi)
CALL MPI_BCAST(Var,nb,MPI_LOGICAL,root_prc,MPI_COMM_ORCH,ierr)
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "bcast_lgen after bcast Var",Var
END SUBROUTINE bcast_lgen
SUBROUTINE scatter_igen(VarIn, VarOut, dimsize)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
INTEGER,INTENT(IN),DIMENSION(nbp_glo,dimsize) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(nbp_loc,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
INTEGER,DIMENSION(dimsize*nbp_glo) :: VarTmp
INTEGER :: nb,i,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=nbp_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
DO i=1,dimsize
VarTmp(Index_Para:Index_Para+nb-1)=VarIn(nbp_para_begin(rank):nbp_para_end(rank),i)
Index_Para=Index_Para+nb
ENDDO
ENDDO
IF (check) THEN
WRITE(numout,*) "scatter_igen VarIn",VarIn
WRITE(numout,*) "scatter_igen VarTmp",VarTmp
ENDIF
ENDIF
CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INT_ORCH,VarOut,nbp_loc*dimsize, &
MPI_INT_ORCH,root_prc, MPI_COMM_ORCH,ierr)
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "scatter_igen VarOut",VarOut
END SUBROUTINE scatter_igen
SUBROUTINE scatter_rgen(VarIn, VarOut, dimsize)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
REAL,INTENT(IN),DIMENSION(nbp_glo,dimsize) :: VarIn
REAL,INTENT(OUT),DIMENSION(nbp_loc,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
REAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
INTEGER :: nb,i,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=nbp_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
DO i=1,dimsize
VarTmp(Index_Para:Index_Para+nb-1)=VarIn(nbp_para_begin(rank):nbp_para_end(rank),i)
Index_Para=Index_Para+nb
ENDDO
ENDDO
IF (check) THEN
WRITE(numout,*) "scatter_rgen VarIn",VarIn
WRITE(numout,*) "scatter_rgen VarTmp",VarTmp
ENDIF
ENDIF
CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_ORCH,VarOut,nbp_loc*dimsize, &
MPI_REAL_ORCH,root_prc, MPI_COMM_ORCH,ierr)
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "scatter_rgen VarOut",VarOut
END SUBROUTINE scatter_rgen
SUBROUTINE scatter_lgen(VarIn, VarOut, dimsize)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
LOGICAL,INTENT(IN),DIMENSION(nbp_glo,dimsize) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(nbp_loc,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
LOGICAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
INTEGER :: nb,i,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=nbp_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
DO i=1,dimsize
VarTmp(Index_Para:Index_Para+nb-1)=VarIn(nbp_para_begin(rank):nbp_para_end(rank),i)
Index_Para=Index_Para+nb
ENDDO
ENDDO
IF (check) THEN
WRITE(numout,*) "scatter_lgen VarIn",VarIn
WRITE(numout,*) "scatter_lgen VarTmp",VarTmp
ENDIF
ENDIF
CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,nbp_loc*dimsize, &
MPI_LOGICAL,root_prc, MPI_COMM_ORCH,ierr)
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "scatter_lgen VarOut",VarOut
END SUBROUTINE scatter_lgen
SUBROUTINE gather_igen(VarIn, VarOut, dimsize)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
INTEGER,INTENT(IN),DIMENSION(nbp_loc,dimsize) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(nbp_glo,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
INTEGER,DIMENSION(dimsize*nbp_glo) :: VarTmp
INTEGER :: nb,i,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
IF (check) &
WRITE(numout,*) "gather_igen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
DO rank=0,mpi_size-1
nb=nbp_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
Index_Para=Index_Para+nb*dimsize
ENDDO
IF (check) &
WRITE(numout,*) "gather_igen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
ENDIF
IF (check) &
WRITE(numout,*) "gather_igen VarIn=",VarIn
CALL MPI_GATHERV(VarIn,nbp_loc*dimsize,MPI_INT_ORCH,VarTmp,counts,displs, &
MPI_INT_ORCH,root_prc, MPI_COMM_ORCH,ierr)
IF (check) &
WRITE(numout,*) "gather_igen dimsize,VarTmp=",dimsize,VarTmp
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=nbp_para_nb(rank)
DO i=1,dimsize
VarOut(nbp_para_begin(rank):nbp_para_end(rank),i)=VarTmp(Index_Para:Index_Para+nb-1)
Index_Para=Index_Para+nb
ENDDO
ENDDO
ENDIF
IF (check) &
WRITE(numout,*) "gather_igen VarOut=",VarOut
IF (flag) CALL resume_timer(timer_mpi)
END SUBROUTINE gather_igen
SUBROUTINE gather_rgen(VarIn, VarOut, dimsize)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
REAL,INTENT(IN),DIMENSION(nbp_loc,dimsize) :: VarIn
REAL,INTENT(OUT),DIMENSION(nbp_glo,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
REAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
INTEGER :: nb,i,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
IF (check) &
WRITE(numout,*) "gather_rgen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
DO rank=0,mpi_size-1
nb=nbp_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
Index_Para=Index_Para+nb*dimsize
ENDDO
IF (check) &
WRITE(numout,*) "gather_rgen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
ENDIF
IF (check) &
WRITE(numout,*) "gather_rgen VarIn=",VarIn
CALL MPI_GATHERV(VarIn,nbp_loc*dimsize,MPI_REAL_ORCH,VarTmp,counts,displs, &
MPI_REAL_ORCH,root_prc, MPI_COMM_ORCH,ierr)
IF (check) &
WRITE(numout,*) "gather_rgen dimsize,VarTmp=",dimsize,VarTmp
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=nbp_para_nb(rank)
DO i=1,dimsize
VarOut(nbp_para_begin(rank):nbp_para_end(rank),i)=VarTmp(Index_Para:Index_Para+nb-1)
Index_Para=Index_Para+nb
ENDDO
ENDDO
ENDIF
IF (check) &
WRITE(numout,*) "gather_rgen VarOut=",VarOut
IF (flag) CALL resume_timer(timer_mpi)
END SUBROUTINE gather_rgen
SUBROUTINE gather_lgen(VarIn, VarOut, dimsize)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
LOGICAL,INTENT(IN),DIMENSION(nbp_loc,dimsize) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(nbp_glo,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
LOGICAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
INTEGER :: nb,i,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
IF (check) &
WRITE(numout,*) "gather_lgen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
DO rank=0,mpi_size-1
nb=nbp_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
Index_Para=Index_Para+nb*dimsize
ENDDO
IF (check) &
WRITE(numout,*) "gather_lgen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
ENDIF
IF (check) &
WRITE(numout,*) "gather_lgen VarIn=",VarIn
CALL MPI_GATHERV(VarIn,nbp_loc*dimsize,MPI_LOGICAL,VarTmp,counts,displs, &
MPI_LOGICAL,root_prc, MPI_COMM_ORCH,ierr)
IF (check) &
WRITE(numout,*) "gather_lgen dimsize,VarTmp=",dimsize,VarTmp
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=nbp_para_nb(rank)
DO i=1,dimsize
VarOut(nbp_para_begin(rank):nbp_para_end(rank),i)=VarTmp(Index_Para:Index_Para+nb-1)
Index_Para=Index_Para+nb
ENDDO
ENDDO
ENDIF
IF (check) &
WRITE(numout,*) "gather_lgen VarOut=",VarOut
IF (flag) CALL resume_timer(timer_mpi)
END SUBROUTINE gather_lgen
SUBROUTINE scatter2D_igen(VarIn, VarOut, dimsize)
USE data_para, iim=>iim_g,jjm=>jjm_g
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
INTEGER,INTENT(IN),DIMENSION(iim*jjm,dimsize) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(iim*jj_nb,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
INTEGER,DIMENSION(dimsize*iim*jjm) :: VarTmp1
INTEGER,DIMENSION(ij_nb,dimsize) :: VarTmp2
INTEGER :: nb,i,ij,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=ij_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
DO i=1,dimsize
VarTmp1(Index_Para:Index_Para+nb-1)=VarIn(ij_para_begin(rank):ij_para_end(rank),i)
Index_Para=Index_Para+nb
ENDDO
ENDDO
IF (check) THEN
WRITE(numout,*) "scatter2D_igen VarIn",VarIn
WRITE(numout,*) "scatter2D_igen VarTmp1",VarTmp1
ENDIF
ENDIF
CALL MPI_SCATTERV(VarTmp1,counts,displs,MPI_INT_ORCH,VarTmp2,ij_nb*dimsize, &
MPI_INT_ORCH,root_prc, MPI_COMM_ORCH,ierr)
IF (check) &
WRITE(numout,*) "scatter2D_igen VarTmp2",VarTmp2
DO i=1,dimsize
DO ij=1,ij_nb
VarOut(ij+ii_begin-1,i)=VarTmp2(ij,i)
ENDDO
ENDDO
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "scatter2D_igen VarOut",VarOut
END SUBROUTINE scatter2D_igen
SUBROUTINE scatter2D_rgen(VarIn, VarOut, dimsize)
USE data_para, iim=>iim_g,jjm=>jjm_g
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
REAL,INTENT(IN),DIMENSION(iim*jjm,dimsize) :: VarIn
REAL,INTENT(OUT),DIMENSION(iim*jj_nb,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
REAL,DIMENSION(dimsize*iim*jjm) :: VarTmp1
REAL,DIMENSION(ij_nb,dimsize) :: VarTmp2
REAL,DIMENSION(iim*jj_nb,dimsize) :: VarOut_bis
INTEGER :: nb,i,ij,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=ij_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
DO i=1,dimsize
VarTmp1(Index_Para:Index_Para+nb-1)=VarIn(ij_para_begin(rank):ij_para_end(rank),i)
Index_Para=Index_Para+nb
ENDDO
ENDDO
IF (check) THEN
WRITE(numout,*) "scatter2D_rgen VarIn",VarIn
WRITE(numout,*) "scatter2D_rgen VarTmp1",VarTmp1
ENDIF
ENDIF
CALL MPI_SCATTERV(VarTmp1,counts,displs,MPI_REAL_ORCH,VarTmp2,ij_nb*dimsize, &
MPI_REAL_ORCH,root_prc, MPI_COMM_ORCH,ierr)
IF (check) &
WRITE(numout,*) "scatter2D_rgen VarTmp2",VarTmp2
DO i=1,dimsize
DO ij=1,ij_nb
VarOut(ij+ii_begin-1,i)=VarTmp2(ij,i)
ENDDO
ENDDO
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "scatter2D_rgen VarOut",VarOut
END SUBROUTINE scatter2D_rgen
SUBROUTINE scatter2D_lgen(VarIn, VarOut, dimsize)
USE data_para, iim=>iim_g,jjm=>jjm_g
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
LOGICAL,INTENT(IN),DIMENSION(iim*jjm,dimsize) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(iim*jj_nb,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
LOGICAL,DIMENSION(dimsize*iim*jjm) :: VarTmp1
LOGICAL,DIMENSION(ij_nb,dimsize) :: VarTmp2
INTEGER :: nb,i,ij,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=ij_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
DO i=1,dimsize
VarTmp1(Index_Para:Index_Para+nb-1)=VarIn(ij_para_begin(rank):ij_para_end(rank),i)
Index_Para=Index_Para+nb
ENDDO
ENDDO
IF (check) THEN
WRITE(numout,*) "scatter2D_lgen VarIn",VarIn
WRITE(numout,*) "scatter2D_lgen VarTmp1",VarTmp1
ENDIF
ENDIF
CALL MPI_SCATTERV(VarTmp1,counts,displs,MPI_LOGICAL,VarTmp2,ij_nb*dimsize, &
MPI_LOGICAL,root_prc, MPI_COMM_ORCH,ierr)
IF (check) &
WRITE(numout,*) "scatter2D_lgen VarTmp2",VarTmp2
DO i=1,dimsize
DO ij=1,ij_nb
VarOut(ij+ii_begin-1,i)=VarTmp2(ij,i)
ENDDO
ENDDO
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "scatter2D_lgen VarOut",VarOut
END SUBROUTINE scatter2D_lgen
SUBROUTINE gather2D_igen(VarIn, VarOut, dimsize)
USE data_para, iim=>iim_g,jjm=>jjm_g
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
INTEGER,INTENT(IN),DIMENSION(iim*jj_nb,dimsize) :: VarIn
INTEGER,INTENT(OUT),DIMENSION(iim*jjm,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
INTEGER,DIMENSION(ij_nb,dimsize) :: VarTmp1
INTEGER,DIMENSION(dimsize*iim*jjm) :: VarTmp2
INTEGER :: nb,i,ij,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL,PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
IF (check) &
WRITE(numout,*) "gather2D_igen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
DO rank=0,mpi_size-1
nb=ij_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
Index_Para=Index_Para+nb*dimsize
ENDDO
IF (check) &
WRITE(numout,*) "gather2D_igen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
ENDIF
DO i=1,dimsize
DO ij=1,ij_nb
VarTmp1(ij,i)=VarIn(ij+ii_begin-1,i)
ENDDO
ENDDO
IF (check) THEN
WRITE(numout,*) "gather2D_igen VarIn=",VarIn
WRITE(numout,*) "gather2D_igen VarTmp1=",VarTmp1
ENDIF
CALL MPI_GATHERV(VarTmp1,ij_nb*dimsize,MPI_INT_ORCH,VarTmp2,counts,displs, &
MPI_INT_ORCH,root_prc, MPI_COMM_ORCH,ierr)
IF (check) &
WRITE(numout,*) "gather2D_igen VarTmp2=",VarTmp2
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=ij_para_nb(rank)
DO i=1,dimsize
VarOut(ij_para_begin(rank):ij_para_end(rank),i)=VarTmp2(Index_Para:Index_Para+nb-1)
Index_Para=Index_Para+nb
ENDDO
ENDDO
ENDIF
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "gather2D_igen VarOut=",VarOut
END SUBROUTINE gather2D_igen
SUBROUTINE gather2D_rgen(VarIn, VarOut, dimsize)
USE data_para, iim=>iim_g,jjm=>jjm_g
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
REAL,INTENT(IN),DIMENSION(iim*jj_nb,dimsize) :: VarIn
REAL,INTENT(OUT),DIMENSION(iim*jjm,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
REAL,DIMENSION(ij_nb,dimsize) :: VarTmp1
REAL,DIMENSION(dimsize*iim*jjm) :: VarTmp2
INTEGER :: nb,i,ij,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL,PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
IF (check) &
WRITE(numout,*) "gather2D_rgen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
DO rank=0,mpi_size-1
nb=ij_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
Index_Para=Index_Para+nb*dimsize
ENDDO
IF (check) &
WRITE(numout,*) "gather2D_rgen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
ENDIF
DO i=1,dimsize
DO ij=1,ij_nb
VarTmp1(ij,i)=VarIn(ij+ii_begin-1,i)
ENDDO
ENDDO
IF (check) THEN
WRITE(numout,*) "gather2D_rgen VarIn=",VarIn
WRITE(numout,*) "gather2D_rgen VarTmp1=",VarTmp1
ENDIF
CALL MPI_GATHERV(VarTmp1,ij_nb*dimsize,MPI_REAL_ORCH,VarTmp2,counts,displs, &
MPI_REAL_ORCH,root_prc, MPI_COMM_ORCH,ierr)
IF (check) &
WRITE(numout,*) "gather2D_rgen VarTmp2=",VarTmp2
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=ij_para_nb(rank)
DO i=1,dimsize
VarOut(ij_para_begin(rank):ij_para_end(rank),i)=VarTmp2(Index_Para:Index_Para+nb-1)
Index_Para=Index_Para+nb
ENDDO
ENDDO
ENDIF
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "gather2D_rgen VarOut=",VarOut
END SUBROUTINE gather2D_rgen
SUBROUTINE gather2D_lgen(VarIn, VarOut, dimsize)
USE data_para, iim=>iim_g,jjm=>jjm_g
USE timer
USE constantes
IMPLICIT NONE
INTEGER,INTENT(IN) :: dimsize
LOGICAL,INTENT(IN),DIMENSION(iim*jj_nb,dimsize) :: VarIn
LOGICAL,INTENT(OUT),DIMENSION(iim*jjm,dimsize) :: VarOut
INCLUDE 'mpif.h'
INTEGER,DIMENSION(0:mpi_size-1) :: displs
INTEGER,DIMENSION(0:mpi_size-1) :: counts
LOGICAL,DIMENSION(ij_nb,dimsize) :: VarTmp1
LOGICAL,DIMENSION(dimsize*iim*jjm) :: VarTmp2
INTEGER :: nb,i,ij,index_para,rank
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL,PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (flag) CALL suspend_timer(timer_mpi)
IF (is_root_prc) THEN
Index_Para=1
IF (check) &
WRITE(numout,*) "gather2D_lgen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
DO rank=0,mpi_size-1
nb=ij_para_nb(rank)
displs(rank)=Index_Para-1
counts(rank)=nb*dimsize
Index_Para=Index_Para+nb*dimsize
ENDDO
IF (check) &
WRITE(numout,*) "gather2D_lgen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
ENDIF
DO i=1,dimsize
DO ij=1,ij_nb
VarTmp1(ij,i)=VarIn(ij+ii_begin-1,i)
ENDDO
ENDDO
IF (check) THEN
WRITE(numout,*) "gather2D_lgen VarIn=",VarIn
WRITE(numout,*) "gather2D_lgen VarTmp1=",VarTmp1
ENDIF
CALL MPI_GATHERV(VarTmp1,ij_nb*dimsize,MPI_LOGICAL,VarTmp2,counts,displs, &
MPI_LOGICAL,root_prc, MPI_COMM_ORCH,ierr)
IF (check) &
WRITE(numout,*) "gather2D_lgen VarTmp2=",VarTmp2
IF (is_root_prc) THEN
Index_Para=1
DO rank=0,mpi_size-1
nb=ij_para_nb(rank)
DO i=1,dimsize
VarOut(ij_para_begin(rank):ij_para_end(rank),i)=VarTmp2(Index_Para:Index_Para+nb-1)
Index_Para=Index_Para+nb
ENDDO
ENDDO
ENDIF
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "gather2D_lgen VarOut=",VarOut
END SUBROUTINE gather2D_lgen
SUBROUTINE reduce_sum_igen(VarIn,VarOut,nb)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut
INTEGER,INTENT(IN) :: nb
INCLUDE 'mpif.h'
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (check) &
WRITE(numout,*) "reduce_sum_igen VarIn",VarIn
IF (flag) CALL suspend_timer(timer_mpi)
CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INT_ORCH,MPI_SUM,root_prc,MPI_COMM_ORCH,ierr)
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "reduce_sum_igen VarOut",VarOut
END SUBROUTINE reduce_sum_igen
SUBROUTINE reduce_sum_rgen(VarIn,VarOut,nb)
USE data_para
USE timer
USE constantes
IMPLICIT NONE
REAL,DIMENSION(nb),INTENT(IN) :: VarIn
REAL,DIMENSION(nb),INTENT(OUT) :: VarOut
INTEGER,INTENT(IN) :: nb
INCLUDE 'mpif.h'
INTEGER :: ierr
LOGICAL :: flag=.FALSE.
LOGICAL, PARAMETER :: check=.FALSE.
IF (timer_state(timer_mpi)==running) THEN
flag=.TRUE.
ELSE
flag=.FALSE.
ENDIF
IF (check) &
WRITE(numout,*) "reduce_sum_rgen VarIn",VarIn
IF (flag) CALL suspend_timer(timer_mpi)
CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_ORCH,MPI_SUM,root_prc,MPI_COMM_ORCH,ierr)
IF (flag) CALL resume_timer(timer_mpi)
IF (check) &
WRITE(numout,*) "reduce_sum_rgen VarOut",VarOut
END SUBROUTINE reduce_sum_rgen
subroutine stopit
USE ioipsl
call MPI_FINALIZE
CALL ipslerr (3,'transfert_para : gather', &
& 'A gather function was called with a VarIn',&
& ' which size is only one.', &
& '(must be strickly greater than one )')
end subroutine stopit
#endif
ORCHIDEE/src_parallel/write_field.f90 0000754 0103600 0005670 00000000345 11164403473 017207 0 ustar acamlmd lmdjus ! Yann Meurdesoif module for sequentiel tests.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/write_field.f90,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
!-
MODULE Write_Field
USE Orch_Write_Field
END MODULE Write_Field
ORCHIDEE/src_parallel/write_field_p.f90 0000754 0103600 0005670 00000000353 11164403473 017525 0 ustar acamlmd lmdjus ! Yann Meurdesoif module for parallel tests.
!-
!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/write_field_p.f90,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
!-
MODULE Write_field_p
USE Orch_Write_Field_p
END MODULE Write_field_p
ORCHIDEE/src_parallel/Makefile 0000754 0103600 0005670 00000005001 11164403473 016024 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.3 2008/01/08 11:49:07 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a PARALLEL
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
ORDIR = ..
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/libparallel.a
SXMODEL_LIB = $(MODEL_LIB)
#-
#- $Id: AA_make.gdef 578 2009-03-13 14:05:38Z bellier $
#-
#- Global definitions for gnu g95 compiler
M_K = gmake
P_C = cpp
P_O = -P -C -traditional $(P_P)
F_C = g95 -c
F_D =
F_P = -i4 -r8
w_w = -O5 -cpp -funroll-all-loops $(F_D) $(F_P) -I$(MODDIR)
#####################################-Q- g95 F_O = $(w_w) -fmod=$(MODDIR) -fno-second-underscore
F_O = $(w_w) -fmod=$(MODDIR)
F_L = g95
M_M = 0
L_X = 0
L_O =
A_C = ar -r
A_G = ar -x
C_C = cc -c
C_O =
C_L = cc
#-
NCDF_INC = /d4/acamlmd/LMDZ4V4/netcdf-3.6.1/include
NCDF_LIB = -L/d4/acamlmd/LMDZ4V4/netcdf-3.6.1/lib -lnetcdf
#-
RM = rm -f
STRIP = strip
SIZE = size
#-
#- $Id: AA_make,v 1.5 2008/01/08 11:49:07 ssipsl Exp $
#-
MODS1 = timer.f90 \
data_para.f90 \
transfert_para.f90 \
ioipsl_para.f90 \
tools_para.f90 \
parallel.f90
#\
# orch_write_field.f90 \
# write_field.f90 \
# orch_write_field_p.f90\
# write_field_p.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-
all:
$(M_K) m_all
@echo parallel is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
$(MODEL_LIB)(%.o) : %.f90
$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
$(A_C) $(MODEL_LIB) $*.o
$(RM) $*.o
config :
$(BINDIR)/Fparser -name PARALLEL $(MODS1)
echo 'Configuration of PARALLEL done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(mpi_dummy.o):
$(MODEL_LIB)(timer.o):
$(MODEL_LIB)(data_para.o):
$(MODEL_LIB)(orch_write_field.o):
$(MODEL_LIB)(write_field_p.o): \
$(MODEL_LIB)(orch_write_field.o)
$(MODEL_LIB)(transfert_para.o): \
$(MODEL_LIB)(timer.o) \
$(MODEL_LIB)(data_para.o) \
$(MODEL_LIB)(ioipsl_para.o): \
$(MODEL_LIB)(transfert_para.o) \
$(MODEL_LIB)(data_para.o)
$(MODEL_LIB)(tools_para.o): \
$(MODEL_LIB)(timer.o) \
$(MODEL_LIB)(data_para.o)
$(MODEL_LIB)(orch_write_field_p.o): \
$(MODEL_LIB)(parallel.o)
$(MODEL_LIB)(write_field_p.o): \
$(MODEL_LIB)(parallel.o) \
$(MODEL_LIB)(orch_write_field_p.o)
$(MODEL_LIB)(parallel.o): \
$(MODEL_LIB)(data_para.o) \
$(MODEL_LIB)(transfert_para.o) \
$(MODEL_LIB)(ioipsl_para.o)
ORCHIDEE/src_parameters/ 0000754 0103600 0005670 00000000000 11202267307 014731 5 ustar acamlmd lmdjus ORCHIDEE/src_parameters/CVS/ 0000754 0103600 0005670 00000000000 11164403473 015367 5 ustar acamlmd lmdjus ORCHIDEE/src_parameters/CVS/Root 0000754 0103600 0005670 00000000071 11164403473 016236 0 ustar acamlmd lmdjus :pserver:sechiba@cvs.ipsl.jussieu.fr:/home/ssipsl/CVSREP
ORCHIDEE/src_parameters/CVS/Repository 0000754 0103600 0005670 00000000030 11164403473 017465 0 ustar acamlmd lmdjus ORCHIDEE/src_parameters
ORCHIDEE/src_parameters/CVS/Entries 0000754 0103600 0005670 00000000562 11164403473 016731 0 ustar acamlmd lmdjus /AA_make/1.13/Tue Nov 7 07:57:08 2006//Torchidee_1_9
/AA_make.ldef/1.6/Tue Nov 7 07:57:08 2006//Torchidee_1_9
/constantes.f90/1.15/Tue Jun 12 19:18:21 2007//Torchidee_1_9
/constantes_co2.f90/1.10/Mon May 28 15:28:05 2007//Torchidee_1_9
/constantes_soil.f90/1.7/Mon May 28 15:21:42 2007//Torchidee_1_9
/constantes_veg.f90/1.29/Tue Jun 12 19:18:21 2007//Torchidee_1_9
D
ORCHIDEE/src_parameters/CVS/Tag 0000754 0103600 0005670 00000000016 11164403473 016025 0 ustar acamlmd lmdjus Norchidee_1_9
ORCHIDEE/src_parameters/CVS/Template 0000754 0103600 0005670 00000000000 11164403473 017056 0 ustar acamlmd lmdjus ORCHIDEE/src_parameters/AA_make 0000754 0103600 0005670 00000003152 11164403473 016141 0 ustar acamlmd lmdjus #-
#- $Id: AA_make,v 1.16 2008/01/08 11:49:07 ssipsl Exp $
#-
IOIPSL_LIB = $(LIBDIR)/libioipsl.a
SXIOIPSL_LIB = $(IOIPSL_LIB)
#-Q- sxnec SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a
#-Q- sx6nec SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a
#-Q- eshpux SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a
#-Q- sx8brodie SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a
#-
MODS1 = constantes.f90 \
constantes_veg.f90 \
constantes_soil.f90 \
constantes_co2.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-Q- sxnec .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
#-
all:
$(M_K) libioipsl
$(M_K) m_all
@echo parameter is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
libioipsl:
(cd ../../IOIPSL/src; $(M_K) -f Makefile)
$(MODEL_LIB)(%.o): %.f90
$(F_C) $(F_O) $*.f90
$(A_C) $(MODEL_LIB) $*.o
#-Q- sxnec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sxnec mv $*.mod $(MODDIR)
#-Q- sx6nec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx6nec mv $*.mod $(MODDIR)
#-Q- eshpux $(A_X) $(SXMODEL_LIB) $*.o
#-Q- eshpux mv $*.mod $(MODDIR)
#-Q- sx8mercure mv $*.mod $(MODDIR)
#-Q- sx8brodie $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx8brodie mv $*.mod $(MODDIR)
#-Q- solaris mv $*.mod $(MODDIR)
$(RM) $*.o
config:
$(BINDIR)/Fparser -name PARAMETERS $(MODS1)
echo 'Configuration of PARAMETERS done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(constantes_co2.o): \
$(MODEL_LIB)(constantes_veg.o)
$(MODEL_LIB)(constantes_veg.o): \
$(MODEL_LIB)(constantes_soil.o)
$(MODEL_LIB)(constantes_soil.o): \
$(MODEL_LIB)(constantes.o)
$(MODEL_LIB)(constantes.o): \
$(IOIPSL_LIB)
ORCHIDEE/src_parameters/AA_make.ldef 0000754 0103600 0005670 00000001367 11164403473 017060 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.7 2008/01/08 11:49:07 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a PARAMETER
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/libparameters.a
SXMODEL_LIB = $(MODEL_LIB)
#-Q- sxnec SXMODEL_LIB = $(LIBDIR)/libsxparameters.a
#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxparameters.a
#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxparameters.a
#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxparameters.a
ORCHIDEE/src_parameters/constantes.f90 0000754 0103600 0005670 00000005127 11164403473 017445 0 ustar acamlmd lmdjus !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parameters/constantes.f90,v 1.15 2007/06/12 19:18:21 ssipsl Exp $
!IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!-
MODULE constantes
!!--------------------------------------------------------------------
!! "constantes" module contains some public technical constants
!!--------------------------------------------------------------------
USE defprec
!-
IMPLICIT NONE
!-
! Unit for output messages
INTEGER(i_std), SAVE :: numout = 6
!-
! To set for more printing
LOGICAL,SAVE :: long_print = .FALSE.
!-
! One of the most frequent problems is a temperature out of range
! we provide here a way to catch that in the calling procedure. (JP)
LOGICAL,PARAMETER :: diag_qsat = .TRUE.
!-
! Selects the type of output for the model.
! Value is read from run.def in intersurf_history.
LOGICAL :: almaoutput
!-
! One day in seconds
REAL(r_std),SAVE :: one_day
! One year in seconds
REAL(r_std),SAVE :: one_year
!-
! No comment
REAL(r_std),PARAMETER :: pi=3.141592653589793238
!-
! 0 degre Celsius in degre Kelvin
REAL(r_std),PARAMETER :: tp_00=273.15
!-
! Specific value if no restart value
REAL(r_std),SAVE :: val_exp = 999999.
!-
! Epsilon to detect a near zero floating point
REAL(r_std),PARAMETER :: min_sechiba = 1.E-8_r_std
! The undef value used in SECHIBA
REAL(r_std),PARAMETER :: undef_sechiba = 1.E+20_r_std
! The undef value used in SECHIBA
INTEGER(i_std),PARAMETER :: undef_int = 999999999
!-
! Numerical constant set to 0
REAL(r_std),PARAMETER :: zero = 0._r_std
! Numerical constant set to 1/2
REAL(r_std),PARAMETER :: undemi = 0.5_r_std
! Numerical constant set to 1
REAL(r_std),PARAMETER :: un = 1._r_std
! Numerical constant set to -1
REAL(r_std),PARAMETER :: moins_un = -1._r_std
! Numerical constant set to 2
REAL(r_std),PARAMETER :: deux = 2._r_std
! Numerical constant set to 3
REAL(r_std),PARAMETER :: trois = 3._r_std
! Numerical constant set to 4
REAL(r_std),PARAMETER :: quatre = 4._r_std
! Numerical constant set to 5
REAL(r_std),PARAMETER :: cinq = 5._r_std
! Numerical constant set to 6
REAL(r_std),PARAMETER :: six = 6._r_std
! Numerical constant set to 8
REAL(r_std),PARAMETER :: huit = 8._r_std
! Numerical constant set to 1000
REAL(r_std),PARAMETER :: mille = 1000._r_std
!-
TYPE control_type
LOGICAL :: river_routing
LOGICAL :: hydrol_cwrr
LOGICAL :: ok_sechiba
LOGICAL :: ok_co2
LOGICAL :: ok_stomate
LOGICAL :: ok_dgvm
LOGICAL :: stomate_watchout
LOGICAL :: ok_pheno
END TYPE control_type
!--------------------
END MODULE constantes
ORCHIDEE/src_parameters/constantes_co2.f90 0000754 0103600 0005670 00000006621 11164403473 020210 0 ustar acamlmd lmdjus !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parameters/constantes_co2.f90,v 1.10 2007/05/28 15:28:05 ssipsl Exp $
!IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!-
MODULE constantes_co2
!!--------------------------------------------------------------------
!! "constantes_co2" module contains some public technical constants
!!--------------------------------------------------------------------
USE constantes_veg
!-
IMPLICIT NONE
!-
! indices for assimilation parameters
!-
INTEGER(i_std),PARAMETER :: itmin = 1
INTEGER(i_std),PARAMETER :: itopt = 2
INTEGER(i_std),PARAMETER :: itmax = 3
INTEGER(i_std),PARAMETER :: ivcmax = 4
INTEGER(i_std),PARAMETER :: ivjmax = 5
INTEGER(i_std),PARAMETER :: npco2 = 5
!-
!!
!! The following tables of parameters for SECHIBA
!! are in the following order :
!!
!! 1 - Bare soil
!! 2 - tropical broad-leaved evergreen
!! 3 - tropical broad-leaved raingreen
!! 4 - temperate needleleaf evergreen
!! 5 - temperate broad-leaved evergreen
!! 6 - temperate broad-leaved summergreen
!! 7 - boreal needleleaf evergreen
!! 8 - boreal broad-leaved summergreen
!! 9 - boreal needleleaf summergreen
!! 10 - C3 grass
!! 11 - C4 grass
!! 12 - C3 agriculture
!! 13 - C4 agriculture
!!
! flag for C4 vegetation types
LOGICAL,DIMENSION(nvm),SAVE :: &
& is_c4 = (/.false.,.false.,.false.,.false.,.false.,.false., &
& .false.,.false.,.false.,.false.,.true.,.false.,.true. /)
! Slope of the gs/A relation (Ball & al.)
REAL(r_std),DIMENSION(nvm),SAVE :: &
& gsslope = (/0., 9., 9., 9., 9., 9., 9., 9., 9., 9., 3., 9., 3./)
! intercept of the gs/A relation (Ball & al.)
REAL(r_std),DIMENSION(nvm),SAVE :: &
& gsoffset = (/0.0, 0.01, 0.01, 0.01, 0.01, 0.01, &
& 0.01, 0.01, 0.01, 0.01, 0.03, 0.01, 0.03/)
! values used for vcmax when STOMATE is not activated
REAL(r_std),DIMENSION(nvm),SAVE :: &
& vcmax_fix = (/ 0., 40., 50., 30., 35., 40., &
& 30., 40., 35., 60., 60., 70., 70. /)
! values used for vjmax when STOMATE is not activated
REAL(r_std),DIMENSION(nvm),SAVE :: &
& vjmax_fix = (/ 0., 80., 100., 60., 70., 80., &
& 60., 80., 70., 120., 120., 140., 140. /)
! values used for photosynthesis tmin when STOMATE is not activated
REAL(r_std),DIMENSION(nvm),SAVE :: &
& co2_tmin_fix = (/ 0., 2., 2., -4., -3., -2., &
& -4., -4., -4., -5., 6., -5., 6. /)
! values used for photosynthesis topt when STOMATE is not activated
REAL(r_std),DIMENSION(nvm),SAVE :: &
& co2_topt_fix = (/ 0., 27.5, 27.5, 17.5, 25., 20., &
& 17.5, 17.5, 17.5, 20., 32.5, 20., 32.5 /)
! values used for photosynthesis tmax when STOMATE is not activated
REAL(r_std),DIMENSION(nvm),SAVE :: &
& co2_tmax_fix = (/ 0., 55., 55., 38., 48., 38., &
& 38., 38., 38., 45., 55., 45., 55. /)
! extinction coefficient of the Monsi&Seaki relationship (1953)
REAL(r_std),DIMENSION(nvm),SAVE :: &
& ext_coef = (/.5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5/)
! NV080800 Name of STOMATE forcing file
CHARACTER(LEN=100) :: stomate_forcing_name='NONE'
! NV080800 Name of soil forcing file
CHARACTER(LEN=100) :: stomate_Cforcing_name='NONE'
!-
INTEGER(i_std),SAVE :: forcing_id
!------------------------
END MODULE constantes_co2
ORCHIDEE/src_parameters/Makefile 0000754 0103600 0005670 00000004041 11164403473 016376 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.7 2008/01/08 11:49:07 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a PARAMETER
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/libparameters.a
SXMODEL_LIB = $(MODEL_LIB)
#-
#- $Id: AA_make.gdef 578 2009-03-13 14:05:38Z bellier $
#-
#- Global definitions for gnu g95 compiler
M_K = gmake
P_C = cpp
P_O = -P -C -traditional $(P_P)
F_C = g95 -c
F_D =
F_P = -i4 -r8
w_w = -O5 -cpp -funroll-all-loops $(F_D) $(F_P) -I$(MODDIR)
#####################################-Q- g95 F_O = $(w_w) -fmod=$(MODDIR) -fno-second-underscore
F_O = $(w_w) -fmod=$(MODDIR)
F_L = g95
M_M = 0
L_X = 0
L_O =
A_C = ar -r
A_G = ar -x
C_C = cc -c
C_O =
C_L = cc
#-
NCDF_INC = /d4/acamlmd/LMDZ4V4/netcdf-3.6.1/include
NCDF_LIB = -L/d4/acamlmd/LMDZ4V4/netcdf-3.6.1/lib -lnetcdf
#-
RM = rm -f
STRIP = strip
SIZE = size
#-
#- $Id: AA_make,v 1.16 2008/01/08 11:49:07 ssipsl Exp $
#-
IOIPSL_LIB = $(LIBDIR)/libioipsl.a
SXIOIPSL_LIB = $(IOIPSL_LIB)
#-
MODS1 = constantes.f90 \
constantes_veg.f90 \
constantes_soil.f90 \
constantes_co2.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-
all:
$(M_K) libioipsl
$(M_K) m_all
@echo parameter is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
libioipsl:
(cd ../../IOIPSL/src; $(M_K) -f Makefile)
$(MODEL_LIB)(%.o): %.f90
$(F_C) $(F_O) $*.f90
$(A_C) $(MODEL_LIB) $*.o
$(RM) $*.o
config:
$(BINDIR)/Fparser -name PARAMETERS $(MODS1)
echo 'Configuration of PARAMETERS done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(constantes_co2.o): \
$(MODEL_LIB)(constantes_veg.o)
$(MODEL_LIB)(constantes_veg.o): \
$(MODEL_LIB)(constantes_soil.o)
$(MODEL_LIB)(constantes_soil.o): \
$(MODEL_LIB)(constantes.o)
$(MODEL_LIB)(constantes.o): \
$(IOIPSL_LIB)
ORCHIDEE/src_parameters/constantes_soil.f90 0000754 0103600 0005670 00000025526 11164403473 020500 0 ustar acamlmd lmdjus !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parameters/constantes_soil.f90,v 1.7 2007/05/28 15:21:42 ssipsl Exp $
!IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!-
MODULE constantes_soil
!!--------------------------------------------------------------------
!! "constantes_soil" module contains public data for the soils
!!--------------------------------------------------------------------
USE constantes
!-
IMPLICIT NONE
!
LOGICAL, SAVE :: check_waterbal=.TRUE. !! The check the water balance
LOGICAL, SAVE :: waterbal_error=.FALSE. !! If true the water balance is bad
!-
! Dimensioning parameters
!-
! Number of soil level
INTEGER(i_std),PARAMETER :: ngrnd=7
! Number of diagnostic levels in the soil
INTEGER(i_std),PARAMETER :: nbdl=11
! Number of levels max in CWRR. nslm=nbdl or nslm>nslm in case of
! variable soil depth. Be careful not to assume equality in the code
INTEGER(i_std),SAVE :: nslm=11
! Maximum depth of soil reservoir. It is fixed accordingly to nslm above (11 -> 2)
! If a depth map is given, nbdl, and nslm will be put to nslm_max and dpu_max will be changed
! in intersurf
REAL(r_std),SAVE :: dpu_max=2.0_r_std
! Number of levels min and max in CWRR (used only when a depth map is given)
INTEGER(i_std),PARAMETER :: nslm_min=10
INTEGER(i_std),PARAMETER :: nslm_max=13
! Number of soil textures (Silt, Sand, Clay)
INTEGER(i_std),PARAMETER :: ntext=3
! Number of soil tiles
INTEGER(i_std), PARAMETER :: nstm=3
! Number of soil classes
! For FAO Classification
INTEGER(i_std),PARAMETER :: nscm_fao=3
! For USDA Classification
INTEGER(i_std),PARAMETER :: nscm_usda=12
INTEGER(i_std), SAVE :: nscm=nscm_fao
!-
!- Parameters for soil thermodynamics
!-
! Average Thermal Conductivity of soils
REAL(r_std),PARAMETER :: so_cond = 1.5396
! Average Heat capacity of soils
REAL(r_std),PARAMETER :: so_capa = 2.0514e+6
!-
! Values taken from : PIELKE,'MESOSCALE METEOROLOGICAL MODELING',P.384
! Dry soil heat capacity was decreased and conductivity increased.
!-
! Dry soil Heat capacity of soils
!*REAL(r_std),PARAMETER :: so_capa_dry = 1.35e+6
REAL(r_std),PARAMETER :: so_capa_dry = 1.80e+6
! Dry soil Thermal Conductivity of soils
!*REAL(r_std),PARAMETER :: so_cond_dry = 0.28
REAL(r_std),PARAMETER :: so_cond_dry = 0.40
!-
! Wet soil Heat capacity of soils
REAL(r_std),PARAMETER :: so_capa_wet = 3.03e+6
! Wet soil Thermal Conductivity of soils
REAL(r_std),PARAMETER :: so_cond_wet = 1.89
!-
! Thermal Conductivity of snow
REAL(r_std),PARAMETER :: sn_cond = 0.3
! Snow density for the soil thermodynamics
REAL(r_std),PARAMETER :: sn_dens = 330.0
! Heat capacity for snow
REAL(r_std),PARAMETER :: sn_capa = 2100.0_r_std*sn_dens
!-
! Constantes from the Choisnel hydrology
!-
! Wilting point (Has a numerical role for the moment)
REAL(r_std),PARAMETER :: qwilt = 5.0
! Total depth of soil reservoir (for hydrolc)
REAL(r_std),SAVE :: dpu_cste=2.0_r_std
! The minimal size we allow for the upper reservoir (m)
REAL(r_std),PARAMETER :: min_resdis = 2.e-5
! Diffusion constant for the slow regime
! (This is for the diffusion between reservoirs)
REAL(r_std),PARAMETER :: min_drain = 0.001
! Diffusion constant for the fast regime
REAL(r_std),PARAMETER :: max_drain = 0.1
! The exponential in the diffusion law
REAL(r_std),PARAMETER :: exp_drain = 1.5
! Transforms leaf area index into size of interception reservoir
REAL(r_std),SAVE :: qsintcst = 0.1
! Maximum quantity of water (Kg/M3)
REAL(r_std),PARAMETER :: mx_eau_eau = 150.
!-
! Constant in the computation of resistance for bare soil evaporation
REAL(r_std),PARAMETER :: rsol_cste = 33.E3
! Scaling depth for litter humidity (m)
REAL(r_std),PARAMETER :: hcrit_litter=0.03
! Default mean slope coefficient for reinfiltration
REAL(r_std),SAVE :: slope_default=0.1
!-
! Parameters specific for the CWRR hydrology.
!-
!-
!- 1. Parameters for FAO Classification
!-
!-
! Parameters for soil type distribution
!-
! Default soil texture distribution in the following order :
! COARSE, MEDIUM, FINE
REAL(r_std),DIMENSION(nscm_fao),SAVE :: soilclass_default_fao = &
& (/ 0.28, 0.52, 0.20 /)
REAL(r_std),DIMENSION(nscm_fao*2-1),SAVE :: soilclass_default_fao2 = &
& (/ 0.28, 0.0, 0.52, 0.0, 0.20 /)
INTEGER, SAVE :: jsc_default = 2
! Van genuchten coefficient n
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: nvan_fao = &
& (/ 1.89_r_std, 1.56_r_std, 1.31_r_std /)
! Van genuchten coefficient a (cm^{-1}) BIG BUG -> mm^{-1}
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: avan_fao = &
& (/ 0.0075_r_std, 0.0036_r_std, 0.0019_r_std /)
! & (/ 0.075_r_std, 0.036_r_std, 0.019_r_std /)
! & (/ 0.036_r_std, 0.036_r_std, 0.036_r_std /)
! Residual soil water content
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mcr_fao = &
& (/ 0.065_r_std, 0.078_r_std, 0.095_r_std /)
! Saturated soil water content
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mcs_fao = &
& (/ 0.41_r_std, 0.43_r_std, 0.41_r_std /)
! Hydraulic conductivity Saturation (mm/d)
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: ks_fao = &
& (/ 1060.8_r_std, 249.6_r_std, 62.4_r_std /)
! Fraction of saturated volumetric soil moisture above which transpir is max
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: pcent_fao = &
& (/ 0.5_r_std, 0.5_r_std, 0.5_r_std /)
! Max value of the permeability coeff at the bottom of the soil
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: free_drain_max_fao = &
& (/ 1.0_r_std, 1.0_r_std, 1.0_r_std /)
! Volumetric water content field capacity
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mcf_fao = &
& (/ 0.32_r_std, 0.32_r_std, 0.32_r_std /)
! Volumetric water content Wilting pt
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mcw_fao = &
& (/ 0.10_r_std, 0.10_r_std, 0.10_r_std /)
! & (/ 0.07_r_std, 0.085_r_std, 0.10_r_std /)
! Vol. wat. cont. above which albedo is cst
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mc_awet_fao = &
& (/ 0.25_r_std, 0.25_r_std, 0.25_r_std /)
! Vol. wat. cont. below which albedo is cst
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: mc_adry_fao = &
& (/ 0.1_r_std, 0.1_r_std, 0.1_r_std /)
! Matrix potential at saturation (mm)
REAL(r_std),PARAMETER,DIMENSION(nscm_fao) :: psis_fao = &
& (/ -300.0_r_std, -300.0_r_std, -300.0_r_std /)
!-
!- 2. Parameters for USDA Classification
!-
!-
! Parameters for soil type distribution
!-
! Default soil texture distribution in the following order :
! sand, loam and clay ??? OR COARSE, MEDIUM, FINE???
REAL(r_std),DIMENSION(nscm_usda),SAVE :: soilclass_default_usda = &
& (/ 0.28, 0.52, 0.20, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 /)
! Van genuchten coefficient n
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: nvan_usda = &
& (/ 2.68_r_std, 2.28_r_std, 1.89_r_std, 1.41_r_std, &
& 1.37_r_std, 1.56_r_std, 1.48_r_std, 1.23_r_std, &
& 1.31_r_std, 1.23_r_std, 1.09_r_std, 1.09_r_std /)
! Van genuchten coefficient a (cm^{-1}) BIG BUG!!! -> mm^{-1}
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: avan_usda = &
& (/ 0.0145_r_std, 0.0124_r_std, 0.0075_r_std, 0.0020_r_std, &
& 0.0016_r_std, 0.0036_r_std, 0.0059_r_std, 0.0010_r_std, &
& 0.0019_r_std, 0.0027_r_std, 0.0005_r_std, 0.0008_r_std /)
! & (/ 0.145_r_std, 0.124_r_std, 0.075_r_std, 0.020_r_std, &
! & 0.016_r_std, 0.036_r_std, 0.059_r_std, 0.010_r_std, &
! & 0.019_r_std, 0.027_r_std, 0.005_r_std, 0.008_r_std /)
! Sand, Loamy Sand, Sandy Loam, Silt Loam, Silt, Loam, Sandy Clay Loam, Silty Clay Loam, Clay Loam, Sandy Clay, Silty Clay, Clay
! Residual soil water content
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mcr_usda = &
& (/ 0.045_r_std, 0.057_r_std, 0.065_r_std, 0.067_r_std, &
& 0.034_r_std, 0.078_r_std, 0.100_r_std, 0.089_r_std, &
& 0.095_r_std, 0.100_r_std, 0.070_r_std, 0.068_r_std /)
! Saturated soil water content
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mcs_usda = &
& (/ 0.43_r_std, 0.41_r_std, 0.41_r_std, 0.45_r_std, &
& 0.46_r_std, 0.43_r_std, 0.39_r_std, 0.43_r_std, &
& 0.41_r_std, 0.38_r_std, 0.36_r_std, 0.38_r_std /)
! Hydraulic conductivity Saturation (mm/d)
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: ks_usda = &
& (/ 7128.0_r_std, 3501.6_r_std, 1060.8_r_std, 108.0_r_std, &
& 60.0_r_std, 249.6_r_std, 314.4_r_std, 16.8_r_std, &
& 62.4_r_std, 28.8_r_std, 4.8_r_std, 48.0_r_std /)
! Soil moisture above which transpir is max
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: pcent_usda = &
& (/ 0.5_r_std, 0.5_r_std, 0.5_r_std, 0.5_r_std, &
& 0.5_r_std, 0.5_r_std, 0.5_r_std, 0.5_r_std, &
& 0.5_r_std, 0.5_r_std, 0.5_r_std, 0.5_r_std /)
! Max value of the permeability coeff at the bottom of the soil
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: free_drain_max_usda = &
& (/ 1.0_r_std, 1.0_r_std, 1.0_r_std, 1.0_r_std, &
& 1.0_r_std, 1.0_r_std, 1.0_r_std, 1.0_r_std, &
& 1.0_r_std, 1.0_r_std, 1.0_r_std, 1.0_r_std /)
! Volumetric water content field capacity
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mcf_usda = &
& (/ 0.32_r_std, 0.32_r_std, 0.32_r_std, 0.32_r_std, &
& 0.32_r_std, 0.32_r_std, 0.32_r_std, 0.32_r_std, &
& 0.32_r_std, 0.32_r_std, 0.32_r_std, 0.32_r_std /)
! Volumetric water content Wilting pt
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mcw_usda = &
& (/ 0.10_r_std, 0.10_r_std, 0.10_r_std, 0.10_r_std, &
& 0.10_r_std, 0.10_r_std, 0.10_r_std, 0.10_r_std, &
& 0.10_r_std, 0.10_r_std, 0.10_r_std, 0.10_r_std /)
! Vol. wat. cont. above which albedo is cst
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mc_awet_usda = &
& (/ 0.25_r_std, 0.25_r_std, 0.25_r_std, 0.25_r_std, &
& 0.25_r_std, 0.25_r_std, 0.25_r_std, 0.25_r_std, &
& 0.25_r_std, 0.25_r_std, 0.25_r_std, 0.25_r_std /)
! Vol. wat. cont. below which albedo is cst
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: mc_adry_usda = &
& (/ 0.1_r_std, 0.1_r_std, 0.1_r_std, 0.1_r_std, &
& 0.1_r_std, 0.1_r_std, 0.1_r_std, 0.1_r_std, &
& 0.1_r_std, 0.1_r_std, 0.1_r_std, 0.1_r_std /)
! Matrix potential at saturation (mm)
REAL(r_std),PARAMETER,DIMENSION(nscm_usda) :: psis_usda = &
& (/ -300.0_r_std, -300.0_r_std, -300.0_r_std, -300.0_r_std, &
& -300.0_r_std, -300.0_r_std, -300.0_r_std, -300.0_r_std, &
& -300.0_r_std, -300.0_r_std, -300.0_r_std, -300.0_r_std /)
! CWRR linearisation
INTEGER(i_std),PARAMETER :: imin = 1
! number of interval for CWRR
INTEGER(i_std),PARAMETER :: nbint = 50
! number of points for CWRR
INTEGER(i_std),PARAMETER :: imax = nbint+1
! Time weighting for discretisation
REAL(r_std),PARAMETER :: w_time = 1.0_r_std
!-
! Diagnostic variables
!-
! The lower limit of the layer on which soil moisture (relative)
! and temperature are going to be diagnosed.
! These variables are made for transfering the information
! to the biogeophyical processes modelled in STOMATE.
!
!- diag_lev is computed until nslm_max in order to provide the depth
!- for the outputs if the soil depth is variable
REAL(r_std),DIMENSION(nslm_max),SAVE :: diaglev
!-------------------------
END MODULE constantes_soil
ORCHIDEE/src_parameters/constantes_veg.f90~ 0000754 0103600 0005670 00000106755 11202263126 020505 0 ustar acamlmd lmdjus !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parameters/constantes_veg.f90,v 1.29 2007/06/12 19:18:21 ssipsl Exp $
!IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!-
MODULE constantes_veg
!!--------------------------------------------------------------------
!! "constantes_soil" module contains public physical constantes
!! and public tools functions like qsat, dev_qsat
!!--------------------------------------------------------------------
USE IOIPSL
USE constantes_soil
!-
IMPLICIT NONE
!-
LOGICAL,SAVE :: l_qsat_first=.TRUE.
!-
! Flags that (de)activate parts of the model
TYPE(control_type),SAVE :: control
!-
! Number of vegetation types
INTEGER(i_std),PARAMETER :: nvm=13
! Number of other surface types: land ice (lakes,cities, ...)
INTEGER(i_std),PARAMETER :: nnobio=1
!-
! Index for land ice (see nnobio)
INTEGER(i_std),PARAMETER :: iice = 1
! The maximum mass (kg/m^2) of a glacier.
REAL(r_std),PARAMETER :: maxmass_glacier = 3000.
!-
! Minimal fraction of mesh a vegetation type can occupy
REAL(r_std),PARAMETER :: min_vegfrac=0.001
!-
! Constant in the computation of surface resistance
REAL(r_std),PARAMETER :: defc_plus=23.E-3
! Constant in the computation of surface resistance
REAL(r_std),PARAMETER :: defc_mult=1.5
!-
! Limit of air temperature for snow
REAL(r_std),PARAMETER :: tsnow=273.
!-
! Sets the amount above which only sublimation occures [Kg/m^2]
REAL(r_std),PARAMETER :: snowcri=1.5
! Critical value for computation of snow albedo [Kg/m^2]
REAL(r_std),PARAMETER :: snowcri_alb=10.
! Lower limit of snow amount
REAL(r_std),PARAMETER :: sneige=snowcri/1000._r_std
! Latent heat of sublimation
REAL(r_std),PARAMETER :: chalsu0 = 2.8345E06
! Latent heat of evaporation
REAL(r_std),PARAMETER :: chalev0 = 2.5008E06
! Latent heat of evaporation 2 (?)
REAL(r_std),PARAMETER :: chalev1 = 2.5008E06
! Latent heat of fusion
REAL(r_std),PARAMETER :: chalfu0 = chalsu0-chalev0
!-
! Stefan-Boltzman constant
REAL(r_std),PARAMETER :: c_stefan = 5.6697E-8
! Specific heat of air
REAL(r_std),PARAMETER :: cp_air = 1004.675
! Constante molere
REAL(r_std),PARAMETER :: cte_molr = 287.05
! Kappa
REAL(r_std),PARAMETER :: kappa = cte_molr/cp_air
! in -- Kg/mole
REAL(r_std),PARAMETER :: msmlr_air = 28.964E-03
! in -- Kg/mole
REAL(r_std),PARAMETER :: msmlr_h2o = 18.02E-03
!
REAL(r_std),PARAMETER :: cp_h2o = &
& cp_air*(4._r_std*msmlr_air)/( 3.5_r_std*msmlr_h2o)
!
REAL(r_std),PARAMETER :: cte_molr_h2o = cte_molr/4._r_std
!
REAL(r_std),PARAMETER :: retv = msmlr_air/msmlr_h2o-1._r_std
!
REAL(r_std),PARAMETER :: rvtmp2 = cp_h2o/cp_air-1._r_std
!
REAL(r_std),PARAMETER :: cepdu2 = (0.1_r_std) **2
! Van Karmann Constante
REAL(r_std),PARAMETER :: ct_karman = 0.35_r_std
! g acceleration
REAL(r_std),PARAMETER :: cte_grav = 9.80665_r_std
! Constantes of the Louis scheme
REAL(r_std),PARAMETER :: cb = 5._r_std
REAL(r_std),PARAMETER :: cc = 5._r_std
REAL(r_std),PARAMETER :: cd = 5._r_std
! The minimum wind
REAL(r_std),PARAMETER :: min_wind = 0.1
! Transform pascal into hectopascal
REAL(r_std),PARAMETER :: pa_par_hpa = 100._r_std
! Time constant of the albedo decay of snow
REAL(r_std),PARAMETER :: tcst_snowa = 5._r_std
! Maximum period of snow aging
REAL(r_std),PARAMETER :: max_snow_age = 50._r_std
! Transformation time constant for snow (m)
REAL(r_std),PARAMETER :: snow_trans = 0.3_r_std
! bare soil roughness length (m)
REAL(r_std),PARAMETER :: z0_bare = 0.01
! ice roughness length (m)
REAL(r_std),PARAMETER :: z0_ice = 0.001
!-
! allow agricultural PFTs
LOGICAL,SAVE :: agriculture = .TRUE.
!!
!! The following tables of parameters for SECHIBA
!! are in the following order :
!!
!! 1 - Bare soil
!! 2 - tropical broad-leaved evergreen
!! 3 - tropical broad-leaved raingreen
!! 4 - temperate needleleaf evergreen
!! 5 - temperate broad-leaved evergreen
!! 6 - temperate broad-leaved summergreen
!! 7 - boreal needleleaf evergreen
!! 8 - boreal broad-leaved summergreen
!! 9 - boreal needleleaf summergreen
!! 10 - C3 grass
!! 11 - C4 grass
!! 12 - C3 agriculture
!! 13 - C4 agriculture
!!
! Value for veget_ori for tests in 0-dim simulations
REAL(r_std),DIMENSION(nvm),SAVE :: veget_ori_fixed_test_1 = &
& (/ 0.2, 0.0, 0.0, 0.0, 0.0, &
& 0.0, 0.0, 0.0, 0.0, 0.8, &
& 0.0, 0.0, 0.0 /)
! Value for frac_nobio for tests in 0-dim simulations
! laisser ca tant qu'il n'y a que de la glace (pas de lacs)
REAL(r_std),SAVE :: frac_nobio_fixed_test_1 = 0.0
! REAL(r_std), DIMENSION(nnobio),SAVE :: frac_nobio_fixed_test_1=(/0.0/)
!-
! laimax for maximum lai see also type of lai interpolation
REAL(r_std),DIMENSION(nvm),SAVE :: llaimax = &
! & (/ 0., 8., 8., 4., 4.5, 4.5, 4., 4.5, 4., 2., 2., 2., 2./)
!MG stage
& (/ 0., 8., 8., 4., 6., 6., 4., 6., 4., 5., 4., 6., 4.5/)
!
! laimin for minimum lai see also type of lai interpolation
REAL(r_std),DIMENSION(nvm),SAVE :: llaimin = &
! & (/ 0., 8., 0., 4., 4.5, 0., 4., 0., 0., 0., 0., 0., 0./)
!MG stage
& (/ 0., 8., 0., 4., 6., 0., 4., 0., 0., 1., 0., 0., 0./)
!
!MG stage
! tempmax for maximum lai see also type of lai interpolation
REAL(r_std),DIMENSION(nvm),SAVE :: ltempmax = &
& (/ 273.15, 300.15, 300.15, 288.15, 288.15, 288.15, 288.15, 288.15, 288.15, 288.15, 294.15, 288.15, 294.15/)
!
! tempmin for minimum lai see also type of lai interpolation
REAL(r_std),DIMENSION(nvm),SAVE :: ltempmin = &
& (/ 273.15, 296.15, 296.15, 278.15, 278.15, 278.15, 278.15, 278.15, 278.15, 280.15, 284.15, 280.15, 284.15/)
!!-
! prescribed height of vegetation.
! Value for height_presc : one for each vegetation type
REAL(r_std),DIMENSION(nvm),SAVE :: height_presc = &
! & (/ 0.,30.,30.,20.,20.,20.,15.,15.,15.,.5,.6,1.,1./)
!MG Tristan these
& (/ 0.,45.,30.,20.,20.,20.,15.,15.,15.,.5,.6,1.,1./)
!-
! Structural resistance.
! Value for rstruct_const : one for each vegetation type
REAL(r_std),DIMENSION(nvm),SAVE :: rstruct_const = &
! & (/ 0.0, 40.0, 40.0, 40.0, 40.0, 40.0, 40.0,&
! & 40.0, 40.0, 3.0, 5.0, 5.0, 8.0 /)
!MG Tristan these
& (/ 0.0, 100.0, 75.0, 50.0, 50.0, 50.0, 50.0,&
& 50.0, 50.0, 3.0, 5.0, 5.0, 10.0 /)
!-
! A vegetation dependent constant used in the calculation
! of the surface resistance.
! Value for kzero one for each vegetation type
REAL(r_std),DIMENSION(nvm),SAVE :: kzero = &
& (/0.0, 12.E-5, 12.E-5, 12.e-5, 12.e-5, 25.e-5, 12.e-5,&
& 25.e-5, 25.e-5, 30.e-5, 30.e-5, 30.e-5, 30.e-5 /)
!-
! Maximum field capacity for each of the vegetations (Temporary).
! Value of wmax_veg : max quantity of water :
! one for each vegetation type en Kg/M3
REAL(r_std),DIMENSION(nvm),SAVE :: wmax_veg = &
& (/ 150., 150., 150., 150., 150., 150., 150.,&
& 150., 150., 150., 150., 150., 150. /)
!-
! Root profile description for the different vegetation types.
! These are the factor in the exponential which gets
! the root density as a function of depth
REAL(r_std),DIMENSION(nvm), SAVE :: humcste = &
& (/5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 4., 4., 4./)
!MG Tristan these
! & (/5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 2.5, 2., 2./)
!-
! Type of behaviour of the LAI evolution algorithm
! for each vegetation type.
! Value of type_of_lai, one for each vegetation type : mean or interp
CHARACTER(len=5),DIMENSION(nvm),SAVE :: type_of_lai = &
& (/ 'mean ', 'mean ', 'inter', 'mean ', 'mean ', &
& 'inter', 'mean ', 'inter', 'inter', 'inter', &
& 'inter', 'inter', 'inter' /)
!-
! Is the vegetation type a tree ?
LOGICAL, DIMENSION(nvm),SAVE :: is_tree = &
& (/ .FALSE., .TRUE., .TRUE., .TRUE., .TRUE., &
& .TRUE., .TRUE., .TRUE., .TRUE., .FALSE., &
& .FALSE., .FALSE., .FALSE. /)
!-
! Initial snow albedo value for each vegetation type
! as it will be used in condveg_snow
! Values are from the Thesis of S. Chalita (1992)
! REAL(r_std),DIMENSION(nvm),SAVE :: snowa_ini = &
! & (/ 0.55, 0., 0., 0.14, 0.15, &
! & 0.15, 0.14, 0.15, 0.14, 0.18, &
! & 0.18, 0.18, 0.18 /)
! Nathalie - Decembre 2006 - on limite les albedos de sol nu en presence de neige, ainsi que ceux de la vegetation
! les valeurs choisies sont proches de celles que nous avions prises dans LMD5.3 avec Delphine Texier
REAL(r_std),DIMENSION(nvm),SAVE :: snowa_ini = &
& (/ 0.35, 0., 0., 0.14, 0.14, &
& 0.14, 0.14, 0.14, 0.14, 0.18, &
& 0.18, 0.18, 0.18 /)
!-
! Decay rate of snow albedo value for each vegetation type
! as it will be used in condveg_snow
! Values are from the Thesis of S. Chalita (1992)
! REAL(r_std),DIMENSION(nvm),SAVE :: snowa_dec = &
! & (/ 0.30, 0., 0., 0.06, 0.14, &
! & 0.14, 0.06, 0.25, 0.06, 0.63, &
! & 0.63, 0.63, 0.63 /)
! Nathalie - Decembre 2006 - on limite les albedos de sol nu en presence de neige, ainsi que ceux de la vegetation
! les valeurs choisies sont proches de celles que nous avions prises dans LMD5.3 avec Delphine Texier
!-
REAL(r_std),DIMENSION(nvm),SAVE :: snowa_dec = &
& (/ 0.45, 0., 0., 0.06, 0.06, &
& 0.11, 0.06, 0.11, 0.11, 0.52, &
& 0.52, 0.52, 0.52 /)
!-
! leaf albedo of vegetation type, VIS+NIR
REAL(r_std),DIMENSION(nvm*2),SAVE :: alb_leaf = &
& (/ .00, .04, .06, .06, .06, &
& .06, .06, .06, .06, .10, &
& .10, .10, .10, &
& .00, .20, .22, .22, .22, &
& .22, .22, .22, .22, .30, &
& .30, .30, .30 /)
!-
! Table which contains the correlation between the soil types
! and vegetation type. Two modes exist :
! 1) pref_soil_veg = 0 then we have an equidistribution
! of vegetation on soil types
! 2) Else for each pft the prefered soil type is given :
! 1=sand, 2=loan, 3=clay
! The variable is initialized in slowproc.
INTEGER(i_std),DIMENSION(nvm),SAVE :: pref_soil_veg
!-
! albedo of dead leaves, VIS+NIR
REAL(r_std),DIMENSION(2),SAVE :: alb_deadleaf = (/ .12, .35/)
! albedo of ice, VIS+NIR
REAL(r_std),DIMENSION(2),SAVE :: alb_ice = (/ .60, .20/)
!-
! Is veget_ori array stored in restart file
LOGICAL,PARAMETER :: ldveget_ori_on_restart = .TRUE.
!-
! Set to .TRUE. if you want q_cdrag coming from GCM
LOGICAL,PARAMETER :: ldq_cdrag_from_gcm = .FALSE.
!-
! Constant in the computation of surface resistance
REAL(r_std),PARAMETER :: rayt_cste = 125.
!-
! Size of local array to keep saturated humidity
! at each temperature level
INTEGER(i_std),PARAMETER :: max_temp=370
! Minimum temperature for saturated humidity
INTEGER(i_std),PARAMETER :: min_temp=10
! Local array to keep saturated humidity at each temperature level
REAL(r_std),DIMENSION(max_temp),SAVE :: qsfrict
!-
!===
CONTAINS
!===
SUBROUTINE qsatcalc (kjpindex,temp_in,pres_in,qsat_out)
!---------------------------------------------------------------------
! input value
! Domain size
INTEGER(i_std),INTENT(in) :: kjpindex
! Temperature in degre Kelvin
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: temp_in
! Pressure
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: pres_in
! output value
! Result
REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: qsat_out
!-
! local variables
INTEGER(i_std), DIMENSION(kjpindex) :: jt
INTEGER(i_std) :: ji
REAL(r_std),DIMENSION(kjpindex) :: zz_a, zz_b, zz_f
INTEGER(i_std) :: nbad
INTEGER(i_std),DIMENSION(1) :: lo
!---------------------------------------------------------------------
IF (l_qsat_first) THEN
CALL qsfrict_init
l_qsat_first = .FALSE.
ENDIF
!-
! 1. computes qsat interpolation into two successive temperature
!-
jt = INT(temp_in(:))
!-
nbad = COUNT(jt(:) >= max_temp-1)
IF (nbad > 0) THEN
WRITE(numout,*) ' qsatcalc: temperature too high at ', &
& nbad, ' points.'
IF (.NOT.diag_qsat) THEN
CALL ipslerr(2,'qsatcalc','diffuco', '', &
& 'temperature incorect.')
ELSE
lo = MAXLOC(temp_in(:))
WRITE(numout,*) &
& 'Maximum temperature ( ',MAXVAL(temp_in),') found at ',lo(1)
WHERE (jt(:) >= max_temp-1) jt(:) = max_temp-1
ENDIF
ENDIF
!-
nbad = COUNT(jt(:) <= min_temp)
IF (nbad > 0) THEN
WRITE(numout,*) ' qsatcalc: temperature too low at ', &
& nbad, ' points.'
IF (.NOT.diag_qsat) THEN
CALL ipslerr(2,'qsatcalc','diffuco', '', &
& 'temperature incorect.')
ELSE
lo = MINLOC(temp_in(:))
WRITE(numout,*) &
& 'Minimum temperature ( ',MINVAL(temp_in),') found at ',lo(1)
WHERE (jt(:) <= min_temp) jt(:) = min_temp
ENDIF
ENDIF
!-
DO ji = 1, kjpindex
zz_f(ji) = temp_in(ji)-FLOAT(jt(ji))
zz_a(ji) = qsfrict(jt(ji))
zz_b(ji) = qsfrict(jt(ji)+1)
ENDDO
!-
! 2. interpolates between this two values
!-
DO ji = 1, kjpindex
qsat_out(ji) = ((zz_b(ji)-zz_a(ji))*zz_f(ji)+zz_a(ji))/pres_in(ji)
ENDDO
!----------------------
END SUBROUTINE qsatcalc
!===
FUNCTION qsat (temp_in,pres_in) RESULT (qsat_result)
!!--------------------------------------------------------------------
!! FUNCTION qsat (temp_in, pres_in) RESULT (qsat_result)
!!--------------------------------------------------------------------
REAL(r_std),INTENT(in) :: temp_in ! Temperature in degre Kelvin
REAL(r_std),INTENT(in) :: pres_in ! Pressure
REAL(r_std) :: qsat_result
!-
INTEGER(i_std) :: jt
REAL(r_std) :: zz_a,zz_b,zz_f
!---------------------------------------------------------------------
IF (l_qsat_first) THEN
CALL qsfrict_init
l_qsat_first = .FALSE.
ENDIF
!-
! 1. computes qsat interpolation into two successive temperature
!-
jt = INT(temp_in)
!-
IF (jt >= max_temp-1) THEN
WRITE(numout,*) &
& ' We stop. temperature too BIG : ',temp_in, &
& ' approximation for : ',jt
IF (.NOT.diag_qsat) THEN
CALL ipslerr(2,'qsat','', '',&
& 'temperature incorect.')
ELSE
qsat_result = 999999.
RETURN
ENDIF
ENDIF
!-
IF (jt <= min_temp ) THEN
WRITE(numout,*) &
& ' We stop. temperature too SMALL : ',temp_in, &
& ' approximation for : ',jt
IF (.NOT.diag_qsat) THEN
CALL ipslerr(2,'qsat','', '',&
& 'temperature incorect.')
ELSE
qsat_result = -999999.
RETURN
ENDIF
ENDIF
!-
zz_f = temp_in-FLOAT(jt)
zz_a = qsfrict(jt)
zz_b = qsfrict(jt+1)
!-
! 2. interpolates between this two values
!-
qsat_result = ((zz_b-zz_a)*zz_f+zz_a)/pres_in
!----------------
END FUNCTION qsat
!===
SUBROUTINE dev_qsatcalc (kjpindex,temp_in,pres_in,dev_qsat_out)
!---------------------------------------------------------------------
! Domain size
INTEGER(i_std),INTENT(in) :: kjpindex
! Temperature in degre Kelvin
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: temp_in
! Pressure
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: pres_in
! Result
REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: dev_qsat_out
!-
INTEGER(i_std),DIMENSION(kjpindex) :: jt
INTEGER(i_std) :: ji
REAL(r_std),DIMENSION(kjpindex) :: zz_a, zz_b, zz_c, zz_f
INTEGER(i_std) :: nbad
!---------------------------------------------------------------------
IF (l_qsat_first) THEN
CALL qsfrict_init
l_qsat_first = .FALSE.
ENDIF
!-
! 1. computes qsat interpolation into two successive temperature
!-
jt = INT(temp_in(:)+undemi)
!-
nbad = COUNT( jt(:) >= max_temp-1 )
IF (nbad > 0) THEN
WRITE(numout,*) &
& ' dev_qsatcalc: temperature too high at ',nbad,' points.'
IF (.NOT.diag_qsat) THEN
CALL ipslerr(3,'dev_qsatcalc','', '', &
& 'temperature incorect.')
ELSE
WHERE (jt(:) >= max_temp-1) jt(:) = max_temp-1
ENDIF
ENDIF
!-
nbad = COUNT( jt(:) <= min_temp )
IF (nbad > 0) THEN
WRITE(numout,*) &
& ' dev_qsatcalc: temperature too low at ',nbad,' points.'
IF (.NOT.diag_qsat) THEN
CALL ipslerr(3,'dev_qsatcalc', '', '',&
& 'temperature incorect.')
ELSE
WHERE (jt(:) <= min_temp) jt(:) = min_temp
ENDIF
ENDIF
!-
DO ji=1,kjpindex
zz_f(ji) = temp_in(ji)+undemi-FLOAT(jt(ji))
zz_a(ji) = qsfrict(jt(ji)-1)
zz_b(ji) = qsfrict(jt(ji))
zz_c(ji) = qsfrict(jt(ji)+1)
ENDDO
!-
! 2. interpolates between this two values
!-
DO ji = 1, kjpindex
dev_qsat_out(ji) = &
& ((zz_c(ji)-deux*zz_b(ji)+zz_a(ji))*(zz_f(ji)-un) + &
& zz_c(ji)-zz_b(ji))/pres_in(ji)
ENDDO
!--------------------------
END SUBROUTINE dev_qsatcalc
!===
FUNCTION dev_qsat (temp_in,pres_in) RESULT (dev_qsat_result)
!!--------------------------------------------------------------------
!! FUNCTION dev_qsat (temp_in, pres_in) RESULT (dev_qsat_result)
!! computes deviation of qsat
!!--------------------------------------------------------------------
REAL(r_std),INTENT(in) :: pres_in ! Pressure
REAL(r_std),INTENT(in) :: temp_in ! Temperture in degre Kelvin
REAL(r_std) :: dev_qsat_result
!-
INTEGER(i_std) :: jt
REAL(r_std) :: zz_a, zz_b, zz_c, zz_f
!---------------------------------------------------------------------
IF (l_qsat_first) THEN
CALL qsfrict_init
l_qsat_first = .FALSE.
ENDIF
!-
! 1. computes qsat deviation interpolation
! into two successive temperature
!-
jt = INT(temp_in+undemi)
!-
IF (jt >= max_temp-1) THEN
WRITE(numout,*) &
& ' We stop. temperature too HIGH : ',temp_in, &
& ' approximation for : ',jt
IF (.NOT.diag_qsat) THEN
CALL ipslerr(3,'dev_qsat','', '',&
& 'temperature incorect.')
ELSE
dev_qsat_result = 999999.
RETURN
ENDIF
ENDIF
!-
IF (jt <= min_temp ) THEN
WRITE(numout,*) &
& ' We stop. temperature too LOW : ',temp_in, &
& ' approximation for : ',jt
IF (.NOT.diag_qsat) THEN
CALL ipslerr(3,'dev_qsat','', '',&
& 'temperature incorect.')
ELSE
dev_qsat_result = -999999.
RETURN
ENDIF
ENDIF
!-
zz_f = temp_in+undemi-FLOAT(jt)
zz_a = qsfrict(jt-1)
zz_b = qsfrict(jt)
zz_c = qsfrict(jt+1)
!-
! 2. interpolates
!-
dev_qsat_result=((zz_c-deux*zz_b+zz_a)*(zz_f-un)+zz_c-zz_b)/pres_in
!--------------------
END FUNCTION dev_qsat
!===
SUBROUTINE qsfrict_init
!!--------------------------------------------------------------------
!! The qsfrict_init routine initialises qsfrict array
!! to store precalculated value for qsat
!!--------------------------------------------------------------------
INTEGER(i_std) :: ji
REAL(r_std) :: zrapp,zcorr,ztemperature,zqsat
!---------------------------------------------------------------------
! initialisation
zrapp = msmlr_h2o/msmlr_air
zcorr = 0.00320991_r_std
! computes saturated humidity one time and store in qsfrict local array
DO ji=100,max_temp
ztemperature = FLOAT(ji)
IF (ztemperature < 273._r_std) THEN
zqsat = zrapp*10.0_r_std**(2.07023_r_std-zcorr*ztemperature &
& -2484.896/ztemperature+3.56654*LOG10(ztemperature))
ELSE
zqsat = zrapp*10.0**(23.8319-2948.964/ztemperature &
& -5.028*LOG10(ztemperature) &
& -29810.16*EXP(-0.0699382*ztemperature) &
& +25.21935*EXP(-2999.924/ztemperature))
ENDIF
qsfrict (ji) = zqsat
ENDDO
!-
qsfrict(1:100) = zero
!-
IF (long_print) WRITE (numout,*) ' qsfrict_init done'
!--------------------------
END SUBROUTINE qsfrict_init
!===
FUNCTION tempfunc (temp_in) RESULT (tempfunc_result)
!!--------------------------------------------------------------------
!! FUNCTION tempfunc (temp_in) RESULT (tempfunc_result)
!! this function interpolates value between ztempmin and ztempmax
!! used for lai detection
!!--------------------------------------------------------------------
REAL(r_std),INTENT(in) :: temp_in !! Temperature in degre Kelvin
REAL(r_std) :: tempfunc_result
!-
REAL(r_std),PARAMETER :: ztempmin=273._r_std !! Temperature for laimin
REAL(r_std),PARAMETER :: ztempmax=293._r_std !! Temperature for laimax
REAL(r_std) :: zfacteur !! Interpolation factor
!---------------------------------------------------------------------
zfacteur = un/(ztempmax-ztempmin)**2
IF (temp_in > ztempmax) THEN
tempfunc_result = un
ELSEIF (temp_in < ztempmin) THEN
tempfunc_result = zero
ELSE
tempfunc_result = un-zfacteur*(ztempmax-temp_in)**2
ENDIF
!--------------------
END FUNCTION tempfunc
!===
SUBROUTINE get_vegcorr (nolson,vegcorr,nobiocorr)
!---------------------------------------------------------------------
INTEGER(i_std),INTENT(in) :: nolson
REAL(r_std),DIMENSION(nolson,nvm),INTENT(out) :: vegcorr(nolson,nvm)
REAL(r_std),DIMENSION(nolson,nnobio),INTENT(out) :: nobiocorr
!-
INTEGER(i_std) :: ib
INTEGER(i_std),PARAMETER :: nolson94 = 94
INTEGER(i_std),PARAMETER :: nvm13 = 13
!---------------------------------------------------------------------
IF (nolson /= nolson94) THEN
WRITE(numout,*) nolson,nolson94
CALL ipslerr(3,'get_vegcorr', '', '',&
& 'wrong number of OLSON vegetation types.')
ENDIF
IF (nvm /= nvm13) THEN
WRITE(numout,*) nvm,nvm13
CALL ipslerr(3,'get_vegcorr', '', '',&
& 'wrong number of SECHIBA vegetation types.')
ENDIF
!-
! 1 set the indices of non-biospheric surface types to 0.
!-
nobiocorr(:,:) = 0.
!-
! 2 Here we construct the correspondance table
! between Olson and the following SECHIBA Classes.
! vegcorr(i,:)+nobiocorr(i,:) = 1. for all i.
!-
! The modified OLSON types found in file carteveg5km.nc
! created by Nicolas Viovy :
! 1 Urban
vegcorr( 1,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 2 Cool low sparse grassland
vegcorr( 2,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 3 Cold conifer forest
vegcorr( 3,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 4 Cold deciduous conifer forest
vegcorr( 4,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0/)
! 5 Cool Deciduous broadleaf forest
vegcorr( 5,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 6 Cool evergreen broadleaf forests
vegcorr( 6,:) = &
& (/0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 7 Cool tall grasses and shrubs
vegcorr( 7,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 8 Warm C3 tall grasses and shrubs
vegcorr( 8,:) = &
& (/0.1, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 9 Warm C4 tall grases and shrubs
vegcorr( 9,:) = &
& (/0.1, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0/)
! 10 Bare desert
vegcorr(10,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 11 Cold upland tundra
vegcorr(11,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 12 Cool irrigated grassland
vegcorr(12,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.0/)
! 13 Semi desert
vegcorr(13,:) = &
& (/0.7, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 14 Glacier ice
vegcorr(14,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
nobiocorr(14,iice) = 1.
! 15 Warm wooded wet swamp
vegcorr(15,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0/)
! 16 Inland water
vegcorr(16,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 17 sea water
vegcorr(17,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 18 cool shrub evergreen
vegcorr(18,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 19 cold shrub deciduous
vegcorr(19,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 20 Cold evergreen forest and fields
vegcorr(20,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0/)
! 21 cool rain forest
vegcorr(21,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 22 cold conifer boreal forest
vegcorr(22,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 23 cool conifer forest
vegcorr(23,:) = &
& (/0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 24 warm mixed forest
vegcorr(24,:) = &
& (/0.0, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0/)
! 25 cool mixed forest
vegcorr(25,:) = &
& (/0.0, 0.0, 0.0, 0.4, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 26 cool broadleaf forest
vegcorr(26,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0/)
! 27 cool deciduous broadleaf forest
vegcorr(27,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.3, 0.5, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 28 warm montane tropical forest
vegcorr(28,:) = &
& (/0.0, 0.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0/)
! 29 warm seasonal tropical forest
vegcorr(29,:) = &
& (/0.0, 0.5, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0/)
! 30 cool crops and towns
vegcorr(30,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0/)
! 31 warm crops and towns
vegcorr(31,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8/)
! 32 cool crops and towns
vegcorr(32,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0/)
! 33 warm dry tropical woods
vegcorr(33,:) = &
& (/0.2, 0.0, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 34 warm tropical rain forest
vegcorr(34,:) = &
& (/0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 35 warm tropical degraded forest
vegcorr(35,:) = &
& (/0.1, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0/)
! 36 warm corn and beans cropland
vegcorr(36,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0/)
! 37 cool corn and bean cropland
vegcorr(37,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
! 38 warm rice paddy and field
vegcorr(38,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0/)
! 39 hot irrigated cropland
vegcorr(39,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0/)
! 40 cool irrigated cropland
vegcorr(40,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
! 41 cold irrigated cropland
vegcorr(41,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
! 42 cool grasses and shrubs
vegcorr(42,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 43 hot and mild grasses and shrubs
vegcorr(43,:) = &
& (/0.2, 0.0, 0.1, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0/)
! 44 cold grassland
vegcorr(44,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.0/)
! 45 Savanna (woods) C3
vegcorr(45,:) = &
& (/0.1, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 46 Savanna woods C4
vegcorr(46,:) = &
& (/0.1, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0/)
! 47 Mire, bog, fen
vegcorr(47,:) = &
& (/0.1, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 48 Warm marsh wetland
vegcorr(48,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 49 cold marsh wetland
vegcorr(49,:) = &
& (/0.0, 0.0, 0.0, 0.1, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 50 mediteraean scrub
vegcorr(50,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 51 Cool dry woody scrub
vegcorr(51,:) = &
& (/0.3, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 52 Warm dry evergreen woods
vegcorr(52,:) = &
& (/0.1, 0.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 53 Volcanic rocks
vegcorr(53,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 54 send desert
vegcorr(54,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 55 warm semi desert shrubs
vegcorr(55,:) = &
& (/0.7, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 56 cool semi desert shrubs
vegcorr(56,:) = &
& (/0.6, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0/)
! 57 semi desert sage
vegcorr(57,:) = &
& (/0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 58 Barren tundra
vegcorr(58,:) = &
& (/0.6, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0/)
! 59 cool southern hemisphere mixed forest
vegcorr(59,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 60 cool fields and woods
vegcorr(60,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 61 warm forest and filed
vegcorr(61,:) = &
& (/0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6/)
! 62 cool forest and field
vegcorr(62,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 63 warm C3 fields and woody savanna
vegcorr(63,:) = &
& (/0.1, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 64 warm C4 fields and woody savanna
vegcorr(64,:) = &
& (/0.1, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6/)
! 65 cool fields and woody savanna
vegcorr(65,:) = &
& (/0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 66 warm succulent and thorn scrub
vegcorr(66,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 67 cold small leaf mixed woods
vegcorr(67,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.3, 0.0, 0.5, 0.0, 0.0, 0.0/)
! 68 cold deciduous and mixed boreal fores
vegcorr(68,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 69 cold narrow conifers
vegcorr(69,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0/)
! 70 cold wooded tundra
vegcorr(70,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 71 cold heath scrub
vegcorr(71,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 72 Polar and alpine desert
vegcorr(72,:) = &
& (/0.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0/)
! 73 warm Mangrove
vegcorr(73,:) = &
& (/0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 74 cool crop and water mixtures
vegcorr(74,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 75 cool southern hemisphere mixed forest
vegcorr(75,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 76 cool moist eucalyptus
vegcorr(76,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 77 warm rain green tropical forest
vegcorr(77,:) = &
& (/0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 78 warm C3 woody savanna
vegcorr(78,:) = &
& (/0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 79 warm C4 woody savanna
vegcorr(79,:) = &
& (/0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 80 cool woody savanna
vegcorr(80,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 81 cold woody savanna
vegcorr(81,:) = &
& (/0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 82 warm broadleaf crops
vegcorr(82,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0/)
! 83 warm C3 grass crops
vegcorr(83,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0/)
! 84 warm C4 grass crops
vegcorr(84,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9/)
! 85 cool grass crops
vegcorr(85,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
! 86 warm C3 crops grass,shrubs
vegcorr(86,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0/)
! 87 cool crops,grass,shrubs
vegcorr(87,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.5, 0.0, 0.5, 0.0/)
! 88 warm evergreen tree crop
vegcorr(88,:) = &
& (/0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2/)
! 89 cool evergreen tree crop
vegcorr(89,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0/)
! 90 cold evergreen tree crop
vegcorr(90,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0/)
! 91 warm deciduous tree crop
vegcorr(91,:) = &
& (/0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2/)
! 92 cool deciduous tree crop
vegcorr(92,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0/)
! 93 cold deciduous tree crop
vegcorr(93,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.2, 0.0/)
! 94 wet sclerophylic forest
vegcorr(94,:) = &
& (/0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
!-
! 3 Check the mapping for the Olson types which are going into the
! the veget and nobio array.
!-
DO ib=1,nolson
IF ( ABS(SUM(vegcorr(ib,:))+SUM(nobiocorr(ib,:))-1.0) &
& > EPSILON(1.0)) THEN
WRITE(numout,*) 'Wrong correspondance for Olson type :', ib
CALL ipslerr(3,'get_vegcorr', '', '',&
& 'Wrong correspondance for Olson type.')
ENDIF
ENDDO
!-------------------------
END SUBROUTINE get_vegcorr
!===
SUBROUTINE get_soilcorr (nclass, textfrac_table)
!! The "get_soilcorr" routine defines the table of correspondence
!! between the Zobler types and the three texture
!! types known by SECHIBA & STOMATE : silt, sand and clay - Verifier aupres de patricia tdo
INTEGER(i_std), INTENT(in) :: nclass
REAL(r_std), DIMENSION(nclass,nscm_fao), INTENT(out) :: textfrac_table(nclass,ntext)
INTEGER(i_std), PARAMETER :: nzobler = 7
INTEGER(i_std) :: ib
!
!
SELECTCASE(nclass)
!
! Textural fraction for : silt sand clay
!
CASE(nzobler)
textfrac_table(1,:) = (/ 0.12, 0.82, 0.06 /)
textfrac_table(2,:) = (/ 0.32, 0.58, 0.10 /)
textfrac_table(3,:) = (/ 0.39, 0.43, 0.18 /)
textfrac_table(4,:) = (/ 0.15, 0.58, 0.27 /)
textfrac_table(5,:) = (/ 0.34, 0.32, 0.34 /)
textfrac_table(6,:) = (/ 0.00, 1.00, 0.00 /)
textfrac_table(7,:) = (/ 0.39, 0.43, 0.18 /)
CASE(nscm_fao)
textfrac_table(1,:) = (/ 0.26, 0.63, 0.11 /)
textfrac_table(2,:) = (/ 0.40, 0.40, 0.20 /)
textfrac_table(3,:) = (/ 0.37, 0.30, 0.33 /)
CASE(nscm_fao*2-1)
textfrac_table(1,:) = (/ 0.26, 0.63, 0.11 /)
textfrac_table(2,:) = (/ 0.26, 0.63, 0.11 /)
textfrac_table(3,:) = (/ 0.40, 0.40, 0.20 /)
textfrac_table(4,:) = (/ 0.40, 0.40, 0.20 /)
textfrac_table(5,:) = (/ 0.37, 0.30, 0.33 /)
CASE(nscm_usda)
textfrac_table(1,:) = (/ 0.04, 0.93, 0.03 /)
textfrac_table(2,:) = (/ 0.13, 0.81, 0.06 /)
textfrac_table(3,:) = (/ 0.26, 0.63, 0.11 /)
textfrac_table(4,:) = (/ 0.64, 0.17, 0.19 /)
textfrac_table(5,:) = (/ 0.84, 0.06, 0.10 /)
textfrac_table(6,:) = (/ 0.40, 0.40, 0.20 /)
textfrac_table(7,:) = (/ 0.19, 0.54, 0.27 /)
textfrac_table(8,:) = (/ 0.59, 0.08, 0.33 /)
textfrac_table(9,:) = (/ 0.37, 0.30, 0.33 /)
textfrac_table(10,:) = (/ 0.11, 0.48, 0.41 /)
textfrac_table(11,:) = (/ 0.48, 0.06, 0.46 /)
textfrac_table(12,:) = (/ 0.30, 0.15, 0.55 /)
CASE DEFAULT
WRITE(*,*) 'We do not have the correct number of classes in the code for the file'
STOP 'GET_soilcorr'
ENDSELECT
!
DO ib=1,nclass
IF ( ABS(SUM(textfrac_table(ib,:))-1.0) .GT. EPSILON(1.0) ) THEN
WRITE(*,*) 'Error in the correspondence table, sum is not equal to 1 in', ib
WRITE(*,*) textfrac_table(ib,:)
STOP 'GET_soilcorr'
ENDIF
ENDDO
!--------------------------
END SUBROUTINE GET_soilcorr
!===
!------------------------
END MODULE constantes_veg
ORCHIDEE/src_parameters/constantes_veg.f90 0000754 0103600 0005670 00000106756 11202265560 020314 0 ustar acamlmd lmdjus !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parameters/constantes_veg.f90,v 1.29 2007/06/12 19:18:21 ssipsl Exp $
!IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!-
MODULE constantes_veg
!!--------------------------------------------------------------------
!! "constantes_soil" module contains public physical constantes
!! and public tools functions like qsat, dev_qsat
!!--------------------------------------------------------------------
USE IOIPSL
USE constantes_soil
!-
IMPLICIT NONE
!-
LOGICAL,SAVE :: l_qsat_first=.TRUE.
!-
! Flags that (de)activate parts of the model
TYPE(control_type),SAVE :: control
!-
! Number of vegetation types
INTEGER(i_std),PARAMETER :: nvm=13
! Number of other surface types: land ice (lakes,cities, ...)
INTEGER(i_std),PARAMETER :: nnobio=1
!-
! Index for land ice (see nnobio)
INTEGER(i_std),PARAMETER :: iice = 1
! The maximum mass (kg/m^2) of a glacier.
REAL(r_std),PARAMETER :: maxmass_glacier = 3000.
!-
! Minimal fraction of mesh a vegetation type can occupy
REAL(r_std),PARAMETER :: min_vegfrac=0.001
!-
! Constant in the computation of surface resistance
REAL(r_std),PARAMETER :: defc_plus=23.E-3
! Constant in the computation of surface resistance
REAL(r_std),PARAMETER :: defc_mult=1.5
!-
! Limit of air temperature for snow
REAL(r_std),PARAMETER :: tsnow=273.
!-
! Sets the amount above which only sublimation occures [Kg/m^2]
REAL(r_std),PARAMETER :: snowcri=1.5
! Critical value for computation of snow albedo [Kg/m^2]
REAL(r_std),PARAMETER :: snowcri_alb=10.
! Lower limit of snow amount
REAL(r_std),PARAMETER :: sneige=snowcri/1000._r_std
! Latent heat of sublimation
REAL(r_std),PARAMETER :: chalsu0 = 2.8345E06
! Latent heat of evaporation
REAL(r_std),PARAMETER :: chalev0 = 2.5008E06
! Latent heat of evaporation 2 (?)
REAL(r_std),PARAMETER :: chalev1 = 2.5008E06
! Latent heat of fusion
REAL(r_std),PARAMETER :: chalfu0 = chalsu0-chalev0
!-
! Stefan-Boltzman constant
REAL(r_std),PARAMETER :: c_stefan = 5.6697E-8
! Specific heat of air
REAL(r_std),PARAMETER :: cp_air = 1004.675
! Constante molere
REAL(r_std),PARAMETER :: cte_molr = 287.05
! Kappa
REAL(r_std),PARAMETER :: kappa = cte_molr/cp_air
! in -- Kg/mole
REAL(r_std),PARAMETER :: msmlr_air = 28.964E-03
! in -- Kg/mole
REAL(r_std),PARAMETER :: msmlr_h2o = 18.02E-03
!
REAL(r_std),PARAMETER :: cp_h2o = &
& cp_air*(4._r_std*msmlr_air)/( 3.5_r_std*msmlr_h2o)
!
REAL(r_std),PARAMETER :: cte_molr_h2o = cte_molr/4._r_std
!
REAL(r_std),PARAMETER :: retv = msmlr_air/msmlr_h2o-1._r_std
!
REAL(r_std),PARAMETER :: rvtmp2 = cp_h2o/cp_air-1._r_std
!
REAL(r_std),PARAMETER :: cepdu2 = (0.1_r_std) **2
! Van Karmann Constante
REAL(r_std),PARAMETER :: ct_karman = 0.35_r_std
! g acceleration
REAL(r_std),PARAMETER :: cte_grav = 9.80665_r_std
! Constantes of the Louis scheme
REAL(r_std),PARAMETER :: cb = 5._r_std
REAL(r_std),PARAMETER :: cc = 5._r_std
REAL(r_std),PARAMETER :: cd = 5._r_std
! The minimum wind
REAL(r_std),PARAMETER :: min_wind = 0.1
! Transform pascal into hectopascal
REAL(r_std),PARAMETER :: pa_par_hpa = 100._r_std
! Time constant of the albedo decay of snow
REAL(r_std),PARAMETER :: tcst_snowa = 5._r_std
! Maximum period of snow aging
REAL(r_std),PARAMETER :: max_snow_age = 50._r_std
! Transformation time constant for snow (m)
REAL(r_std),PARAMETER :: snow_trans = 0.3_r_std
! bare soil roughness length (m)
REAL(r_std),PARAMETER :: z0_bare = 0.01
! ice roughness length (m)
REAL(r_std),PARAMETER :: z0_ice = 0.001
!-
! allow agricultural PFTs
LOGICAL,SAVE :: agriculture = .TRUE.
!!
!! The following tables of parameters for SECHIBA
!! are in the following order :
!!
!! 1 - Bare soil
!! 2 - tropical broad-leaved evergreen
!! 3 - tropical broad-leaved raingreen
!! 4 - temperate needleleaf evergreen
!! 5 - temperate broad-leaved evergreen
!! 6 - temperate broad-leaved summergreen
!! 7 - boreal needleleaf evergreen
!! 8 - boreal broad-leaved summergreen
!! 9 - boreal needleleaf summergreen
!! 10 - C3 grass
!! 11 - C4 grass
!! 12 - C3 agriculture
!! 13 - C4 agriculture
!!
! Value for veget_ori for tests in 0-dim simulations
REAL(r_std),DIMENSION(nvm),SAVE :: veget_ori_fixed_test_1 = &
& (/ 0.2, 0.0, 0.0, 0.0, 0.0, &
& 0.0, 0.0, 0.0, 0.0, 0.8, &
& 0.0, 0.0, 0.0 /)
! Value for frac_nobio for tests in 0-dim simulations
! laisser ca tant qu'il n'y a que de la glace (pas de lacs)
REAL(r_std),SAVE :: frac_nobio_fixed_test_1 = 0.0
! REAL(r_std), DIMENSION(nnobio),SAVE :: frac_nobio_fixed_test_1=(/0.0/)
!-
! laimax for maximum lai see also type of lai interpolation
REAL(r_std),DIMENSION(nvm),SAVE :: llaimax = &
! & (/ 0., 8., 8., 4., 4.5, 4.5, 4., 4.5, 4., 2., 2., 2., 2./)
!MG stage
& (/ 0., 8., 8., 4., 6., 6., 4., 6., 4., 5., 4., 6., 4.5/)
!
! laimin for minimum lai see also type of lai interpolation
REAL(r_std),DIMENSION(nvm),SAVE :: llaimin = &
! & (/ 0., 8., 0., 4., 4.5, 0., 4., 0., 0., 0., 0., 0., 0./)
!MG stage
& (/ 0., 8., 0., 4., 6., 0., 4., 0., 0., 1., 0., 0., 0./)
!
!MG stage
! tempmax for maximum lai see also type of lai interpolation
REAL(r_std),DIMENSION(nvm),SAVE :: ltempmax = &
& (/ 273.15, 300.15, 300.15, 288.15, 288.15, 288.15, 288.15, 288.15, 288.15, 288.15, 294.15, 288.15, 294.15/)
!
! tempmin for minimum lai see also type of lai interpolation
REAL(r_std),DIMENSION(nvm),SAVE :: ltempmin = &
& (/ 273.15, 296.15, 296.15, 278.15, 278.15, 278.15, 278.15, 278.15, 278.15, 280.15, 284.15, 280.15, 284.15/)
!!-
! prescribed height of vegetation.
! Value for height_presc : one for each vegetation type
REAL(r_std),DIMENSION(nvm),SAVE :: height_presc = &
! & (/ 0.,30.,30.,20.,20.,20.,15.,15.,15.,.5,.6,1.,1./)
!MG Tristan these
& (/ 0.,45.,30.,20.,20.,20.,15.,15.,15.,.5,.6,1.,1./)
!-
! Structural resistance.
! Value for rstruct_const : one for each vegetation type
REAL(r_std),DIMENSION(nvm),SAVE :: rstruct_const = &
! & (/ 0.0, 40.0, 40.0, 40.0, 40.0, 40.0, 40.0,&
! & 40.0, 40.0, 3.0, 5.0, 5.0, 8.0 /)
!MG Tristan these
& (/ 0.0, 100.0, 75.0, 50.0, 50.0, 50.0, 50.0,&
& 50.0, 50.0, 3.0, 5.0, 5.0, 10.0 /)
!-
! A vegetation dependent constant used in the calculation
! of the surface resistance.
! Value for kzero one for each vegetation type
REAL(r_std),DIMENSION(nvm),SAVE :: kzero = &
& (/0.0, 12.E-5, 12.E-5, 12.e-5, 12.e-5, 25.e-5, 12.e-5,&
& 25.e-5, 25.e-5, 30.e-5, 30.e-5, 30.e-5, 30.e-5 /)
!-
! Maximum field capacity for each of the vegetations (Temporary).
! Value of wmax_veg : max quantity of water :
! one for each vegetation type en Kg/M3
REAL(r_std),DIMENSION(nvm),SAVE :: wmax_veg = &
& (/ 150., 150., 150., 150., 150., 150., 150.,&
& 150., 150., 150., 150., 150., 150. /)
!-
! Root profile description for the different vegetation types.
! These are the factor in the exponential which gets
! the root density as a function of depth
REAL(r_std),DIMENSION(nvm), SAVE :: humcste = &
& (/5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 4., 4., 4./)
!MG Tristan these
! & (/5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 2.5, 2., 2./)
!-
! Type of behaviour of the LAI evolution algorithm
! for each vegetation type.
! Value of type_of_lai, one for each vegetation type : mean or interp
CHARACTER(len=5),DIMENSION(nvm),SAVE :: type_of_lai = &
& (/ 'mean ', 'mean ', 'inter', 'mean ', 'mean ', &
& 'inter', 'mean ', 'inter', 'inter', 'inter', &
& 'inter', 'inter', 'inter' /)
!-
! Is the vegetation type a tree ?
LOGICAL, DIMENSION(nvm),SAVE :: is_tree = &
& (/ .FALSE., .TRUE., .TRUE., .TRUE., .TRUE., &
& .TRUE., .TRUE., .TRUE., .TRUE., .FALSE., &
& .FALSE., .FALSE., .FALSE. /)
!-
! Initial snow albedo value for each vegetation type
! as it will be used in condveg_snow
! Values are from the Thesis of S. Chalita (1992)
! REAL(r_std),DIMENSION(nvm),SAVE :: snowa_ini = &
! & (/ 0.55, 0., 0., 0.14, 0.15, &
! & 0.15, 0.14, 0.15, 0.14, 0.18, &
! & 0.18, 0.18, 0.18 /)
! Nathalie - Decembre 2006 - on limite les albedos de sol nu en presence de neige, ainsi que ceux de la vegetation
! les valeurs choisies sont proches de celles que nous avions prises dans LMD5.3 avec Delphine Texier
REAL(r_std),DIMENSION(nvm),SAVE :: snowa_ini = &
& (/ 0.35, 0., 0., 0.14, 0.14, &
& 0.14, 0.14, 0.14, 0.14, 0.18, &
& 0.18, 0.18, 0.18 /)
!-
! Decay rate of snow albedo value for each vegetation type
! as it will be used in condveg_snow
! Values are from the Thesis of S. Chalita (1992)
! REAL(r_std),DIMENSION(nvm),SAVE :: snowa_dec = &
! & (/ 0.30, 0., 0., 0.06, 0.14, &
! & 0.14, 0.06, 0.25, 0.06, 0.63, &
! & 0.63, 0.63, 0.63 /)
! Nathalie - Decembre 2006 - on limite les albedos de sol nu en presence de neige, ainsi que ceux de la vegetation
! les valeurs choisies sont proches de celles que nous avions prises dans LMD5.3 avec Delphine Texier
!-
REAL(r_std),DIMENSION(nvm),SAVE :: snowa_dec = &
& (/ 0.45, 0., 0., 0.06, 0.06, &
& 0.11, 0.06, 0.11, 0.11, 0.52, &
& 0.52, 0.52, 0.52 /)
!-
! leaf albedo of vegetation type, VIS+NIR
REAL(r_std),DIMENSION(nvm*2),SAVE :: alb_leaf = &
& (/ .00, .04, .06, .06, .06, &
& .06, .06, .06, .06, .10, &
& .10, .10, .10, &
& .00, .20, .22, .22, .22, &
& .22, .22, .22, .22, .30, &
& .30, .30, .30 /)
!-
! Table which contains the correlation between the soil types
! and vegetation type. Two modes exist :
! 1) pref_soil_veg = 0 then we have an equidistribution
! of vegetation on soil types
! 2) Else for each pft the prefered soil type is given :
! 1=sand, 2=loan, 3=clay
! The variable is initialized in slowproc.
INTEGER(i_std),DIMENSION(nvm),SAVE :: pref_soil_veg
!-
! albedo of dead leaves, VIS+NIR
REAL(r_std),DIMENSION(2),SAVE :: alb_deadleaf = (/ .12, .35/)
! albedo of ice, VIS+NIR
REAL(r_std),DIMENSION(2),SAVE :: alb_ice = (/ .60, .20/)
!-
! Is veget_ori array stored in restart file
LOGICAL,PARAMETER :: ldveget_ori_on_restart = .TRUE.
!-
! Set to .TRUE. if you want q_cdrag coming from GCM
LOGICAL,PARAMETER :: ldq_cdrag_from_gcm = .FALSE.
!-
! Constant in the computation of surface resistance
REAL(r_std),PARAMETER :: rayt_cste = 125.
!-
! Size of local array to keep saturated humidity
! at each temperature level
INTEGER(i_std),PARAMETER :: max_temp=370
! Minimum temperature for saturated humidity
INTEGER(i_std),PARAMETER :: min_temp=100
! Local array to keep saturated humidity at each temperature level
REAL(r_std),DIMENSION(max_temp),SAVE :: qsfrict
!-
!===
CONTAINS
!===
SUBROUTINE qsatcalc (kjpindex,temp_in,pres_in,qsat_out)
!---------------------------------------------------------------------
! input value
! Domain size
INTEGER(i_std),INTENT(in) :: kjpindex
! Temperature in degre Kelvin
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: temp_in
! Pressure
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: pres_in
! output value
! Result
REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: qsat_out
!-
! local variables
INTEGER(i_std), DIMENSION(kjpindex) :: jt
INTEGER(i_std) :: ji
REAL(r_std),DIMENSION(kjpindex) :: zz_a, zz_b, zz_f
INTEGER(i_std) :: nbad
INTEGER(i_std),DIMENSION(1) :: lo
!---------------------------------------------------------------------
IF (l_qsat_first) THEN
CALL qsfrict_init
l_qsat_first = .FALSE.
ENDIF
!-
! 1. computes qsat interpolation into two successive temperature
!-
jt = INT(temp_in(:))
!-
nbad = COUNT(jt(:) >= max_temp-1)
IF (nbad > 0) THEN
WRITE(numout,*) ' qsatcalc: temperature too high at ', &
& nbad, ' points.'
IF (.NOT.diag_qsat) THEN
CALL ipslerr(2,'qsatcalc','diffuco', '', &
& 'temperature incorect.')
ELSE
lo = MAXLOC(temp_in(:))
WRITE(numout,*) &
& 'Maximum temperature ( ',MAXVAL(temp_in),') found at ',lo(1)
WHERE (jt(:) >= max_temp-1) jt(:) = max_temp-1
ENDIF
ENDIF
!-
nbad = COUNT(jt(:) <= min_temp)
IF (nbad > 0) THEN
WRITE(numout,*) ' qsatcalc: temperature too low at ', &
& nbad, ' points.'
IF (.NOT.diag_qsat) THEN
CALL ipslerr(2,'qsatcalc','diffuco', '', &
& 'temperature incorect.')
ELSE
lo = MINLOC(temp_in(:))
WRITE(numout,*) &
& 'Minimum temperature ( ',MINVAL(temp_in),') found at ',lo(1)
WHERE (jt(:) <= min_temp) jt(:) = min_temp
ENDIF
ENDIF
!-
DO ji = 1, kjpindex
zz_f(ji) = temp_in(ji)-FLOAT(jt(ji))
zz_a(ji) = qsfrict(jt(ji))
zz_b(ji) = qsfrict(jt(ji)+1)
ENDDO
!-
! 2. interpolates between this two values
!-
DO ji = 1, kjpindex
qsat_out(ji) = ((zz_b(ji)-zz_a(ji))*zz_f(ji)+zz_a(ji))/pres_in(ji)
ENDDO
!----------------------
END SUBROUTINE qsatcalc
!===
FUNCTION qsat (temp_in,pres_in) RESULT (qsat_result)
!!--------------------------------------------------------------------
!! FUNCTION qsat (temp_in, pres_in) RESULT (qsat_result)
!!--------------------------------------------------------------------
REAL(r_std),INTENT(in) :: temp_in ! Temperature in degre Kelvin
REAL(r_std),INTENT(in) :: pres_in ! Pressure
REAL(r_std) :: qsat_result
!-
INTEGER(i_std) :: jt
REAL(r_std) :: zz_a,zz_b,zz_f
!---------------------------------------------------------------------
IF (l_qsat_first) THEN
CALL qsfrict_init
l_qsat_first = .FALSE.
ENDIF
!-
! 1. computes qsat interpolation into two successive temperature
!-
jt = INT(temp_in)
!-
IF (jt >= max_temp-1) THEN
WRITE(numout,*) &
& ' We stop. temperature too BIG : ',temp_in, &
& ' approximation for : ',jt
IF (.NOT.diag_qsat) THEN
CALL ipslerr(2,'qsat','', '',&
& 'temperature incorect.')
ELSE
qsat_result = 999999.
RETURN
ENDIF
ENDIF
!-
IF (jt <= min_temp ) THEN
WRITE(numout,*) &
& ' We stop. temperature too SMALL : ',temp_in, &
& ' approximation for : ',jt
IF (.NOT.diag_qsat) THEN
CALL ipslerr(2,'qsat','', '',&
& 'temperature incorect.')
ELSE
qsat_result = -999999.
RETURN
ENDIF
ENDIF
!-
zz_f = temp_in-FLOAT(jt)
zz_a = qsfrict(jt)
zz_b = qsfrict(jt+1)
!-
! 2. interpolates between this two values
!-
qsat_result = ((zz_b-zz_a)*zz_f+zz_a)/pres_in
!----------------
END FUNCTION qsat
!===
SUBROUTINE dev_qsatcalc (kjpindex,temp_in,pres_in,dev_qsat_out)
!---------------------------------------------------------------------
! Domain size
INTEGER(i_std),INTENT(in) :: kjpindex
! Temperature in degre Kelvin
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: temp_in
! Pressure
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: pres_in
! Result
REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: dev_qsat_out
!-
INTEGER(i_std),DIMENSION(kjpindex) :: jt
INTEGER(i_std) :: ji
REAL(r_std),DIMENSION(kjpindex) :: zz_a, zz_b, zz_c, zz_f
INTEGER(i_std) :: nbad
!---------------------------------------------------------------------
IF (l_qsat_first) THEN
CALL qsfrict_init
l_qsat_first = .FALSE.
ENDIF
!-
! 1. computes qsat interpolation into two successive temperature
!-
jt = INT(temp_in(:)+undemi)
!-
nbad = COUNT( jt(:) >= max_temp-1 )
IF (nbad > 0) THEN
WRITE(numout,*) &
& ' dev_qsatcalc: temperature too high at ',nbad,' points.'
IF (.NOT.diag_qsat) THEN
CALL ipslerr(3,'dev_qsatcalc','', '', &
& 'temperature incorect.')
ELSE
WHERE (jt(:) >= max_temp-1) jt(:) = max_temp-1
ENDIF
ENDIF
!-
nbad = COUNT( jt(:) <= min_temp )
IF (nbad > 0) THEN
WRITE(numout,*) &
& ' dev_qsatcalc: temperature too low at ',nbad,' points.'
IF (.NOT.diag_qsat) THEN
CALL ipslerr(3,'dev_qsatcalc', '', '',&
& 'temperature incorect.')
ELSE
WHERE (jt(:) <= min_temp) jt(:) = min_temp
ENDIF
ENDIF
!-
DO ji=1,kjpindex
zz_f(ji) = temp_in(ji)+undemi-FLOAT(jt(ji))
zz_a(ji) = qsfrict(jt(ji)-1)
zz_b(ji) = qsfrict(jt(ji))
zz_c(ji) = qsfrict(jt(ji)+1)
ENDDO
!-
! 2. interpolates between this two values
!-
DO ji = 1, kjpindex
dev_qsat_out(ji) = &
& ((zz_c(ji)-deux*zz_b(ji)+zz_a(ji))*(zz_f(ji)-un) + &
& zz_c(ji)-zz_b(ji))/pres_in(ji)
ENDDO
!--------------------------
END SUBROUTINE dev_qsatcalc
!===
FUNCTION dev_qsat (temp_in,pres_in) RESULT (dev_qsat_result)
!!--------------------------------------------------------------------
!! FUNCTION dev_qsat (temp_in, pres_in) RESULT (dev_qsat_result)
!! computes deviation of qsat
!!--------------------------------------------------------------------
REAL(r_std),INTENT(in) :: pres_in ! Pressure
REAL(r_std),INTENT(in) :: temp_in ! Temperture in degre Kelvin
REAL(r_std) :: dev_qsat_result
!-
INTEGER(i_std) :: jt
REAL(r_std) :: zz_a, zz_b, zz_c, zz_f
!---------------------------------------------------------------------
IF (l_qsat_first) THEN
CALL qsfrict_init
l_qsat_first = .FALSE.
ENDIF
!-
! 1. computes qsat deviation interpolation
! into two successive temperature
!-
jt = INT(temp_in+undemi)
!-
IF (jt >= max_temp-1) THEN
WRITE(numout,*) &
& ' We stop. temperature too HIGH : ',temp_in, &
& ' approximation for : ',jt
IF (.NOT.diag_qsat) THEN
CALL ipslerr(3,'dev_qsat','', '',&
& 'temperature incorect.')
ELSE
dev_qsat_result = 999999.
RETURN
ENDIF
ENDIF
!-
IF (jt <= min_temp ) THEN
WRITE(numout,*) &
& ' We stop. temperature too LOW : ',temp_in, &
& ' approximation for : ',jt
IF (.NOT.diag_qsat) THEN
CALL ipslerr(3,'dev_qsat','', '',&
& 'temperature incorect.')
ELSE
dev_qsat_result = -999999.
RETURN
ENDIF
ENDIF
!-
zz_f = temp_in+undemi-FLOAT(jt)
zz_a = qsfrict(jt-1)
zz_b = qsfrict(jt)
zz_c = qsfrict(jt+1)
!-
! 2. interpolates
!-
dev_qsat_result=((zz_c-deux*zz_b+zz_a)*(zz_f-un)+zz_c-zz_b)/pres_in
!--------------------
END FUNCTION dev_qsat
!===
SUBROUTINE qsfrict_init
!!--------------------------------------------------------------------
!! The qsfrict_init routine initialises qsfrict array
!! to store precalculated value for qsat
!!--------------------------------------------------------------------
INTEGER(i_std) :: ji
REAL(r_std) :: zrapp,zcorr,ztemperature,zqsat
!---------------------------------------------------------------------
! initialisation
zrapp = msmlr_h2o/msmlr_air
zcorr = 0.00320991_r_std
! computes saturated humidity one time and store in qsfrict local array
DO ji=100,max_temp
ztemperature = FLOAT(ji)
IF (ztemperature < 273._r_std) THEN
zqsat = zrapp*10.0_r_std**(2.07023_r_std-zcorr*ztemperature &
& -2484.896/ztemperature+3.56654*LOG10(ztemperature))
ELSE
zqsat = zrapp*10.0**(23.8319-2948.964/ztemperature &
& -5.028*LOG10(ztemperature) &
& -29810.16*EXP(-0.0699382*ztemperature) &
& +25.21935*EXP(-2999.924/ztemperature))
ENDIF
qsfrict (ji) = zqsat
ENDDO
!-
qsfrict(1:100) = zero
!-
IF (long_print) WRITE (numout,*) ' qsfrict_init done'
!--------------------------
END SUBROUTINE qsfrict_init
!===
FUNCTION tempfunc (temp_in) RESULT (tempfunc_result)
!!--------------------------------------------------------------------
!! FUNCTION tempfunc (temp_in) RESULT (tempfunc_result)
!! this function interpolates value between ztempmin and ztempmax
!! used for lai detection
!!--------------------------------------------------------------------
REAL(r_std),INTENT(in) :: temp_in !! Temperature in degre Kelvin
REAL(r_std) :: tempfunc_result
!-
REAL(r_std),PARAMETER :: ztempmin=273._r_std !! Temperature for laimin
REAL(r_std),PARAMETER :: ztempmax=293._r_std !! Temperature for laimax
REAL(r_std) :: zfacteur !! Interpolation factor
!---------------------------------------------------------------------
zfacteur = un/(ztempmax-ztempmin)**2
IF (temp_in > ztempmax) THEN
tempfunc_result = un
ELSEIF (temp_in < ztempmin) THEN
tempfunc_result = zero
ELSE
tempfunc_result = un-zfacteur*(ztempmax-temp_in)**2
ENDIF
!--------------------
END FUNCTION tempfunc
!===
SUBROUTINE get_vegcorr (nolson,vegcorr,nobiocorr)
!---------------------------------------------------------------------
INTEGER(i_std),INTENT(in) :: nolson
REAL(r_std),DIMENSION(nolson,nvm),INTENT(out) :: vegcorr(nolson,nvm)
REAL(r_std),DIMENSION(nolson,nnobio),INTENT(out) :: nobiocorr
!-
INTEGER(i_std) :: ib
INTEGER(i_std),PARAMETER :: nolson94 = 94
INTEGER(i_std),PARAMETER :: nvm13 = 13
!---------------------------------------------------------------------
IF (nolson /= nolson94) THEN
WRITE(numout,*) nolson,nolson94
CALL ipslerr(3,'get_vegcorr', '', '',&
& 'wrong number of OLSON vegetation types.')
ENDIF
IF (nvm /= nvm13) THEN
WRITE(numout,*) nvm,nvm13
CALL ipslerr(3,'get_vegcorr', '', '',&
& 'wrong number of SECHIBA vegetation types.')
ENDIF
!-
! 1 set the indices of non-biospheric surface types to 0.
!-
nobiocorr(:,:) = 0.
!-
! 2 Here we construct the correspondance table
! between Olson and the following SECHIBA Classes.
! vegcorr(i,:)+nobiocorr(i,:) = 1. for all i.
!-
! The modified OLSON types found in file carteveg5km.nc
! created by Nicolas Viovy :
! 1 Urban
vegcorr( 1,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 2 Cool low sparse grassland
vegcorr( 2,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 3 Cold conifer forest
vegcorr( 3,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 4 Cold deciduous conifer forest
vegcorr( 4,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0/)
! 5 Cool Deciduous broadleaf forest
vegcorr( 5,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 6 Cool evergreen broadleaf forests
vegcorr( 6,:) = &
& (/0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 7 Cool tall grasses and shrubs
vegcorr( 7,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 8 Warm C3 tall grasses and shrubs
vegcorr( 8,:) = &
& (/0.1, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 9 Warm C4 tall grases and shrubs
vegcorr( 9,:) = &
& (/0.1, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0/)
! 10 Bare desert
vegcorr(10,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 11 Cold upland tundra
vegcorr(11,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 12 Cool irrigated grassland
vegcorr(12,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.0/)
! 13 Semi desert
vegcorr(13,:) = &
& (/0.7, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 14 Glacier ice
vegcorr(14,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
nobiocorr(14,iice) = 1.
! 15 Warm wooded wet swamp
vegcorr(15,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0/)
! 16 Inland water
vegcorr(16,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 17 sea water
vegcorr(17,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 18 cool shrub evergreen
vegcorr(18,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 19 cold shrub deciduous
vegcorr(19,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 20 Cold evergreen forest and fields
vegcorr(20,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0/)
! 21 cool rain forest
vegcorr(21,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 22 cold conifer boreal forest
vegcorr(22,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 23 cool conifer forest
vegcorr(23,:) = &
& (/0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 24 warm mixed forest
vegcorr(24,:) = &
& (/0.0, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0/)
! 25 cool mixed forest
vegcorr(25,:) = &
& (/0.0, 0.0, 0.0, 0.4, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 26 cool broadleaf forest
vegcorr(26,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0/)
! 27 cool deciduous broadleaf forest
vegcorr(27,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.3, 0.5, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 28 warm montane tropical forest
vegcorr(28,:) = &
& (/0.0, 0.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0/)
! 29 warm seasonal tropical forest
vegcorr(29,:) = &
& (/0.0, 0.5, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0/)
! 30 cool crops and towns
vegcorr(30,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0/)
! 31 warm crops and towns
vegcorr(31,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8/)
! 32 cool crops and towns
vegcorr(32,:) = &
& (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0/)
! 33 warm dry tropical woods
vegcorr(33,:) = &
& (/0.2, 0.0, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 34 warm tropical rain forest
vegcorr(34,:) = &
& (/0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 35 warm tropical degraded forest
vegcorr(35,:) = &
& (/0.1, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0/)
! 36 warm corn and beans cropland
vegcorr(36,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0/)
! 37 cool corn and bean cropland
vegcorr(37,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
! 38 warm rice paddy and field
vegcorr(38,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0/)
! 39 hot irrigated cropland
vegcorr(39,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0/)
! 40 cool irrigated cropland
vegcorr(40,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
! 41 cold irrigated cropland
vegcorr(41,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
! 42 cool grasses and shrubs
vegcorr(42,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 43 hot and mild grasses and shrubs
vegcorr(43,:) = &
& (/0.2, 0.0, 0.1, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0/)
! 44 cold grassland
vegcorr(44,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.0/)
! 45 Savanna (woods) C3
vegcorr(45,:) = &
& (/0.1, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 46 Savanna woods C4
vegcorr(46,:) = &
& (/0.1, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0/)
! 47 Mire, bog, fen
vegcorr(47,:) = &
& (/0.1, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 48 Warm marsh wetland
vegcorr(48,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 49 cold marsh wetland
vegcorr(49,:) = &
& (/0.0, 0.0, 0.0, 0.1, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 50 mediteraean scrub
vegcorr(50,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 51 Cool dry woody scrub
vegcorr(51,:) = &
& (/0.3, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 52 Warm dry evergreen woods
vegcorr(52,:) = &
& (/0.1, 0.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 53 Volcanic rocks
vegcorr(53,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 54 send desert
vegcorr(54,:) = &
& (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 55 warm semi desert shrubs
vegcorr(55,:) = &
& (/0.7, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 56 cool semi desert shrubs
vegcorr(56,:) = &
& (/0.6, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0/)
! 57 semi desert sage
vegcorr(57,:) = &
& (/0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 58 Barren tundra
vegcorr(58,:) = &
& (/0.6, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0/)
! 59 cool southern hemisphere mixed forest
vegcorr(59,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 60 cool fields and woods
vegcorr(60,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 61 warm forest and filed
vegcorr(61,:) = &
& (/0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6/)
! 62 cool forest and field
vegcorr(62,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 63 warm C3 fields and woody savanna
vegcorr(63,:) = &
& (/0.1, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 64 warm C4 fields and woody savanna
vegcorr(64,:) = &
& (/0.1, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6/)
! 65 cool fields and woody savanna
vegcorr(65,:) = &
& (/0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 66 warm succulent and thorn scrub
vegcorr(66,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
! 67 cold small leaf mixed woods
vegcorr(67,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.3, 0.0, 0.5, 0.0, 0.0, 0.0/)
! 68 cold deciduous and mixed boreal fores
vegcorr(68,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
! 69 cold narrow conifers
vegcorr(69,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0/)
! 70 cold wooded tundra
vegcorr(70,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 71 cold heath scrub
vegcorr(71,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.7, 0.0, 0.0, 0.0/)
! 72 Polar and alpine desert
vegcorr(72,:) = &
& (/0.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0/)
! 73 warm Mangrove
vegcorr(73,:) = &
& (/0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 74 cool crop and water mixtures
vegcorr(74,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
! 75 cool southern hemisphere mixed forest
vegcorr(75,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 76 cool moist eucalyptus
vegcorr(76,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
! 77 warm rain green tropical forest
vegcorr(77,:) = &
& (/0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! 78 warm C3 woody savanna
vegcorr(78,:) = &
& (/0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 79 warm C4 woody savanna
vegcorr(79,:) = &
& (/0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 80 cool woody savanna
vegcorr(80,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 81 cold woody savanna
vegcorr(81,:) = &
& (/0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
! 82 warm broadleaf crops
vegcorr(82,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0/)
! 83 warm C3 grass crops
vegcorr(83,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0/)
! 84 warm C4 grass crops
vegcorr(84,:) = &
& (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9/)
! 85 cool grass crops
vegcorr(85,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
! 86 warm C3 crops grass,shrubs
vegcorr(86,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0/)
! 87 cool crops,grass,shrubs
vegcorr(87,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.5, 0.0, 0.5, 0.0/)
! 88 warm evergreen tree crop
vegcorr(88,:) = &
& (/0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2/)
! 89 cool evergreen tree crop
vegcorr(89,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0/)
! 90 cold evergreen tree crop
vegcorr(90,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0/)
! 91 warm deciduous tree crop
vegcorr(91,:) = &
& (/0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2/)
! 92 cool deciduous tree crop
vegcorr(92,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0/)
! 93 cold deciduous tree crop
vegcorr(93,:) = &
& (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.2, 0.0/)
! 94 wet sclerophylic forest
vegcorr(94,:) = &
& (/0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
!-
! 3 Check the mapping for the Olson types which are going into the
! the veget and nobio array.
!-
DO ib=1,nolson
IF ( ABS(SUM(vegcorr(ib,:))+SUM(nobiocorr(ib,:))-1.0) &
& > EPSILON(1.0)) THEN
WRITE(numout,*) 'Wrong correspondance for Olson type :', ib
CALL ipslerr(3,'get_vegcorr', '', '',&
& 'Wrong correspondance for Olson type.')
ENDIF
ENDDO
!-------------------------
END SUBROUTINE get_vegcorr
!===
SUBROUTINE get_soilcorr (nclass, textfrac_table)
!! The "get_soilcorr" routine defines the table of correspondence
!! between the Zobler types and the three texture
!! types known by SECHIBA & STOMATE : silt, sand and clay - Verifier aupres de patricia tdo
INTEGER(i_std), INTENT(in) :: nclass
REAL(r_std), DIMENSION(nclass,nscm_fao), INTENT(out) :: textfrac_table(nclass,ntext)
INTEGER(i_std), PARAMETER :: nzobler = 7
INTEGER(i_std) :: ib
!
!
SELECTCASE(nclass)
!
! Textural fraction for : silt sand clay
!
CASE(nzobler)
textfrac_table(1,:) = (/ 0.12, 0.82, 0.06 /)
textfrac_table(2,:) = (/ 0.32, 0.58, 0.10 /)
textfrac_table(3,:) = (/ 0.39, 0.43, 0.18 /)
textfrac_table(4,:) = (/ 0.15, 0.58, 0.27 /)
textfrac_table(5,:) = (/ 0.34, 0.32, 0.34 /)
textfrac_table(6,:) = (/ 0.00, 1.00, 0.00 /)
textfrac_table(7,:) = (/ 0.39, 0.43, 0.18 /)
CASE(nscm_fao)
textfrac_table(1,:) = (/ 0.26, 0.63, 0.11 /)
textfrac_table(2,:) = (/ 0.40, 0.40, 0.20 /)
textfrac_table(3,:) = (/ 0.37, 0.30, 0.33 /)
CASE(nscm_fao*2-1)
textfrac_table(1,:) = (/ 0.26, 0.63, 0.11 /)
textfrac_table(2,:) = (/ 0.26, 0.63, 0.11 /)
textfrac_table(3,:) = (/ 0.40, 0.40, 0.20 /)
textfrac_table(4,:) = (/ 0.40, 0.40, 0.20 /)
textfrac_table(5,:) = (/ 0.37, 0.30, 0.33 /)
CASE(nscm_usda)
textfrac_table(1,:) = (/ 0.04, 0.93, 0.03 /)
textfrac_table(2,:) = (/ 0.13, 0.81, 0.06 /)
textfrac_table(3,:) = (/ 0.26, 0.63, 0.11 /)
textfrac_table(4,:) = (/ 0.64, 0.17, 0.19 /)
textfrac_table(5,:) = (/ 0.84, 0.06, 0.10 /)
textfrac_table(6,:) = (/ 0.40, 0.40, 0.20 /)
textfrac_table(7,:) = (/ 0.19, 0.54, 0.27 /)
textfrac_table(8,:) = (/ 0.59, 0.08, 0.33 /)
textfrac_table(9,:) = (/ 0.37, 0.30, 0.33 /)
textfrac_table(10,:) = (/ 0.11, 0.48, 0.41 /)
textfrac_table(11,:) = (/ 0.48, 0.06, 0.46 /)
textfrac_table(12,:) = (/ 0.30, 0.15, 0.55 /)
CASE DEFAULT
WRITE(*,*) 'We do not have the correct number of classes in the code for the file'
STOP 'GET_soilcorr'
ENDSELECT
!
DO ib=1,nclass
IF ( ABS(SUM(textfrac_table(ib,:))-1.0) .GT. EPSILON(1.0) ) THEN
WRITE(*,*) 'Error in the correspondence table, sum is not equal to 1 in', ib
WRITE(*,*) textfrac_table(ib,:)
STOP 'GET_soilcorr'
ENDIF
ENDDO
!--------------------------
END SUBROUTINE GET_soilcorr
!===
!------------------------
END MODULE constantes_veg
ORCHIDEE/src_sechiba/ 0000754 0103600 0005670 00000000000 11205035745 014166 5 ustar acamlmd lmdjus ORCHIDEE/src_sechiba/CVS/ 0000754 0103600 0005670 00000000000 11164403473 014622 5 ustar acamlmd lmdjus ORCHIDEE/src_sechiba/CVS/Root 0000754 0103600 0005670 00000000071 11164403473 015471 0 ustar acamlmd lmdjus :pserver:sechiba@cvs.ipsl.jussieu.fr:/home/ssipsl/CVSREP
ORCHIDEE/src_sechiba/CVS/Repository 0000754 0103600 0005670 00000000025 11164403473 016724 0 ustar acamlmd lmdjus ORCHIDEE/src_sechiba
ORCHIDEE/src_sechiba/CVS/Entries 0000754 0103600 0005670 00000001465 11164403473 016167 0 ustar acamlmd lmdjus /AA_make/1.17/Tue Jun 12 19:56:03 2007//Torchidee_1_9
/AA_make.ldef/1.6/Tue Nov 7 07:57:08 2006//Torchidee_1_9
/condveg.f90/1.27/Tue Jun 12 19:19:59 2007//Torchidee_1_9
/diffuco.f90/1.29/Tue Jun 12 19:19:59 2007//Torchidee_1_9
/enerbil.f90/1.21/Tue Jun 12 20:02:37 2007//Torchidee_1_9
/hydrol.f90/1.35/Tue Jun 12 20:02:37 2007//Torchidee_1_9
/hydrolc.f90/1.10/Tue Jun 12 20:02:37 2007//Torchidee_1_9
/intersurf.f90/1.57/Thu Jun 21 09:54:45 2007//Torchidee_1_9
/routing.f90/1.39/Tue Jun 12 20:23:23 2007//Torchidee_1_9
/sechiba.f90/1.37/Tue Jun 12 19:55:02 2007//Torchidee_1_9
/sechiba_io.f90/1.7/Tue Jun 12 19:53:24 2007//Torchidee_1_9
/sechiba_io_p.f90/1.2/Tue Jun 12 19:53:24 2007//Torchidee_1_9
/slowproc.f90/1.31/Tue Jun 12 20:15:58 2007//Torchidee_1_9
/thermosoil.f90/1.13/Tue Jun 12 20:06:12 2007//Torchidee_1_9
D
ORCHIDEE/src_sechiba/CVS/Tag 0000754 0103600 0005670 00000000016 11164403473 015260 0 ustar acamlmd lmdjus Norchidee_1_9
ORCHIDEE/src_sechiba/CVS/Template 0000754 0103600 0005670 00000000000 11164403473 016311 0 ustar acamlmd lmdjus ORCHIDEE/src_sechiba/AA_make 0000754 0103600 0005670 00000011057 11164403473 015377 0 ustar acamlmd lmdjus #-
#- $Id: AA_make,v 1.20 2008/01/08 11:49:07 ssipsl Exp $
#-
PARAM_LIB = $(LIBDIR)/libparameters.a
SXPARAM_LIB = $(PARAM_LIB)
#-Q- sxnec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-Q- sx6nec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-Q- eshpux SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-Q- sx8brodie SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-
PARALLEL_LIB = $(LIBDIR)/libparallel.a
SXPARALLEL_LIB = $(PARALLEL_LIB)
#-Q- sxnec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
#-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
#-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
#-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
#-
ORGLOB_LIB = $(LIBDIR)/liborglob.a
SXORGLOB_LIB = $(ORGLOB_LIB)
#-Q- sxnec SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
#-Q- sx6nec SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
#-Q- eshpux SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
#-Q- sx8brodie SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
#-
STOMATE_LIB = $(LIBDIR)/libstomate.a
SXSTOMATE_LIB = $(STOMATE_LIB)
#-Q- sxnec SXSTOMATE_LIB = $(LIBDIR)/libsxstomate.a
#-Q- sx6nec SXSTOMATE_LIB = $(LIBDIR)/libsxstomate.a
#-Q- eshpux SXSTOMATE_LIB = $(LIBDIR)/libsxstomate.a
#-Q- sx8brodie SXSTOMATE_LIB = $(LIBDIR)/libsxstomate.a
#-
MODS1 = \
sechiba_io_p.f90 \
sechiba_io.f90 \
slowproc.f90 \
diffuco.f90 \
condveg.f90 \
enerbil.f90 \
hydrol.f90 \
hydrolc.f90 \
thermosoil.f90 \
routing.f90 \
sechiba.f90 \
intersurf.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-Q- sxnec .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
#-
all:
$(M_K) libparameters
$(M_K) libparallel
$(M_K) libstomate
$(M_K) m_all
@echo sechiba is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
#-Q- intel m_all: WORK_MOD $(MODEL_LIB)($(OBJSMODS1))
libparameters:
(cd ../src_parameters; $(M_K) -f Makefile)
libparallel:
(cd ../src_parallel; $(M_K) -f Makefile)
liborglob:
(cd ../src_global; $(M_K) -f Makefile)
libstomate:
(cd ../src_stomate; $(M_K) -f Makefile)
$(MODEL_LIB)(%.o) : %.f90
$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
$(A_C) $(MODEL_LIB) $*.o
#-Q- sxnec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sxnec mv $*.mod $(MODDIR)
#-Q- sx6nec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx6nec mv $*.mod $(MODDIR)
#-Q- eshpux $(A_X) $(SXMODEL_LIB) $*.o
#-Q- eshpux mv $*.mod $(MODDIR)
#-Q- sx8mercure mv $*.mod $(MODDIR)
#-Q- sx8brodie $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx8brodie mv $*.mod $(MODDIR)
#-Q- solaris mv $*.mod $(MODDIR)
$(RM) $*.o
#-Q- intel
#-Q- intel WORK_MOD :
#-Q- intel $(RM) work.pcl
#-Q- intel @echo "work.pc" > work.pcl
#-Q- intel @echo "../src_parameters/work.pc" >> work.pcl
#-Q- intel @echo "../src_stomate/work.pc" >> work.pcl
#-Q- intel @echo "../../IOIPSL/src/work.pc" >> work.pcl
config :
$(BINDIR)/Fparser -name SECHIBA $(MODS1)
echo 'Configuration of SECHIBA done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(sechiba.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(MODEL_LIB)(sechiba_io_p.o) \
$(MODEL_LIB)(sechiba_io.o) \
$(MODEL_LIB)(diffuco.o) \
$(MODEL_LIB)(condveg.o) \
$(MODEL_LIB)(enerbil.o) \
$(MODEL_LIB)(hydrolc.o) \
$(MODEL_LIB)(hydrol.o) \
$(MODEL_LIB)(thermosoil.o) \
$(MODEL_LIB)(slowproc.o) \
$(MODEL_LIB)(routing.o)
$(MODEL_LIB)(sechiba_io_p.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(PARALLEL_LIB)(parallel.o)
$(MODEL_LIB)(sechiba_io.o): \
$(MODEL_LIB)(sechiba_io_p.o) \
$(PARAM_LIB)(constantes_veg.o)
$(MODEL_LIB)(hydrol.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(MODEL_LIB)(sechiba_io.o) \
$(ORGLOB_LIB)(grid.o)
$(MODEL_LIB)(hydrolc.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(slowproc.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(STOMATE_LIB)(stomate.o) \
$(MODEL_LIB)(sechiba_io.o) \
$(ORGLOB_LIB)(interpol_help.o)
$(MODEL_LIB)(diffuco.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(enerbil.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(condveg.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(ORGLOB_LIB)(interpol_help.o)
$(MODEL_LIB)(thermosoil.o): \
$(PARAM_LIB)(constantes_soil.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(routing.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(intersurf.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(ORGLOB_LIB)(grid.o) \
$(MODEL_LIB)(sechiba.o)
ORCHIDEE/src_sechiba/AA_make.ldef 0000754 0103600 0005670 00000001346 11164403473 016310 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.7 2008/01/08 11:49:07 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a SECHIBA
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/libsechiba.a
SXMODEL_LIB = $(MODEL_LIB)
#-Q- sxnec SXMODEL_LIB = $(LIBDIR)/libsxsechiba.a
#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxsechiba.a
#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxsechiba.a
#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxsechiba.a
ORCHIDEE/src_sechiba/condveg.f90 0000754 0103600 0005670 00000140275 11164403473 016150 0 ustar acamlmd lmdjus !!
!! This module computes surface conditions
!! - albedo
!! - roughness
!! - emissivity
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.27 $, $Date: 2007/06/12 19:19:59 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/condveg.f90,v 1.27 2007/06/12 19:19:59 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE condveg
!
USE ioipsl
!
! modules used :
USE constantes
USE constantes_veg
USE interpol_help
USE parallel
IMPLICIT NONE
! public routines :
! condveg_main only
PRIVATE
PUBLIC :: condveg_main,condveg_clear
!
! variables used inside condveg module : declaration and initialisation
!
LOGICAL, SAVE :: l_first_condveg=.TRUE. !! To keep first call's trace
LOGICAL, SAVE :: z0cdrag_ave=.FALSE. !! Chooses the method for the z0 average
!
REAL(r_std), SAVE :: fixed_snow_albedo !! In case we wish a fxed snow albedo
INTEGER(i_std), PARAMETER :: ivis = 1 !! index for visible albedo
INTEGER(i_std), PARAMETER :: inir = 2 !! index for near infrared albedo
LOGICAL, SAVE :: impaze !! Choice on the surface parameters
!
REAL(r_std), SAVE :: z0_scal !! Roughness used to initialize the scheme
REAL(r_std), SAVE :: roughheight_scal !! Height to displace the surface
!! from the zero wind height.
REAL(r_std), SAVE :: albedo_scal(2) !! Two albedos used to initialize the scheme
REAL(r_std), SAVE :: emis_scal !! Surface emissivity used to initialize the scheme
!
REAL(r_std), ALLOCATABLE, SAVE :: soilalb_dry(:,:) !! albedo for the dry bare soil
REAL(r_std), ALLOCATABLE, SAVE :: soilalb_wet(:,:) !! albedo for the wet bare soil
! Ajout Nathalie pour autre calcul soilalbedo
REAL(r_std), ALLOCATABLE, SAVE :: soilalb_moy(:,:) !! mean soil albedo
REAL(r_std), PARAMETER :: z0_over_height = un/16. !! to get z0 from height
REAL(r_std), PARAMETER :: height_displacement = 0.75 !! Magic number which relates the
!! height to the displacement height.
!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: albedo_snow !! Snow albedo
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: albedo_glob !! Mean albedo
!
LOGICAL, SAVE :: alb_bare_model !! Switch to old (albedo bare depend on soil wetness)
!! or new one (mean of soilalb)
CONTAINS
!!
!! Main routine for *condveg* module
!! - called only one time for initialisation
!! - called every time step
!! - called one more time at last time step for writing _restart_ file
!!
!! Algorithm:
!! - call condveg_init for initialisation
!! - call condveg_var_init for initialisation done every time step
!! - call condveg_snow for computing the modification of the albedo induced by snow cover
!!
!! @call condveg_init
!! @call condveg_var_init
!! @call condveg_snow
!!
!!
SUBROUTINE condveg_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index,&
& lalo, neighbours, resolution, contfrac, veget, frac_nobio, totfrac_nobio, &
& zlev, snow, snow_age, snow_nobio, snow_nobio_age, frac_bare, &
& drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, rest_id, hist_id, hist2_id)
! interface description:
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std),INTENT (in) :: rest_id !! _Restart_ file identifier
INTEGER(i_std),INTENT (in) :: hist_id !! _History_ file identifier
INTEGER(i_std), OPTIONAL, INTENT (in) :: hist2_id !! _History_ file 2 identifier
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for restart file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for restart file to write
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geographical coordinates
INTEGER(i_std),DIMENSION (kjpindex,8), INTENT(in):: neighbours !! neighoring grid points if land
REAL(r_std), DIMENSION (kjpindex,2), INTENT(in) :: resolution !! size in x an y of the grid (m)
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: contfrac ! Fraction of land in each grid box.
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: veget !! Fraction of vegetation types
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio !! Fraction of continental ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: totfrac_nobio !! total fraction of continental ice+lakes+...
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: snow !! Snow mass [Kg/m^2]
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: snow_age !! Snow age
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio !! Snow mass [Kg/m^2] on ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: snow_nobio_age !! Snow age on ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: frac_bare !! Bare fraction in each tile
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: drysoil_frac !! Fraction of visibly Dry soil(between 0 and 1)
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: height !! Vegetation Height (m)
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: deadleaf_cover !! Fraction of soil covered by dead leaves
! output scalar
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: emis !! Emissivity
REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo !! Albedo, vis(1) and nir(2)
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: z0 !! Roughness
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: roughheight !! Effective height for roughness
! local
CHARACTER(LEN=80) :: var_name !! To store variables names for I/O
!
IF (l_first_condveg) THEN
IF (long_print) WRITE (numout,*) ' l_first_condveg : call condveg_init '
CALL condveg_init (kjit, ldrestart_read, kjpindex, index, veget, &
lalo, neighbours, resolution, contfrac, rest_id)
CALL condveg_var_init (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio, &
& frac_bare, drysoil_frac, zlev, height, deadleaf_cover, emis, albedo, z0, roughheight)
CALL condveg_snow (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio, &
snow, snow_age, snow_nobio, snow_nobio_age, albedo, albedo_snow, albedo_glob)
RETURN
ENDIF
CALL condveg_var_update (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio, &
& frac_bare, drysoil_frac, zlev, height, deadleaf_cover, emis, albedo, z0, roughheight)
CALL condveg_snow (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio, &
snow, snow_age, snow_nobio, snow_nobio_age, albedo, albedo_snow, albedo_glob)
IF (ldrestart_write) THEN
!
var_name = 'soilalbedo_dry'
CALL restput_p (rest_id, var_name, nbp_glo, 2, 1, kjit, soilalb_dry, 'scatter', nbp_glo, index_g)
!
var_name = 'soilalbedo_wet'
CALL restput_p (rest_id, var_name, nbp_glo, 2, 1, kjit, soilalb_wet, 'scatter', nbp_glo, index_g)
!
var_name = 'soilalbedo_moy'
CALL restput_p (rest_id, var_name, nbp_glo, 2, 1, kjit, soilalb_moy, 'scatter', nbp_glo, index_g)
!
RETURN
!
ENDIF
IF ( almaoutput ) THEN
CALL histwrite(hist_id, 'Albedo', kjit, albedo_glob, kjpindex, index)
CALL histwrite(hist_id, 'SAlbedo', kjit, albedo_snow, kjpindex, index)
IF ( hist2_id > 0 ) THEN
CALL histwrite(hist2_id, 'Albedo', kjit, albedo_glob, kjpindex, index)
CALL histwrite(hist2_id, 'SAlbedo', kjit, albedo_snow, kjpindex, index)
ENDIF
ENDIF
IF (long_print) WRITE (numout,*)' condveg_main done '
END SUBROUTINE condveg_main
!! Algorithm:
!! - dynamic allocation for local array
!!
SUBROUTINE condveg_init (kjit, ldrestart_read, kjpindex, index, veget, &
lalo, neighbours, resolution, contfrac, rest_id)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for restart file to read
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in):: veget !! Vegetation distribution
REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geographical coordinates
INTEGER(i_std),DIMENSION (kjpindex,4), INTENT(in):: neighbours !! neighoring grid points if land
REAL(r_std), DIMENSION (kjpindex,2), INTENT(in) :: resolution !! size in x an y of the grid (m)
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: contfrac ! Fraction of land in each grid box.
INTEGER(i_std), INTENT(in) :: rest_id !! Restart file identifier
! input fields
! output scalar
! output fields
! local declaration
INTEGER(i_std) :: ji
INTEGER(i_std) :: ier
CHARACTER(LEN=80) :: var_name !! To store variables names for I/O
! initialisation
IF (l_first_condveg) THEN
!
! Get the fixed snow albedo if needed
!
!
!Config Key = CONDVEG_SNOWA
!Config Desc = The snow albedo used by SECHIBA
!Config Def = DEF
!Config Help = This option allows the user to impose a snow albedo.
!Config Default behaviour is to use the model of snow albedo
!Config developed by Chalita (1993).
!
fixed_snow_albedo = undef_sechiba
CALL getin_p('CONDVEG_SNOWA', fixed_snow_albedo)
!
!
!Config Key = ALB_BARE_MODEL
!Config Desc = Switch bare soil albedo dependent (if TRUE) on soil wetness
!Config Def = FALSE
!Config Help = If TRUE, the model for bare soil albedo is the old formulation.
!Config Then it depend on the soil dry or wetness. If FALSE, it is the
!Config new computation that is taken, it is the mean of soil albedo.
!
alb_bare_model=.FALSE.
CALL getin_p('ALB_BARE_MODEL', alb_bare_model)
!
l_first_condveg=.FALSE.
!
! Allocate variables which have to
!
ALLOCATE (soilalb_dry(kjpindex,2),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soilalb_dry allocation. We stop.We need kjpindex words = ',kjpindex
STOP 'condveg_init'
END IF
soilalb_dry(:,:) = val_exp
ALLOCATE (soilalb_wet(kjpindex,2),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soilalb_wet allocation. We stop.We need kjpindex words = ',kjpindex
STOP 'condveg_init'
END IF
soilalb_wet(:,:) = val_exp
! Ajout Nathalie
ALLOCATE (soilalb_moy(kjpindex,2),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soilalb_moy allocation. We stop.We need kjpindex words = ',kjpindex
STOP 'condveg_init'
END IF
soilalb_moy(:,:) = val_exp
ALLOCATE (albedo_snow(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in albedo_snow allocation. We stop.We need kjpindex words = ',kjpindex
STOP 'condveg_init'
END IF
ALLOCATE (albedo_glob(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in albedo_glob allocation. We stop.We need kjpindex words = ',kjpindex
STOP 'condveg_init'
END IF
!
! Get the bare soil albedo
!
!
var_name= 'soilalbedo_dry'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Dry bare soil albedo')
CALL restget_p (rest_id, var_name, nbp_glo, 2, 1, kjit, .TRUE., soilalb_dry, "gather", nbp_glo, index_g)
var_name= 'soilalbedo_wet'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Wet bare soil albedo')
CALL restget_p (rest_id, var_name, nbp_glo, 2, 1, kjit, .TRUE., soilalb_wet, "gather", nbp_glo, index_g)
var_name= 'soilalbedo_moy'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Mean bare soil albedo')
CALL restget_p (rest_id, var_name, nbp_glo, 2, 1, kjit, .TRUE., soilalb_moy, "gather", nbp_glo, index_g)
!
IF ( MINVAL(soilalb_wet) .EQ. MAXVAL(soilalb_wet) .AND. MAXVAL(soilalb_wet) .EQ. val_exp .OR.&
& MINVAL(soilalb_dry) .EQ. MAXVAL(soilalb_dry) .AND. MAXVAL(soilalb_dry) .EQ. val_exp .OR.&
& MINVAL(soilalb_moy) .EQ. MAXVAL(soilalb_moy) .AND. MAXVAL(soilalb_moy) .EQ. val_exp) THEN
CALL condveg_soilalb(kjpindex, lalo, neighbours, resolution, contfrac, soilalb_dry,soilalb_wet)
WRITE(numout,*) '---> val_exp ', val_exp
WRITE(numout,*) '---> ALBEDO_wet VIS:', MINVAL(soilalb_wet(:,ivis)), MAXVAL(soilalb_wet(:,ivis))
WRITE(numout,*) '---> ALBEDO_wet NIR:', MINVAL(soilalb_wet(:,inir)), MAXVAL(soilalb_wet(:,inir))
WRITE(numout,*) '---> ALBEDO_dry VIS:', MINVAL(soilalb_dry(:,ivis)), MAXVAL(soilalb_dry(:,ivis))
WRITE(numout,*) '---> ALBEDO_dry NIR:', MINVAL(soilalb_dry(:,inir)), MAXVAL(soilalb_dry(:,inir))
WRITE(numout,*) '---> ALBEDO_moy VIS:', MINVAL(soilalb_moy(:,ivis)), MAXVAL(soilalb_moy(:,ivis))
WRITE(numout,*) '---> ALBEDO_moy NIR:', MINVAL(soilalb_moy(:,inir)), MAXVAL(soilalb_moy(:,inir))
ENDIF
!
ELSE
WRITE (numout,*) ' l_first_condveg false . we stop '
STOP 'condveg_init'
ENDIF
!! test de commentaires
IF (long_print) WRITE (numout,*) ' condveg_init done '
END SUBROUTINE condveg_init
!!
!!
SUBROUTINE condveg_clear ()
l_first_condveg=.TRUE.
IF (ALLOCATED (soilalb_dry)) DEALLOCATE (soilalb_dry)
IF (ALLOCATED(soilalb_wet)) DEALLOCATE (soilalb_wet)
! Ajout Nathalie
IF (ALLOCATED(soilalb_moy)) DEALLOCATE (soilalb_moy)
IF (ALLOCATED(albedo_snow)) DEALLOCATE (albedo_snow)
IF (ALLOCATED(albedo_glob)) DEALLOCATE (albedo_glob)
!
END SUBROUTINE condveg_clear
!! Algorithm:
!! - initialisation of local arry
!! - reads map for emissivity, albedo or roughness
!!
SUBROUTINE condveg_var_init (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio,&
& frac_bare, drysoil_frac, zlev, height, deadleaf_cover, emis, albedo, z0, roughheight)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
! input fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: veget !! Fraction of vegetation types
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio !! Fraction of continental ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: totfrac_nobio !! Total fraction of continental ice+lakes+...
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: frac_bare !! Bare fraction in each tile
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: drysoil_frac !! Dry soil heigth in meters
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: height !! Vegetation Height (m)
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: deadleaf_cover !! Fraction of soil covered by dead leaves
! output scalar
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: emis !! Emissivity
REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo !! Albedo, vis(1) and nir(2)
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: z0 !! Roughness
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: roughheight !! Effective height for roughness
!
! local declaration
INTEGER(i_std) :: ier !! Error code
INTEGER(i_std) :: jv
! initialisation of variables
!
!
!Config Key = IMPOSE_AZE
!Config Desc = Should the surface parameters be prescribed
!Config Def = n
!Config Help = This flag allows the user to impose the surface parameters
!Config (Albedo Roughness and Emissivity). It is espacially interesting for 0D
!Config simulations. On the globe it does not make too much sense as
!Config it imposes the same vegetation everywhere
!
impaze = .FALSE.
CALL getin_p('IMPOSE_AZE', impaze)
!!
!! calculs de emis
!!
IF ( impaze ) THEN
!
!Config Key = CONDVEG_EMIS
!Config Desc = Emissivity of the surface for LW radiation
!Config Def = 1.0
!Config If = IMPOSE_AZE
!Config Help = The surface emissivity used for compution the LE emission
!Config of the surface in a 0-dim version. Values range between
!Config 0.97 and 1.. The GCM uses 0.98.
!
emis_scal = un
CALL getin_p('CONDVEG_EMIS', emis_scal)
emis(:) = emis_scal
ELSE
! Some day it will be moisture dependent
emis_scal = un
emis(:) = emis_scal
ENDIF
!!
!! calculs de albedo
!!
!
IF ( impaze ) THEN
!
!Config Key = CONDVEG_ALBVIS
!Config Desc = SW visible albedo for the surface
!Config Def = 0.25
!Config If = IMPOSE_AZE
!Config Help = Surface albedo in visible wavelengths to be used
!Config on the point if a 0-dim version of SECHIBA is used.
!Config Look at the description of the forcing data for
!Config the correct value.
!
albedo_scal(ivis) = 0.25_r_std
CALL getin_p('CONDVEG_ALBVIS', albedo_scal(ivis))
albedo(:,ivis) = albedo_scal(ivis)
!
!Config Key = CONDVEG_ALBNIR
!Config Desc = SW near infrared albedo for the surface
!Config Def = 0.25
!Config If = IMPOSE_AZE
!Config Help = Surface albedo in near infrared wavelengths to be used
!Config on the point if a 0-dim version of SECHIBA is used.
!Config Look at the description of the forcing data for
!Config the correct value.
!
albedo_scal(inir) = 0.25_r_std
CALL getin_p('CONDVEG_ALBNIR', albedo_scal(inir))
albedo(:,inir) = albedo_scal(inir)
ELSE
!
CALL condveg_albcalc (kjpindex,deadleaf_cover,veget,frac_bare,drysoil_frac,albedo)
!
ENDIF
!!
!! calculs de z0
!!
!
!Config Key = Z0CDRAG_AVE
!Config Desc = Average method for z0
!Config Def = y
!Config Help = If this flag is set to true (y) then the neutral Cdrag
!Config is averaged instead of the log(z0). This should be
!Config the prefered option. We still wish to keep the other
!Config option so we can come back if needed. If this is
!Config desired then one should set Z0CDRAG_AVE=n
z0cdrag_ave = .TRUE.
CALL getin_p('Z0CDRAG_AVE', z0cdrag_ave)
!!
IF ( impaze ) THEN
!
!Config Key = CONDVEG_Z0
!Config Desc = Surface roughness (m)
!Config Def = 0.15
!Config If = IMPOSE_AZE
!Config Help = Surface rougness to be used on the point if a 0-dim version
!Config of SECHIBA is used. Look at the description of the forcing
!Config data for the correct value.
!
z0_scal = 0.15_r_std
CALL getin_p('CONDVEG_Z0', z0_scal)
z0(:) = z0_scal
!
!Config Key = ROUGHHEIGHT
!Config Desc = Height to be added to the height of the first level (m)
!Config Def = 0.0
!Config If = IMPOSE_AZE
!Config Help = ORCHIDEE assumes that the atmospheric level height is counted
!Config from the zero wind level. Thus to take into account the roughness
!Config of tall vegetation we need to correct this by a certain fraction
!Config of the vegetation height. This is called the roughness height in
!Config ORCHIDEE talk.
!
roughheight_scal = zero
CALL getin_p('ROUGHHEIGHT', roughheight_scal)
roughheight(:) = roughheight_scal
!
ELSE
!
IF ( z0cdrag_ave ) THEN
CALL condveg_z0cdrag(kjpindex, veget, frac_bare, frac_nobio, totfrac_nobio, zlev, &
& height, z0, roughheight)
ELSE
CALL condveg_z0logz(kjpindex, veget, frac_bare, frac_nobio, totfrac_nobio, height, &
& z0, roughheight)
ENDIF
!
ENDIF
!!
!!
IF (long_print) WRITE (numout,*) ' condveg_var_init done '
END SUBROUTINE condveg_var_init
!!
!! Algorithm:
!! - Simply update the emissivity, albedo and roughness fields
!!
SUBROUTINE condveg_var_update (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio, &
& frac_bare, drysoil_frac, zlev, height, deadleaf_cover, emis, albedo, z0, roughheight)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
! input fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: veget !! Fraction of vegetation types
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio !! Fraction of continental ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: totfrac_nobio !! Total fraction of continental ice+lakes+...
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: frac_bare !! Bare fraction in each tile
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: drysoil_frac !! Dry soil heigth in meters
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: height !! Vegetation Height (m)
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: deadleaf_cover !! Fraction of soil covered by dead leaves
! output scalar
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: emis !! Emissivity
REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo !! Albedo, vis(1) and nir(2)
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: z0 !! Roughness
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: roughheight !! Effective height for roughness
!
! local
INTEGER(i_std) :: ji, jv
!!
!! calculs de emis
!!
emis(:) = emis_scal
!!
!! calculs de albedo
!!
!
IF ( impaze ) THEN
!
albedo(:,ivis) = albedo_scal(ivis)
albedo(:,inir) = albedo_scal(inir)
!
ELSE
!
CALL condveg_albcalc (kjpindex,deadleaf_cover,veget,frac_bare,drysoil_frac,albedo)
!
ENDIF
!
!!
!! Calculs de la rugosite
!!
IF ( impaze ) THEN
DO ji = 1, kjpindex
z0(ji) = z0_scal
roughheight(ji) = roughheight_scal
ENDDO
ELSE
!
IF ( z0cdrag_ave ) THEN
CALL condveg_z0cdrag (kjpindex, veget, frac_bare, frac_nobio, totfrac_nobio, zlev, height, &
& z0, roughheight)
ELSE
CALL condveg_z0logz (kjpindex, veget, frac_bare, frac_nobio, totfrac_nobio, height, &
& z0, roughheight)
ENDIF
!
ENDIF
IF (long_print) WRITE (numout,*) ' condveg_var_update done '
END SUBROUTINE condveg_var_update
!! Algorithm:
!! - The snow albedo is updated by the snow within the mesh
!! This is done as a function of snow mass, snow age and vegetation type
!! The model is described in Chalita 1992
!!
SUBROUTINE condveg_snow (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio, &
snow, snow_age, snow_nobio, snow_nobio_age, albedo, albedo_snow, albedo_glob)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
! input fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation types
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio !! Fraction of continental ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: totfrac_nobio !! Total fraction of continental ice+lakes+ ...
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: snow !! Snow mass [Kg/m^2] in vegetation
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio !! Snow mass [Kg/m^2]on ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: snow_age !! Snow age
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio_age !! Snow age on ice, lakes, ...
! output scalar
! output fields
REAL(r_std),DIMENSION (kjpindex,2), INTENT (inout) :: albedo !! Albedo
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: albedo_snow !! Albedo de la neige
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: albedo_glob !! Mean albedo
!
! local declaration
INTEGER(i_std) :: ji, jv, jb !! Loop index
REAL(r_std), DIMENSION(kjpindex) :: frac_snow_veg !! Fraction of snow on vegetation
REAL(r_std), DIMENSION(kjpindex,nnobio) :: frac_snow_nobio !! Fraction of snow on ice, lakes, ...
REAL(r_std), DIMENSION(kjpindex) :: snowa_veg !! Total albedo of snow covered area on vegetation
REAL(r_std), DIMENSION(kjpindex,nnobio) :: snowa_nobio !! albedo of snow covered area on ice, lakes, ...
REAL(r_std), DIMENSION(kjpindex) :: fraction_veg !! total vegetation fraction
REAL(r_std), DIMENSION(kjpindex) :: agefunc_veg !! age dependency of snow albedo on vegetation
REAL(r_std), DIMENSION(kjpindex,nnobio) :: agefunc_nobio !! age dependency of snow albedo on ice, lakes, ..;
REAL(r_std) :: alb_nobio
!
DO ji = 1, kjpindex
albedo_snow(ji) = zero
albedo_glob(ji) = zero
ENDDO
IF (ABS(fixed_snow_albedo - undef_sechiba) .GT. EPSILON(undef_sechiba)) THEN
snowa_veg(:) = fixed_snow_albedo
snowa_nobio(:,:) = fixed_snow_albedo
ELSE
!
! calculate first age dependence
!
DO ji = 1, kjpindex
agefunc_veg(ji) = EXP(-snow_age(ji)/tcst_snowa)
ENDDO
!
!
DO jv = 1, nnobio
DO ji = 1, kjpindex
agefunc_nobio(ji,jv) = EXP(-snow_nobio_age(ji,jv)/tcst_snowa)
ENDDO
ENDDO
!
! snow albedo on vegetated surfaces
!
fraction_veg(:) = 1. - totfrac_nobio(:)
snowa_veg(:) = 0.
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( fraction_veg(ji) .GT. min_sechiba ) THEN
snowa_veg(ji) = snowa_veg(ji) + &
veget(ji,jv)/fraction_veg(ji) * ( snowa_ini(jv)+snowa_dec(jv)*agefunc_veg(ji) )
ENDIF
ENDDO
ENDDO
!
! snow albedo on other surfaces
!
DO jv = 1, nnobio
DO ji = 1, kjpindex
snowa_nobio(ji,jv) = ( snowa_ini(1) + snowa_dec(1) * agefunc_nobio(ji,jv) )
ENDDO
ENDDO
ENDIF
frac_snow_veg(:) = MIN(MAX(snow(:),zero)/(MAX(snow(:),zero)+snowcri_alb),un)
DO jv = 1, nnobio
frac_snow_nobio(:,jv) = MIN(MAX(snow_nobio(:,jv),zero)/(MAX(snow_nobio(:,jv),zero)+snowcri_alb),un)
ENDDO
DO jb = 1, 2
!
albedo(:,jb) = ( fraction_veg(:) ) * &
( (un-frac_snow_veg(:)) * albedo(:,jb) + &
( frac_snow_veg(:) ) * snowa_veg(:) )
albedo_snow(:) = albedo_snow(:) + (fraction_veg(:)) * (frac_snow_veg(:)) * snowa_veg(:)
!
DO jv = 1, nnobio
!
IF ( jv .EQ. iice ) THEN
alb_nobio = alb_ice(jb)
ELSE
WRITE(numout,*) 'jv=',jv
STOP 'DO NOT KNOW ALBEDO OF THIS SURFACE TYPE'
ENDIF
!
albedo(:,jb) = albedo(:,jb) + &
( frac_nobio(:,jv) ) * &
( (un-frac_snow_nobio(:,jv)) * alb_nobio + &
( frac_snow_nobio(:,jv) ) * snowa_nobio(:,jv) )
albedo_snow(:) = albedo_snow(:) + &
( frac_nobio(:,jv) ) * ( frac_snow_nobio(:,jv) ) * &
snowa_nobio(:,jv)
albedo_glob(:) = albedo_glob(:) + albedo(:,jb)
!
ENDDO
!
END DO
!
DO ji = 1, kjpindex
albedo_snow(ji) = (albedo_snow(ji))/2.
albedo_glob(ji) = (albedo_glob(ji))/2.
ENDDO
IF (long_print) WRITE (numout,*) ' condveg_snow done '
END SUBROUTINE condveg_snow
!
!
!
SUBROUTINE condveg_soilalb(nbpt, lalo, neighbours, resolution, contfrac, soilalb_dry,soilalb_wet)
!
!
! This subroutine should read the soil color maps from the Henderson-Sellers & Wilson database. This data
! is then interpolated to the models resolution and transformed into dry and wet albedos. We have chosen to
! do both these operations at the same time as one can average the albedo but not the color types.
!
! We make the assumption in this code that the grid of the data is regular and that it covers the globe.
! For the model grid we base the calculation of the borders of the grid on the resolution.
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box.
REAL(r_std), INTENT(inout) :: soilalb_dry(nbpt,2) ! albedo for the dry bare soil
REAL(r_std), INTENT(inout) :: soilalb_wet(nbpt,2) ! albedo for the wet bare soil
!
!
! 0.3 LOCAL
!
INTEGER(i_std) :: nbvmax
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt, ilf, lastjp, nbexp
REAL(r_std) :: lev(1), date, dt, coslat, sgn
INTEGER(i_std) :: itau(1)
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel, lon_rel, soilcol
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
CHARACTER(LEN=30) :: callsign
!
! The correspondance table for the soil color numbers and their albedo
!
INTEGER(i_std), PARAMETER :: classnb = 9
!
REAL(r_std), DIMENSION(classnb) :: vis_dry = (/0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.27/)
REAL(r_std), DIMENSION(classnb) :: nir_dry = (/0.48, 0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20, 0.55/)
REAL(r_std), DIMENSION(classnb) :: vis_wet = (/0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.15/)
REAL(r_std), DIMENSION(classnb) :: nir_wet = (/0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.31/)
!
! Nathalie, introduction d'un albedo moyen, VIS+NIR
! Les valeurs suivantes correspondent a la moyenne des valeurs initiales
! REAL(stnd), DIMENSION(classnb) :: albsoil_vis = (/0.18, 0.165, 0.15, 0.135, 0.12, 0.105, 0.09, 0.075, 0.21/)
! REAL(stnd), DIMENSION(classnb) :: albsoil_nir = (/0.36, 0.33, 0.30, 0.27, 0.24, 0.21, 0.18, 0.15, 0.43/)
! les valeurs retenues accentuent le contraste entre equateur et Sahara.
! On diminue aussi l'albedo des deserts (tous sauf Sahara)
REAL(r_std), DIMENSION(classnb) :: albsoil_vis = (/0.18, 0.16, 0.16, 0.15, 0.12, 0.105, 0.09, 0.075, 0.25/)
REAL(r_std), DIMENSION(classnb) :: albsoil_nir = (/0.36, 0.34, 0.34, 0.33, 0.30, 0.25, 0.20, 0.15, 0.45/)
!
LOGICAL :: ok_interpol = .FALSE. ! optionnal return of aggregate_2d
!
INTEGER :: ALLOC_ERR
!
!
! Needs to be a configurable variable
!
!
!Config Key = SOILALB_FILE
!Config Desc = Name of file from which the bare soil albedo
!Config Def = ../surfmap/soils_param.nc
!Config If = !IMPOSE_AZE
!Config Help = The name of the file to be opened to read the soil types from
!Config which we derive then the bare soil albedos. This file is 1x1
!Config deg and based on the soil colors defined by Wilson and Henderson-Seller.
!
filename = '../surfmap/soils_param.nc'
CALL getin_p('SOILALB_FILE',filename)
!
IF (is_root_prc) CALL flininfo(filename,iml, jml, lml, tml, fid)
CALL bcast(iml)
CALL bcast(jml)
CALL bcast(lml)
CALL bcast(tml)
!
! soils_param.nc file is 1° soit texture file.
!
ALLOC_ERR=-1
ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
PRINT *,"ERROR IN ALLOCATION of lat_rel : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
PRINT *,"ERROR IN ALLOCATION of lon_rel : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
PRINT *,"ERROR IN ALLOCATION of mask : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(soilcol(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
PRINT *,"ERROR IN ALLOCATION of soiltext : ",ALLOC_ERR
STOP
ENDIF
!
IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
CALL bcast(lon_rel)
CALL bcast(lat_rel)
CALL bcast(lev)
CALL bcast(itau)
CALL bcast(date)
CALL bcast(dt)
!
IF (is_root_prc) CALL flinget(fid, 'soilcolor', iml, jml, lml, tml, 1, 1, soilcol)
CALL bcast(soilcol)
!
IF (is_root_prc) CALL flinclo(fid)
!
! Mask of permitted variables.
!
mask(:,:) = zero
DO ip=1,iml
DO jp=1,jml
IF (soilcol(ip,jp) > min_sechiba) THEN
mask(ip,jp) = un
ENDIF
ENDDO
ENDDO
!
nbvmax = 220
!
callsign = 'Soil color map'
!
DO WHILE ( .NOT. ok_interpol )
WRITE(numout,*) "Projection arrays for ",callsign," : "
WRITE(numout,*) "nbvmax = ",nbvmax
!
ALLOC_ERR=-1
ALLOCATE(sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
PRINT *,"ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
STOP
ENDIF
sub_area(:,:)=zero
ALLOC_ERR=-1
ALLOCATE(sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
PRINT *,"ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
STOP
ENDIF
sub_index(:,:,:)=0
!
CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
& iml, jml, lon_rel, lat_rel, mask, callsign, &
& nbvmax, sub_index, sub_area, ok_interpol)
!
IF ( .NOT. ok_interpol ) THEN
DEALLOCATE(sub_area)
DEALLOCATE(sub_index)
ENDIF
!
nbvmax = nbvmax * 2
ENDDO
!
nbexp = 0
!
! Check that we found some points
!
soilalb_dry(:,:) = zero
soilalb_wet(:,:) = zero
! Ajout Nathalie
soilalb_moy(:,:) = zero
!
DO ib=1,nbpt
!
! GO through the point we have found
!
!
fopt = COUNT(sub_area(ib,:) > zero)
!
IF ( fopt .EQ. 0) THEN
nbexp = nbexp + 1
soilalb_dry(ib,ivis) = (SUM(vis_dry)/classnb + SUM(vis_wet)/classnb)/deux
soilalb_dry(ib,inir) = (SUM(nir_dry)/classnb + SUM(nir_wet)/classnb)/deux
soilalb_wet(ib,ivis) = (SUM(vis_dry)/classnb + SUM(vis_wet)/classnb)/deux
soilalb_wet(ib,inir) = (SUM(nir_dry)/classnb + SUM(nir_wet)/classnb)/deux
! Ajout Nathalie
soilalb_moy(ib,ivis) = SUM(albsoil_vis)/classnb
soilalb_moy(ib,inir) = SUM(albsoil_nir)/classnb
ELSE
sgn = zero
!
! Compute the average bare soil albedo parameters
!
DO ilf = 1,fopt
!
ip = sub_index(ib,ilf,1)
jp = sub_index(ib,ilf,2)
!
IF ( NINT(soilcol(ip,jp)) .LE. classnb) THEN
soilalb_dry(ib,ivis) = soilalb_dry(ib,ivis) + vis_dry(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
soilalb_dry(ib,inir) = soilalb_dry(ib,inir) + nir_dry(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
soilalb_wet(ib,ivis) = soilalb_wet(ib,ivis) + vis_wet(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
soilalb_wet(ib,inir) = soilalb_wet(ib,inir) + nir_wet(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
! Ajout Nathalie
soilalb_moy(ib,ivis) = soilalb_moy(ib,ivis) + albsoil_vis(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
soilalb_moy(ib,inir) = soilalb_moy(ib,inir) + albsoil_nir(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
sgn = sgn + sub_area(ib,ilf)
ELSE
WRITE(numout,*) 'The file contains a soil color class which is incompatible with this program'
STOP
ENDIF
!
ENDDO
!
! Normalize the surface
!
IF ( sgn .LT. min_sechiba) THEN
nbexp = nbexp + 1
soilalb_dry(ib,ivis) = (SUM(vis_dry)/classnb + SUM(vis_wet)/classnb)/deux
soilalb_dry(ib,inir) = (SUM(nir_dry)/classnb + SUM(nir_wet)/classnb)/deux
soilalb_wet(ib,ivis) = (SUM(vis_dry)/classnb + SUM(vis_wet)/classnb)/deux
soilalb_wet(ib,inir) = (SUM(nir_dry)/classnb + SUM(nir_wet)/classnb)/deux
! Ajout Nathalie
soilalb_moy(ib,ivis) = SUM(albsoil_vis)/classnb
soilalb_moy(ib,inir) = SUM(albsoil_nir)/classnb
ELSE
soilalb_dry(ib,ivis) = soilalb_dry(ib,ivis)/sgn
soilalb_dry(ib,inir) = soilalb_dry(ib,inir)/sgn
soilalb_wet(ib,ivis) = soilalb_wet(ib,ivis)/sgn
soilalb_wet(ib,inir) = soilalb_wet(ib,inir)/sgn
! Ajout Nathalie
soilalb_moy(ib,ivis) = soilalb_moy(ib,ivis)/sgn
soilalb_moy(ib,inir) = soilalb_moy(ib,inir)/sgn
ENDIF
!
ENDIF
!
ENDDO
!
IF ( nbexp .GT. 0 ) THEN
WRITE(numout,*) 'CONDVEG_soilalb : The interpolation of the bare soil albedo had ', nbexp
WRITE(numout,*) 'CONDVEG_soilalb : points without data. This are either coastal points or'
WRITE(numout,*) 'CONDVEG_soilalb : ice covered land.'
WRITE(numout,*) 'CONDVEG_soilalb : The problem was solved by using the average of all soils'
WRITE(numout,*) 'CONDVEG_soilalb : in dry and wet conditions'
ENDIF
!
DEALLOCATE (lat_rel)
DEALLOCATE (lon_rel)
DEALLOCATE (mask)
DEALLOCATE (sub_index)
DEALLOCATE (sub_area)
DEALLOCATE (soilcol)
!
!
RETURN
!
END SUBROUTINE condveg_soilalb
!
!
!
SUBROUTINE condveg_z0logz (kjpindex, veget, frac_bare, frac_nobio, totfrac_nobio, height, &
& z0, roughheight)
!
! 0. Declarations
!
! 0.1 Input
INTEGER(i_std), INTENT(in) :: kjpindex
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: veget
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: frac_bare
REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(in) :: frac_nobio
REAL(r_std), DIMENSION(kjpindex), INTENT(in) :: totfrac_nobio
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: height
! 0.2 Output
REAL(r_std), DIMENSION(kjpindex), INTENT(out) :: z0
REAL(r_std), DIMENSION(kjpindex), INTENT(out) :: roughheight
! 0.3 Local
INTEGER(i_std) :: jv
REAL(r_std), DIMENSION(kjpindex) :: sumveg, ave_height
REAL(r_std), DIMENSION(kjpindex) :: d_veg, zhdispl, tot_frac_bare
REAL(r_std) :: z0_nobio
tot_frac_bare(:) = veget(:,1)
DO jv = 2, nvm
tot_frac_bare(:) = tot_frac_bare(:) + veget(:,jv) * frac_bare(:,jv)
ENDDO
!
z0(:) = tot_frac_bare(:) * LOG(z0_bare)
sumveg(:) = tot_frac_bare(:)
ave_height(:) = zero
!
DO jv = 2, nvm
!
IF ( is_tree(jv) ) THEN
! tree trunks influence the atmosphere even when there are no leaves
d_veg(:) = veget(:,jv)
ELSE
! grasses only have an influence if they are really there!
d_veg(:) = veget(:,jv) * (un - frac_bare(:,jv))
ENDIF
!
z0(:) = z0(:) + d_veg(:) * &
LOG( MAX(height(:,jv)*z0_over_height,z0_bare) )
sumveg(:) = sumveg(:) + d_veg(:)
!
ave_height(:) = ave_height(:) + veget(:,jv)*height(:,jv)
!
ENDDO
!
WHERE ( sumveg(:) > zero ) z0(:) = z0(:) / sumveg(:)
!
z0(:) = (un - totfrac_nobio(:)) * z0(:)
!
DO jv = 1, nnobio
!
IF ( jv .EQ. iice ) THEN
z0_nobio = z0_ice
ELSE
WRITE(numout,*) 'jv=',jv
STOP 'DO NOT KNOW ROUGHNESS OF THIS SURFACE TYPE'
ENDIF
!
z0(:) = z0(:) + frac_nobio(:,jv) * LOG(z0_nobio)
!
ENDDO
!
z0(:) = EXP( z0(:) )
!
! Temporarily we compute the zero plane displacement height
!
zhdispl(:) = ave_height(:) * height_displacement
!
! In order to get a variable independent of the height of the
! vegetation we compute what we call the effective roughness height.
! This is the height over which the roughness acts. It combines the
! zero plane displacement height and the vegetation height.
!
roughheight(:) = ave_height(:) - zhdispl(:)
!
END SUBROUTINE condveg_z0logz
!
!
!
SUBROUTINE condveg_z0cdrag (kjpindex,veget,frac_bare,frac_nobio,totfrac_nobio,zlev, height, &
& z0, roughheight)
!
! 0. Declarations
!
! 0.1 Input
INTEGER(i_std), INTENT(in) :: kjpindex
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: veget
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: frac_bare
REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(in) :: frac_nobio
REAL(r_std), DIMENSION(kjpindex), INTENT(in) :: totfrac_nobio
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: height
! 0.2 Output
REAL(r_std), DIMENSION(kjpindex), INTENT(out) :: z0
REAL(r_std), DIMENSION(kjpindex), INTENT(out) :: roughheight
! 0.3 Local
INTEGER(i_std) :: jv
REAL(r_std), DIMENSION(kjpindex) :: sumveg, ztmp, ave_height
REAL(r_std), DIMENSION(kjpindex) :: d_veg, zhdispl, tot_frac_bare
REAL(r_std) :: z0_nobio
!
! The grid average z0 is computed by averaging the neutral drag coefficients.
! This is pretty straight forward except for the reference level which needs
! to be chosen.
!
! We need a reference lever high enough above the canopy else we get into
! singularities of the LOG.
!
tot_frac_bare(:) = veget(:,1)
DO jv = 2, nvm
tot_frac_bare(:) = tot_frac_bare(:) + veget(:,jv) * frac_bare(:,jv)
ENDDO
!
ztmp(:) = MAX(10., zlev(:))
!
z0(:) = tot_frac_bare(:) * (ct_karman/LOG(ztmp(:)/z0_bare))**2
sumveg(:) = tot_frac_bare(:)
ave_height(:) = zero
!
DO jv = 2, nvm
!
IF ( is_tree(jv) ) THEN
! tree trunks influence the atmosphere even when there are no leaves
d_veg(:) = veget(:,jv)
ELSE
! grasses only have an influence if they are really there!
d_veg(:) = veget(:,jv) * (un - frac_bare(:,jv))
ENDIF
!
z0(:) = z0(:) + d_veg(:) * (ct_karman/LOG(ztmp(:)/MAX(height(:,jv)*z0_over_height,z0_bare)))**2
sumveg(:) = sumveg(:) + d_veg(:)
!
ave_height(:) = ave_height(:) + veget(:,jv)*height(:,jv)
!
ENDDO
!
WHERE ( sumveg(:) .GT. 0.0 ) z0(:) = z0(:) / sumveg(:)
!
z0(:) = (un - totfrac_nobio(:)) * z0(:)
!
DO jv = 1, nnobio
!
IF ( jv .EQ. iice ) THEN
z0_nobio = z0_ice
ELSE
WRITE(numout,*) 'jv=',jv
STOP 'DO NOT KNOW ROUGHNESS OF THIS SURFACE TYPE'
ENDIF
!
z0(:) = z0(:) + frac_nobio(:,jv) * (ct_karman/LOG(ztmp(:)/z0_nobio))**2
!
ENDDO
!
z0(:) = ztmp(:) / EXP(ct_karman/SQRT(z0(:)))
!
! Temporarily we compute the zero plane displacement height
!
zhdispl(:) = ave_height(:) * height_displacement
!
! In order to get a variable independent of the height of the
! vegetation we compute what we call the effective roughness height.
! This is the height over which the roughness acts. It combines the
! zero plane displacement height and the vegetation height.
!
roughheight(:) = ave_height(:) - zhdispl(:)
!
END SUBROUTINE condveg_z0cdrag
!
!
!
SUBROUTINE condveg_albcalc (kjpindex,deadleaf_cover,veget,frac_bare,drysoil_frac,albedo)
!
! 0. Declarations
!
! 0.1 Input
INTEGER(i_std), INTENT(in) :: kjpindex
REAL(r_std), DIMENSION(kjpindex), INTENT(in) :: deadleaf_cover
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: veget
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: frac_bare
REAL(r_std), DIMENSION(kjpindex), INTENT(in) :: drysoil_frac
! 0.2 Output
REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo !! Albedo, vis(1) and nir(2)
! 0.3 Local
REAL(r_std),DIMENSION (kjpindex) :: alb_bare
REAL(r_std),DIMENSION (kjpindex) :: tot_frac_bare
REAL(r_std),DIMENSION (nvm,2) :: alb_leaf_tmp
INTEGER(i_std) :: ks, jv
!
alb_leaf_tmp(:,1) = alb_leaf(1:nvm)
alb_leaf_tmp(:,2) = alb_leaf(nvm+1:2*nvm)
tot_frac_bare(:) = veget(:,1)
DO jv = 2, nvm
tot_frac_bare(:) = tot_frac_bare(:) + veget(:,jv) * frac_bare(:,jv)
ENDDO
!
!
DO ks = 1, 2
!
IF ( alb_bare_model ) THEN
alb_bare(:) = soilalb_wet(:,ks) + drysoil_frac(:) * (soilalb_dry(:,ks) - soilalb_wet(:,ks))
ELSE
! Nouvelle formulation Nathalie, sans dependance en drysoil_frac.
alb_bare(:) = soilalb_moy(:,ks)
ENDIF
!
! Correction Nathalie le 12 Avril 2006 - suppression de la dependance en deadleaf_cover
!albedo(:,ks) = tot_frac_bare(:) * ( (1.-deadleaf_cover(:))*alb_bare(:) + &
! deadleaf_cover(:)*alb_deadleaf(ks) )
albedo(:,ks) = tot_frac_bare(:) * alb_bare(:)
! vegetation
DO jv = 2, nvm
albedo(:,ks) = albedo(:,ks) + veget(:,jv)*(un-frac_bare(:,jv))*alb_leaf_tmp(jv,ks)
ENDDO
!
ENDDO
END SUBROUTINE condveg_albcalc
END MODULE condveg
ORCHIDEE/src_sechiba/diffuco.f90 0000754 0103600 0005670 00000220727 11164403473 016143 0 ustar acamlmd lmdjus !!
!! This module computes diffusion coefficients for continental points.
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.29 $, $Date: 2007/06/12 19:19:59 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/diffuco.f90,v 1.29 2007/06/12 19:19:59 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE diffuco
! modules used :
USE constantes
USE constantes_veg
USE sechiba_io
USE ioipsl
USE constantes_co2
USE parallel
! USE WRITE_FIELD_p
IMPLICIT NONE
! public routines :
! diffuco_main only
PRIVATE
PUBLIC :: diffuco_main,diffuco_clear
!
! variables used inside diffuco module : declaration and initialisation
!
INTEGER(i_std), PARAMETER :: nlai = 20
LOGICAL, SAVE :: l_first_diffuco = .TRUE. !! Initialisation has to be done one time
CHARACTER(LEN=80) :: var_name !! To store variables names for I/O
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: leaf_ci !! intercellular CO2 concentration (ppm)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: raero !! Aerodynamic resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: qsatt !! Surface saturated humidity
!! Nathalie le 28 mars 2006 - sur proposition de Fred Hourdin, ajout
!! d'un potentiometre pour regler la resistance de la vegetation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: rveg_pft
! MM
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: wind !! Wind norm
CONTAINS
!!
!! Main routine for *diffuco* module.
!! - called only one time for initialisation
!! - called every time step
!! - called one more time at last time step for writing _restart_ file
!!
!! Algorithm:
!! - call diffuco_aero for aerodynamic transfer coeficient
!! - call diffuco_snow for partial beta coefficient : sublimation
!! - call diffuco_inter for partial beta coefficient : interception for each type of vegetation
!! - call diffuco_bare for partial beta coefficient : bare soil
!! - call diffuco_trans for partial beta coefficient : transpiration for each type of vegetation
!! - call diffuco_comb for alpha and beta coefficient
!!
!! @call diffuco_aero
!! @call diffuco_snow
!! @call diffuco_inter
!! @call diffuco_bare
!! @call diffuco_trans
!! @call diffuco_comb
!!
SUBROUTINE diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, u, v, &
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! & zlev, z0, roughheight, temp_sol, temp_air, rau, q_cdrag, qsurf, qair, pb, &
& zlev, z0, roughheight, temp_sol, temp_air, rau, q_cdrag, qsurf, qair, q2m, t2m, pb, &
& rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
& swnet, swdown, ccanopy, humrel, frac_bare, veget, lai, qsintveg, qsintmax, assim_param, &
& vbeta , valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, rstruct, cimean, rest_id, hist_id, hist2_id)
! interface description:
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std),INTENT (in) :: rest_id !! _Restart_ file identifier
INTEGER(i_std),INTENT (in) :: hist_id !! _History_ file identifier
INTEGER(i_std),INTENT (in) :: hist2_id !! _History_ file 2 identifier
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for restart file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for restart file to write
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in) :: indexveg !! Indeces of the points on the 3D map
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: z0 !! Surface roughness
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: roughheight !! Effective height for roughness
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol !! Skin temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Lowest level temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qsurf !! near surface specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
! Ajout Nathalie - declaration q2m
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q2m !! 2m specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: t2m !! 2m air temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: snow !! Snow mass
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: flood_frac !! Fraction of floodplains
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: flood_res !! Reservoir in floodplains (estimation to avoid over-evaporation)
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Surface level pressure
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rsol !! Bare soil evaporation resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evap_bare_lim !! Beta factor for bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot !! Soil Potential Evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot_corr !! Soil Potential Evaporation
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: frac_nobio !! Fraction of ice,lakes,cities,...
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: snow_nobio !! Snow on ice,lakes,cities,...
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: totfrac_nobio !! Total fraction of ice+lakes+cities+...
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swdown !! Down-welling surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: ccanopy !! CO2 concentration inside the canopy
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: frac_bare !! Fraction of bare soil per vegetation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: lai !! Leaf area index
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintveg !! Water on vegetation due to interception
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintmax !! Maximum water on vegetation for interception
REAL(r_std),DIMENSION (kjpindex,nvm,npco2), INTENT (in):: assim_param !! min+max+opt temps, vcmax, vjmax for photosynthesis
! modified fields
REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (inout) :: humrel !! Moisture stress
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: q_cdrag !! Surface drag
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vbeta !! Total beta coefficient
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: valpha !! Total alpha coefficient
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vbeta1 !! Beta for sublimation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vbeta4 !! Beta for bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vbeta5 !! Beta for floodplains
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbetaco2 !! STOMATE: Beta for CO2
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta2 !! Beta for interception loss
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta3 !! Beta for transpiration
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: rveget !! Surface resistance for the vegetatuon
! MG
REAL(r_std) ,DIMENSION (kjpindex,nvm), INTENT (out) :: rstruct !! Structural resistance for the vegetation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: cimean !! STOMATE: mean intercellular ci (see enerbil)
! Local
! AJout Nathalie - Juin 2006
REAL(r_std),DIMENSION (kjpindex,nvm) :: vbeta23 !! Beta for fraction of wetted foliage that will transpire
LOGICAL, SAVE :: ldq_cdrag_from_gcm !! Set to .TRUE. if you want q_cdrag coming from GCM
INTEGER(i_std) :: ilai
CHARACTER(LEN=4) :: laistring
! do initialisation if needed
IF (l_first_diffuco) THEN
!Config Key = CDRAG_FROM_GCM
!Config Desc = Keep cdrag coefficient from gcm.
!Config Def = TRUE if q_cdrag on initialization is non zero
!Config Help = Set to .TRUE. if you want q_cdrag coming from GCM.
!Congig Keep cdrag coefficient from gcm for latent and sensible heat fluxes.
IF ( ABS(MAXVAL(q_cdrag)) .LE. EPSILON(q_cdrag)) THEN
ldq_cdrag_from_gcm = .FALSE.
ELSE
ldq_cdrag_from_gcm = .TRUE.
ENDIF
!MM q_cdrag is always 0 on initialization ??
CALL getin_p('CDRAG_from_GCM', ldq_cdrag_from_gcm)
WRITE(numout,*) "ldq_cdrag_from_gcm = ",ldq_cdrag_from_gcm
IF (long_print) WRITE (numout,*) ' call diffuco_init '
! If cdrag is
CALL diffuco_init(kjit, ldrestart_read, kjpindex, index, rest_id, q_cdrag, rstruct)
RETURN
ENDIF
!
! prepares restart file for the next simulation
!
IF (ldrestart_write) THEN
IF (long_print) WRITE (numout,*) ' we have to complete restart file with DIFFUCO variables '
var_name= 'rstruct'
CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, rstruct, 'scatter', nbp_glo, index_g)
! the following variable is written only if CO2 was calculated
IF ( control%ok_co2 ) THEN
DO ilai = 1, nlai
! variable name is somewhat complicated as ioipsl does not allow 3d variables for the moment...
write(laistring,'(i4)') ilai
laistring=ADJUSTL(laistring)
var_name='leaf_ci_'//laistring(1:LEN_TRIM(laistring))
CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, leaf_ci(:,:,ilai), 'scatter', nbp_glo, index_g)
ENDDO
ENDIF
RETURN
END IF
! MM
wind(:) = SQRT (u(:)*u(:) + v(:)*v(:))
!
! calculs des differents coefficients
!
IF (.NOT.ldq_cdrag_from_gcm) THEN
CALL diffuco_aero (kjpindex, kjit, u, v, zlev, z0, roughheight, temp_sol, temp_air, &
& qsurf, qair, q_cdrag)
ENDIF
CALL diffuco_raerod (kjpindex, u, v, q_cdrag, raero)
!
! An estimation of the satturated humidity at the surface
!
CALL qsatcalc (kjpindex, temp_sol, pb, qsatt)
!
! beta coefficient for sublimation
!
CALL diffuco_snow (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, &
& snow, frac_nobio, totfrac_nobio, snow_nobio, vbeta1)
!
! beta coefficient for floodplains (surface reservoir)
!
CALL diffuco_flood (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, evapot, evapot_corr, &
& flood_frac, flood_res, vbeta5)
!
! beta coefficient for interception
!
! Correction Nathalie - Juin 2006 - introduction d'un terme vbeta23
!CALL diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, veget, &
! & qsintveg, qsintmax, rstruct, vbeta2)
CALL diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, veget, &
& qsintveg, qsintmax, rstruct, vbeta2, vbeta23)
!
! beta coefficient for transpiration
!
IF ( control%ok_co2 ) THEN
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! Correction Nathalie - Juin 2006 - introduction d'un terme vbeta23
!CALL diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
! assim_param, ccanopy, &
! veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2)
CALL diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_air, pb, qair, q2m, t2m, rau, u, v, q_cdrag, humrel, &
assim_param, ccanopy, &
veget, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2, vbeta23)
ELSE
! Correction Nathalie - Juin 2006 - introduction d'un terme vbeta23
!CALL diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
! veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2)
CALL diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
veget, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2, vbeta23)
ENDIF
!
! beta coefficient for bare soil
!
CALL diffuco_bare (kjpindex, dtradia, u, v, q_cdrag, rsol, evap_bare_lim, evapot, humrel, &
& frac_bare, veget, vbeta2, vbeta3, vbeta4)
!
! combination of coefficient : alpha and beta coefficient
!
! Ajout qsintmax dans les arguments de la routine.... Nathalie / le 13-03-2006
CALL diffuco_comb (kjpindex, dtradia, humrel, rau, u, v, q_cdrag, pb, qair, temp_sol, temp_air, snow, &
& veget, frac_bare, vbeta1, vbeta2, vbeta3, vbeta4, valpha, vbeta, qsintmax)
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'raero', kjit, raero, kjpindex, index)
! Ajouts Nathalie - novembre 2006
CALL histwrite(hist_id, 'cdrag', kjit, q_cdrag, kjpindex, index)
CALL histwrite(hist_id, 'Wind', kjit, wind, kjpindex, index)
! Fin ajouts Nathalie
IF ( hist2_id > 0 ) THEN
CALL histwrite(hist2_id, 'raero', kjit, raero, kjpindex, index)
CALL histwrite(hist2_id, 'cdrag', kjit, q_cdrag, kjpindex, index)
CALL histwrite(hist2_id, 'Wind', kjit, wind, kjpindex, index)
ENDIF
ELSE
ENDIF
!
!
IF (long_print) WRITE (numout,*) ' diffuco_main done '
END SUBROUTINE diffuco_main
!! Algorithm:
!! - dynamic allocation for local array
!!
! SUBROUTINE diffuco_init(kjit, ldrestart_read, kjpindex, index, rest_id)
!MG
SUBROUTINE diffuco_init(kjit, ldrestart_read, kjpindex, index, rest_id, q_cdrag, rstruct)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjit !! Time step number
LOGICAL,INTENT (in) :: ldrestart_read !! Logical for restart file to read
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in):: index !! Indeces of the points on the map
INTEGER(i_std), INTENT (in) :: rest_id !! _Restart_ file identifier
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: q_cdrag !! Surface drag
!MG
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: rstruct !! STOMATE: architectural resistance
! input fields
! output scalar
! output fields
! local declaration
INTEGER(i_std) :: ier, jv
INTEGER(i_std) :: ilai
CHARACTER(LEN=4) :: laistring
!
! initialisation
!
IF (l_first_diffuco) THEN
l_first_diffuco=.FALSE.
ELSE
WRITE (numout,*) ' l_first_diffuco false . we stop '
STOP 'diffuco_init'
ENDIF
! allocate only if CO2 is calculated
IF ( control%ok_co2 ) THEN
ALLOCATE (leaf_ci(kjpindex,nvm,nlai),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in leaf_ci allocation. We stop. We need kjpindex*nvm*nlai words = ',&
kjpindex*nvm*nlai
STOP 'diffuco_init'
END IF
ENDIF
ALLOCATE (raero(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in raero allocation. We stop. We need kjpindex x nvm words = ', kjpindex
STOP 'diffuco_init'
END IF
ALLOCATE (qsatt(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsatt allocation. We stop. We need kjpindex x nvm words = ', kjpindex
STOP 'diffuco_init'
END IF
ALLOCATE (wind(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in wind allocation. We stop. We need kjpindex x nvm words = ', kjpindex
STOP 'diffuco_init'
END IF
IF (ldrestart_read) THEN
IF (long_print) WRITE (numout,*) ' we have to read a restart file for DIFFUCO variables'
var_name='rstruct' ;
CALL ioconf_setatt('UNITS', 's/m')
CALL ioconf_setatt('LONG_NAME','Structural resistance')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., rstruct, "gather", nbp_glo, index_g)
!
IF ( MINVAL(rstruct) .EQ. MAXVAL(rstruct) .AND. MAXVAL(rstruct) .EQ. val_exp ) THEN
!
DO jv = 1, nvm
rstruct(:,jv) = rstruct_const(jv)
ENDDO
ENDIF
! the following variable is read only if CO2 is calculated
IF ( control%ok_co2 ) THEN
CALL ioconf_setatt('UNITS', 'ppm')
CALL ioconf_setatt('LONG_NAME','Leaf CO2')
DO ilai = 1, nlai
! variable name is somewhat complicated as ioipsl does not allow 3d variables for the moment...
write(laistring,'(i4)') ilai
laistring=ADJUSTL(laistring)
var_name='leaf_ci_'//laistring(1:LEN_TRIM(laistring))
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE.,leaf_ci(:,:,ilai), "gather", nbp_glo, index_g)
ENDDO
!
!Config Key = DIFFUCO_LEAFCI
!Config Desc = Initial leaf CO2 level if not found in restart
!Config Def = 233.
!Config Help = The initial value of leaf_ci if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (leaf_ci, val_exp,'DIFFUCO_LEAFCI', 233._r_std)
ENDIF
ENDIF
!
! Ajouts Nathalie - le 28 Mars 2006 - sur conseils Fred Hourdin
!
ALLOCATE (rveg_pft(nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) &
' error in rveg_pft allocation. We stop. We need nvm words = ', nvm
STOP 'diffuco_init'
END IF
!
!Config Key = RVEG_PFT
!Config Desc = Artificial parameter to increase or decrease canopy resistance.
!Config Def = 1.
!Config Help = This parameter is set by PFT.
rveg_pft(:) = 1.
CALL getin_p('RVEG_PFT', rveg_pft)
WRITE(numout,*) 'DANS DIFFUCO_INIT , RVEG_PFT=',rveg_pft
IF (long_print) WRITE (numout,*) ' diffuco_init done '
END SUBROUTINE diffuco_init
SUBROUTINE diffuco_clear()
l_first_diffuco=.TRUE.
IF (ALLOCATED (leaf_ci)) DEALLOCATE (leaf_ci)
IF (ALLOCATED (raero)) DEALLOCATE (raero)
IF (ALLOCATED (rveg_pft)) DEALLOCATE (rveg_pft)
END SUBROUTINE diffuco_clear
!! This routine computes aerothermic coefficient if required
!! see logical *ldq_cdrag_from_gcm*
!!
SUBROUTINE diffuco_aero (kjpindex, kjit, u, v, zlev, z0, roughheight, temp_sol, temp_air, &
& qsurf, qair, q_cdrag)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex, kjit !! Domain size
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: z0 !! Surface roughness
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: roughheight !! Effective roughness height
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol !! Skin temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Lowest level temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qsurf !! near surface specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
! output scalar
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: q_cdrag !! Surface drag
! local declaration
INTEGER(i_std) :: ji, jv
REAL(r_std) :: speed, zg, zdphi, ztvd, ztvs, zdu2
REAL(r_std) :: zri, cd_neut, zscf, cd_tmp
! initialisation
! test if we have to work with q_cdrag or to calcul it
DO ji=1,kjpindex
!
! 1. computes wind speed
!
speed = wind(ji)
!
! 2. computes geopotentiel
!
zg = zlev(ji) * cte_grav
zdphi = zg/cp_air
!
! 3. virtual air temperature at the surface
!
ztvd = (temp_air(ji) + zdphi / (un + rvtmp2 * qair(ji))) * (un + retv * qair(ji))
!
! 4. virtual surface temperature
!
ztvs = temp_sol(ji) * (un + retv * qsurf(ji))
!
! 5. squared wind shear
!
zdu2 = MAX(cepdu2,speed**2)
!
! 6. Richardson number
!
zri = zg * (ztvd - ztvs) / (zdu2 * ztvd)
zri = MAX(MIN(zri,5.),-5.)
!
! 7. Computing the drag coefficient
! We add the add the height of the vegetation to the level height to take into account
! that the level seen by the vegetation is actually the top of the vegetation. Then we
! we can subtract the displacement height.
!
cd_neut = (ct_karman / LOG( (zlev(ji) + roughheight(ji)) / z0(ji) )) ** 2
!
! 7.1 Stable case
!
IF (zri .GE. zero) THEN
zscf = SQRT(un + cd * ABS(zri))
cd_tmp=cd_neut/(un + trois * cb * zri * zscf)
ELSE
!
! 7.2 Unstable case
!
zscf = un / (un + trois * cb * cc * cd_neut * SQRT(ABS(zri) * &
& ((zlev(ji) + roughheight(ji)) / z0(ji))))
cd_tmp=cd_neut * (un - trois * cb * zri * zscf)
ENDIF
! dont let it go to low else the surface uncouples
q_cdrag(ji) = MAX(cd_tmp, 1.e-4/MAX(speed,min_wind))
!!
!! In some situations it might be useful to give an upper limit on the cdrag as well.
!! The line here should then be uncommented.
!! q_cdrag(ji) = MIN(q_cdrag(ji), 0.5/MAX(speed,min_wind))
END DO
IF (long_print) WRITE (numout,*) ' not ldqcdrag_from_gcm : diffuco_aero done '
END SUBROUTINE diffuco_aero
!! This routine computes partial beta coefficient : snow sublimation
!!
SUBROUTINE diffuco_snow (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, &
& snow, frac_nobio, totfrac_nobio, snow_nobio, vbeta1)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qsatt !! Surface saturated humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !! Surface drag
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: snow !! Snow mass
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: frac_nobio !! Fraction of ice,lakes,cities,...
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: snow_nobio !! Snow on ice,lakes,cities,...
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: totfrac_nobio!! Total fraction of ice+lakes+cities+...
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vbeta1 !! Beta for sublimation
! local declaration
REAL(r_std) :: subtest, zrapp, speed, vbeta1_add
INTEGER(i_std) :: ji, jv
!
! 1. beta coefficient for sublimation for snow on vegetation
!
DO ji=1,kjpindex
! Fraction of mesh that can sublimate snow
vbeta1(ji) = (un - totfrac_nobio(ji)) * MAX( MIN(snow(ji)/snowcri,un), zero)
!
! -- Limitation of sublimation in case of snow amounts smaller than
! the atmospheric demande.
!
speed = MAX(min_wind, wind(ji))
!
subtest = dtradia * vbeta1(ji) * speed * q_cdrag(ji) * rau(ji) * &
& ( qsatt(ji) - qair(ji) )
!
IF ( subtest .GT. zero ) THEN
zrapp = snow(ji) / subtest
IF ( zrapp .LT. un ) THEN
vbeta1(ji) = vbeta1(ji) * zrapp
ENDIF
ENDIF
!
END DO
!
! 2. add beta coefficient for other surface types.
!
DO jv = 1, nnobio
!
IF ( jv .EQ. iice ) THEN
!
! Land ice is of course a particular case
!
DO ji=1,kjpindex
vbeta1(ji) = vbeta1(ji) + frac_nobio(ji,jv)
ENDDO
!
ELSE
!
DO ji=1,kjpindex
!
vbeta1_add = frac_nobio(ji,jv) * MAX( MIN(snow_nobio(ji,jv)/snowcri,un), zero)
!
! -- Limitation of sublimation in case of snow amounts smaller than
! the atmospheric demand.
!
speed = MAX(min_wind, wind(ji))
!
subtest = dtradia * vbeta1_add * speed * q_cdrag(ji) * rau(ji) * &
& ( qsatt(ji) - qair(ji) )
!
IF ( subtest .GT. zero ) THEN
zrapp = snow_nobio(ji,jv) / subtest
IF ( zrapp .LT. un ) THEN
vbeta1_add = vbeta1_add * zrapp
ENDIF
ENDIF
!
vbeta1(ji) = vbeta1(ji) + vbeta1_add
!
ENDDO
!
ENDIF
!
ENDDO
IF (long_print) WRITE (numout,*) ' diffuco_snow done '
END SUBROUTINE diffuco_snow
!! This routine computes partial beta coefficient : floodplains
!!
SUBROUTINE diffuco_flood (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, evapot, evapot_corr, &
& flood_frac, flood_res, vbeta5)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qsatt !! Surface saturated humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !! Surface drag
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: flood_res !! water mass in flood reservoir
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: flood_frac !! fraction of floodplains
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot !! Potential evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot_corr!! Potential evaporation2
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vbeta5 !! Beta for floodplains
! local declaration
REAL(r_std) :: subtest, zrapp, speed
INTEGER(i_std) :: ji, jv
!
! beta coefficient for sublimation for floodplains
!
DO ji=1,kjpindex
!
IF (evapot(ji) .GT. min_sechiba) THEN
vbeta5(ji) = flood_frac(ji) *evapot_corr(ji)/evapot(ji)
ELSE
vbeta5(ji) = flood_frac(ji)
ENDIF
!
! -- Limitation of evaporation in case of water amounts smaller than
! the atmospheric demand.
!
speed = MAX(min_wind, wind(ji))
!
subtest = dtradia * vbeta5(ji) * speed * q_cdrag(ji) * rau(ji) * &
& ( qsatt(ji) - qair(ji) )
!
IF ( subtest .GT. zero ) THEN
zrapp = flood_res(ji) / subtest
IF ( zrapp .LT. un ) THEN
vbeta5(ji) = vbeta5(ji) * zrapp
ENDIF
ENDIF
!
END DO
IF (long_print) WRITE (numout,*) ' diffuco_flood done '
END SUBROUTINE diffuco_flood
!! This routine computes partial beta coefficient : interception for each type of vegetation
!!
! Nathalie - Juin 2006 - Introduction de vbeta23
!SUBROUTINE diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, veget, &
! & qsintveg, qsintmax, rstruct, vbeta2)
SUBROUTINE diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, veget, &
& qsintveg, qsintmax, rstruct, vbeta2, vbeta23)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qsatt !! Surface saturated humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !! Surface drag
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! vegetation fraction for each type
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintveg !! Water on vegetation due to interception
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintmax !! Maximum water on vegetation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: rstruct !! STOMATE: architectural resistance
! output fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta2 !! Beta for interception loss
! AJout Nathalie - Juin 2006
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta23 !! Beta for fraction of wetted foliage that will transpire
! Fin ajout Nathalie
! local declaration
INTEGER(i_std) :: ji, jv
REAL(r_std) :: zqsvegrap, ziltest, zrapp, speed
!
! Correction Nathalie - Initialisation des vbeta2x
vbeta2(:,:) = zero
! Ajout Nathalie - Juin 2006
vbeta23(:,:) = zero
! Fin ajout Nathalie
!
DO jv = 1,nvm
!
! 1. beta coefficient for vegetation interception
!
DO ji=1,kjpindex
IF (veget(ji,jv) .GT. min_sechiba .AND. qsintveg(ji,jv) .GT. zero ) THEN
zqsvegrap = zero
IF (qsintmax(ji,jv) .GT. min_sechiba ) THEN
zqsvegrap = MAX(zero, qsintveg(ji,jv) / qsintmax(ji,jv))
END IF
! Comment the line below if you want to use a formula of evaporation that uses zqsvegrap (see vbeta3)
zqsvegrap = un
!
speed = MAX(min_wind, wind(ji))
! -- Interception loss: IL
vbeta2(ji,jv) = veget(ji,jv) * zqsvegrap * (un / (un + speed * q_cdrag(ji) * rstruct(ji,jv)))
!
! -- Limitation of IL by the water stored on the leaf.
! A first approximation of IL is obtained with the old values of
! qair and qsol_sat: function of temp-sol and pb. (see call of qsatcalc)
!
ziltest = dtradia * vbeta2(ji,jv) * speed * q_cdrag(ji) * rau(ji) * &
& ( qsatt(ji) - qair(ji) )
IF ( ziltest .GT. zero ) THEN
zrapp = qsintveg(ji,jv) / ziltest
IF ( zrapp .LT. un ) THEN
! Ajout Nathalie - Juin 2006
vbeta23(ji,jv) = MAX(vbeta2(ji,jv) - vbeta2(ji,jv) * zrapp, zero)
! Fin ajout Nathalie
vbeta2(ji,jv) = vbeta2(ji,jv) * zrapp
ENDIF
ENDIF
END IF
! Autre formulation possible pour l'evaporation permettant une transpiration sur tout le feuillage
!commenter si formulation Nathalie sinon Tristan
!MG
speed = MAX(min_wind, wind(ji))
vbeta23(ji,jv) = MAX(zero, veget(ji,jv) * (un / (un + speed * q_cdrag(ji) * rstruct(ji,jv))) - vbeta2(ji,jv))
END DO
END DO
IF (long_print) WRITE (numout,*) ' diffuco_inter done '
END SUBROUTINE diffuco_inter
!! This routine computes partial beta coefficient : bare soil
!!
SUBROUTINE diffuco_bare (kjpindex, dtradia, u, v, q_cdrag, rsol, evap_bare_lim, evapot, humrel, &
& frac_bare, veget, vbeta2, vbeta3, vbeta4)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !! Surface drag
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rsol !! resistance for bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evap_bare_lim !! Beta factor for bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot !! Soil Potential Evaporation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: humrel !! Soil moisture stress
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Type of vegetation fraction
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: frac_bare !! Bare soil fraction per vegetation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbeta2 !! Beta for Interception
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbeta3 !! Beta for Transpiration
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vbeta4 !! Beta for bare soil evaporation
! local declaration
INTEGER(i_std) :: ji, jv
REAL(r_std) :: speed
REAL(r_std) :: humveg_prod
IF ( .NOT. control%hydrol_cwrr ) THEN
DO ji = 1, kjpindex
!
vbeta4(ji) = zero
!
! 1. Soil resistance and beta for bare soil
! Using bare soil fraction
!
!
speed = MAX(min_wind, wind(ji))
!
humveg_prod = zero
!
DO jv = 1, nvm
humveg_prod = humveg_prod + frac_bare(ji,jv) * veget(ji,jv) * humrel(ji,jv)
ENDDO
! Correction Nathalie de Noblet - le 27 Mars 2006
! Selon recommandation de Frederic Hourdin: supprimer humrel dans formulation vbeta4
!vbeta4(ji) = veget(ji,1) *humrel(ji,1)* (un / (un + speed * q_cdrag(ji) * rsol(ji)))
! Nathalie - le 28 mars 2006 - vbeta4 n'etait pas calcule en fonction de
! rsol mais de rsol_cste * hdry! Dans ce cas inutile de calculer rsol(ji)!!
!Decommenter la ligne ci-dessous si calcul Nathalie
!vbeta4(ji) = veget(ji,1) * (un / (un + speed * q_cdrag(ji) * rsol(ji)))
!Commenter la ligne ci-dessous si calcul Nathalie sinon Tristan
vbeta4(ji) = MIN(humveg_prod * (un / (un + speed * q_cdrag(ji) * rsol(ji))), &
& un - SUM(vbeta2(ji,:)+vbeta3(ji,:)))
!
!
END DO
ELSE
DO ji = 1, kjpindex
! The limitation by 1-beta2-beta3 is due to the fact that evaporation under vegetation is possible
vbeta4(ji) = MIN(evap_bare_lim(ji), un - SUM(vbeta2(ji,:)+vbeta3(ji,:)))
END DO
ENDIF
IF (long_print) WRITE (numout,*) ' diffuco_bare done '
END SUBROUTINE diffuco_bare
!! This routine computes partial beta coefficient : transpiration for each type of vegetation
!!
! Nathalie - Juin 2006 - introduction de vbeta23
!SUBROUTINE diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
! veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2)
SUBROUTINE diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
veget, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2, vbeta23)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swnet !! Short wave net flux in
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Air temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !! Surface drag
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: humrel !! Soil moisture stress
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Type of vegetation fraction
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: lai !! Leaf area index
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintveg !! Water on vegetation due to interception
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintmax !! Maximum water on vegetation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: rstruct !! STOMATE
! AJout Nathalie - Juin 2006
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbeta23 !! Beta for fraction of wetted foliage that will transpire
! Fin ajout Nathalie
! output fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta3 !! Beta for Transpiration
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: rveget !! Surface resistance of vegetation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: cimean !! STOMATE
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbetaco2 !! STOMATE
! local declaration
INTEGER(i_std) :: ji, jv
REAL(r_std) :: speed
REAL(r_std), DIMENSION(kjpindex) :: zdefconc, zqsvegrap
REAL(r_std), DIMENSION(kjpindex) :: qsatt
!
! 1. Moisture concentration at the leaf level.
!
CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
zdefconc(:) = rau(:) * MAX( qsatt(:) - qair(:), zero )
!
! 2. beta coefficient for vegetation transpiration
!
DO jv = 1,nvm
rveget(:,jv) = undef_sechiba
vbeta3(:,jv) = zero
zqsvegrap(:) = zero
DO ji = 1, kjpindex
speed = MAX(min_wind, wind(ji))
IF (qsintmax(ji,jv) .GT. min_sechiba) THEN
zqsvegrap(ji) = MAX(zero, qsintveg(ji,jv) / qsintmax(ji,jv))
ENDIF
IF ( ( veget(ji,jv)*lai(ji,jv) .GT. min_sechiba ) .AND. &
( kzero(jv) .GT. min_sechiba ) .AND. &
( swnet(ji) .GT. min_sechiba ) ) THEN
rveget(ji,jv) = (( swnet(ji) + rayt_cste ) / swnet(ji) ) &
* ((defc_plus + (defc_mult * zdefconc(ji) )) / kzero(jv)) * (un / lai(ji,jv))
! Corrections Nathalie - le 28 mars 2006 - sur conseils Fred Hourdin
! Introduction d'un potentiometre (rveg_pft) pour regler la somme rveg+rstruct
!vbeta3(ji,jv) = veget(ji,jv) * (un - zqsvegrap(ji)) * humrel(ji,jv) * &
! (un / (un + speed * q_cdrag(ji) * (rveget(ji,jv) + rstruct(ji,jv))))
!vbeta3(ji,jv) = veget(ji,jv) * (un - zqsvegrap(ji)) * humrel(ji,jv) * &
! (un / (un + speed * q_cdrag(ji) * (rveg_pft(jv)*(rveget(ji,jv) + rstruct(ji,jv)))))
! Fin ajout Nathalie
! Ajout Nathalie - Juin 2006
!vbeta3(ji,jv) = vbeta3(ji,jv) + MIN( vbeta23(ji,jv), &
! veget(ji,jv) * zqsvegrap(ji) * humrel(ji,jv) * &
! (un / (un + speed * q_cdrag(ji) * (rveg_pft(jv)*(rveget(ji,jv) + rstruct(ji,jv))))))
! Fin ajout Nathalie
! Autre possibilite permettant la transpiration sur toute la canopee
!Commenter si formulation Nathalie sinon Tristan
vbeta3(ji,jv) = MAX(zero, MIN(vbeta23(ji,jv), &
& veget(ji,jv) * humrel(ji,jv) / (un + speed * q_cdrag(ji) * (rveg_pft(jv)*(rveget(ji,jv) + rstruct(ji,jv))))))
ENDIF
ENDDO
ENDDO
! STOMATE
cimean(:,:) = zero
vbetaco2(:,:) = zero
IF (long_print) WRITE (numout,*) ' diffuco_trans done '
END SUBROUTINE diffuco_trans
!! This routine computes partial beta coefficient : transpiration for each type of vegetation
!! STOMATE: this routine now calculates also the assimilation using the Farqhuar & al (1980) formulation
!!
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! Nathalie - Juin 2006 - introduction de vbeta23
!SUBROUTINE diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
! assim_param, ccanopy, &
! veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2)
SUBROUTINE diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_air, pb, qair, q2m, t2m, rau, u, v, q_cdrag, humrel, &
assim_param, ccanopy, &
veget, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2, vbeta23)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swdown !! Downwelling short wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Air temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
! Ajout Nathalie - Juin 2006 - declaration q2m
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q2m !! 2m specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: t2m !! 2m air temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !! Surface drag
REAL(r_std),DIMENSION (kjpindex,nvm,npco2), INTENT (in) :: assim_param !! min+max+opt temps, vcmax, vjmax for photosynthesis
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: ccanopy !! STOMATE: CO2 concentration inside the canopy
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: humrel !! Soil moisture stress
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Type of vegetation fraction
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: lai !! Leaf area index
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintveg !! Water on vegetation due to interception
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintmax !! Maximum water on vegetation
! AJout Nathalie - Juin 2006
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbeta23 !! Beta for fraction of wetted foliage that will transpire
! Fin ajout Nathalie
! output fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta3 !! Beta for Transpiration
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: rveget !! Surface resistance of vegetation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: rstruct !! STOMATE
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: cimean !! STOMATE
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbetaco2 !! STOMATE
! local declaration
REAL(r_std),DIMENSION (kjpindex,nvm) :: vcmax
REAL(r_std),DIMENSION (kjpindex,nvm) :: vjmax
REAL(r_std),DIMENSION (kjpindex,nvm) :: tmin
REAL(r_std),DIMENSION (kjpindex,nvm) :: topt
REAL(r_std),DIMENSION (kjpindex,nvm) :: tmax
INTEGER(i_std) :: ji, jv, jl
REAL(r_std), DIMENSION(kjpindex) :: leaf_ci_lowest
INTEGER(i_std), DIMENSION(kjpindex) :: ilai
REAL(r_std), DIMENSION(kjpindex) :: zqsvegrap
REAL(r_std) :: speed
! STOMATE:
LOGICAL, DIMENSION(kjpindex) :: assimilate, calculate
INTEGER(i_std) :: nic,inic,icinic
INTEGER(i_std), DIMENSION(kjpindex) :: index_calc
INTEGER(i_std) :: nia,inia,nina,inina,iainia
INTEGER(i_std), DIMENSION(kjpindex) :: index_assi,index_non_assi
REAL(r_std), PARAMETER :: laimax = 12.
REAL(r_std), PARAMETER :: xc4_1 = .83
REAL(r_std), PARAMETER :: xc4_2 = .93
REAL(r_std), DIMENSION(kjpindex) :: vc2, vj2
REAL(r_std), DIMENSION(kjpindex) :: assimi
REAL(r_std) :: x_1,x_2,x_3,x_4,x_5,x_6
REAL(r_std), DIMENSION(kjpindex) :: gstop, gs
REAL(r_std), DIMENSION(kjpindex) :: Kc, Ko, CP
REAL(r_std), DIMENSION(kjpindex) :: vc, vj
REAL(r_std), DIMENSION(kjpindex) :: kt, rt
REAL(r_std), DIMENSION(kjpindex) :: air_relhum
REAL(r_std), DIMENSION(kjpindex) :: water_lim, temp_lim
REAL(r_std), DIMENSION(kjpindex) :: gstot
REAL(r_std), DIMENSION(kjpindex) :: assimtot
REAL(r_std), DIMENSION(kjpindex) :: leaf_gs_top !! stomatal conductance at topmost level
REAL(r_std), DIMENSION(nlai+1) :: laitab !! tabulated LAI steps
REAL(r_std), DIMENSION(kjpindex) :: qsatt
REAL(r_std), DIMENSION(nvm,nlai) :: light !! fraction of light that gets through
REAL(r_std), DIMENSION(kjpindex) :: ci_gs
!
! calculate LAI steps
!
DO jl = 1, nlai+1
laitab(jl) = laimax*(EXP(.15*REAL(jl-1,r_std))-1.)/(EXP(.15*REAL(nlai,r_std))-1.)
ENDDO
!
! calculate light fraction that comes through at a given LAI for each vegetation type
!
DO jl = 1, nlai
!
DO jv = 1, nvm
!
light(jv,jl) = exp( -ext_coef(jv)*laitab(jl) )
!
ENDDO
!
ENDDO
!
! 1. Photosynthesis parameters
!
!
! temperatures in K
!
tmin(:,:) = assim_param(:,:,itmin)
tmax(:,:) = assim_param(:,:,itmax)
topt(:,:) = assim_param(:,:,itopt)
!
vcmax(:,:) = assim_param(:,:,ivcmax)
vjmax(:,:) = assim_param(:,:,ivjmax)
!
! estimation of relative humidity of the air
!
! correction Nathalie, on utilise q2m/t2m au lieu de qair - Juin 2006
! CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
! air_relhum(:) = &
! ( qair(:) * pb(:) / (0.622+qair(:)*0.378) ) / &
! ( qsatt(:)*pb(:) / (0.622+qsatt(:)*0.378 ) )
CALL qsatcalc (kjpindex, t2m, pb, qsatt)
air_relhum(:) = &
( q2m(:) * pb(:) / (0.622+q2m(:)*0.378) ) / &
( qsatt(:)*pb(:) / (0.622+qsatt(:)*0.378 ) )
!
DO jv = 1,nvm
!
! 2. beta coefficient for vegetation transpiration
!
rstruct(:,jv) = rstruct_const(jv)
rveget(:,jv) = undef_sechiba
!
vbeta3(:,jv) = zero
vbetaco2(:,jv) = zero
!
cimean(:,jv) = ccanopy(:)
!
! mask that contains points where there is photosynthesis
!
nia=0
nina=0
!
DO ji=1,kjpindex
!
IF ( ( lai(ji,jv) .GT. 0.01 ) .AND. &
( veget(ji,jv) .GT. 1.E-8 ) .AND. &
( swdown(ji) .GT. min_sechiba ) .AND. &
( temp_air(ji) .GT. tmin(ji,jv) ) .AND. &
( temp_air(ji) .LT. tmax(ji,jv) ) .AND. &
( humrel(ji,jv) .GT. min_sechiba ) ) then
!
assimilate(ji) = .TRUE.
nia=nia+1
index_assi(nia)=ji
!
ELSE
!
assimilate(ji) = .FALSE.
nina=nina+1
index_non_assi(nina)=ji
!
ENDIF
!
ENDDO
!
gstot(:) = zero
assimtot(:) = zero
!
zqsvegrap(:) = zero
WHERE (qsintmax(:,jv) .GT. min_sechiba)
zqsvegrap(:) = MAX(zero, qsintveg(:,jv) / qsintmax(:,jv))
ENDWHERE
!
WHERE ( assimilate(:) )
water_lim(:) = MIN( 2.*humrel(:,jv), 1. )
ENDWHERE
! give a default value of ci for all pixel that do not assimilate
DO jl=1,nlai
DO inina=1,nina
leaf_ci(index_non_assi(inina),jv,jl) = ccanopy(index_non_assi(inina)) * .667_r_std
ENDDO
ENDDO
!
ilai(:) = 1
!
! Here is calculated photosynthesis (Farqhuar et al. 80)
! and stomatal conductance (Ball & al. 86)
!
! Calculating temperature dependent parameters
!
IF ( is_c4(jv) ) THEN
!
! Case of C4 plants
!
IF (nia .GT. 0) then
!OCL NOVREC
DO inia=1,nia
!
x_1 = 0.177 * EXP( 0.069*(temp_air(index_assi(inia))-tp_00) )
! = 2.0**(((temp_air(index_assi(inia))-tp_00)-25.0)/10.0)
!
kt(index_assi(inia)) = 0.7 * x_1 * 1.e6
rt(index_assi(inia)) = 0.8 * x_1 / &
( 1.0 + EXP(1.3*(temp_air(index_assi(inia))-tmax(index_assi(inia),jv))) )
!
vc(index_assi(inia)) = vcmax(index_assi(inia),jv) &
* 0.39 * x_1 * water_lim(index_assi(inia)) / &
! * 0.39 * x_1 / &
( (1.0+EXP(0.3*(tmin(index_assi(inia),jv)-temp_air(index_assi(inia))))) &
* (1.0+EXP(0.3*(temp_air(index_assi(inia))-topt(index_assi(inia),jv)))) )
!
ENDDO
ENDIF
!
IF (nina .GT. 0) then
!
!OCL NOVREC
DO inina=1,nina
!
kt(index_non_assi(inina)) = 0.0
rt(index_non_assi(inina)) = 0.0
vc(index_non_assi(inina)) = 0.0
!
ENDDO
!
ENDIF
!
ELSE
!
! Case of C3 plants
!
IF (nia .GT. 0) then
!
!OCL NOVREC
DO inia=1,nia
!
temp_lim(index_assi(inia)) = &
(temp_air(index_assi(inia))-tmin(index_assi(inia),jv)) * &
(temp_air(index_assi(inia))-tmax(index_assi(inia),jv))
temp_lim(index_assi(inia)) = temp_lim(index_assi(inia)) / &
(temp_lim(index_assi(inia))-(temp_air(index_assi(inia))-&
topt(index_assi(inia),jv))**2)
!
Kc(index_assi(inia)) = 39.09 * EXP(.085*(temp_air(index_assi(inia))-tp_00))
!
Ko(index_assi(inia)) = 2.412 * 210000. &
* EXP(.085*(temp_air(index_assi(inia))-tmin(index_assi(inia),jv))) / &
(temp_air(index_assi(inia))-tmin(index_assi(inia),jv))
!
CP(index_assi(inia)) = 42. * EXP( 9.46*(temp_air(index_assi(inia))-tp_00-25.)/&
temp_air(index_assi(inia)) )
!
vc(index_assi(inia)) = vcmax(index_assi(inia),jv) * &
temp_lim(index_assi(inia)) * water_lim(index_assi(inia))
! temp_lim(index_assi(inia))
vj(index_assi(inia)) = vjmax(index_assi(inia),jv) * &
temp_lim(index_assi(inia)) * water_lim(index_assi(inia))
! temp_lim(index_assi(inia))
!
ENDDO
!
ENDIF
!
IF (nina .GT. 0) then
!
!OCL NOVREC
DO inina=1,nina
!
temp_lim(index_non_assi(inina)) = 0.0
Kc(index_non_assi(inina)) = 0.0
Ko(index_non_assi(inina)) = 0.0
CP(index_non_assi(inina)) = 0.0
!
vc(index_non_assi(inina)) = 0.0
vj(index_non_assi(inina)) = 0.0
!
ENDDO
!
ENDIF
!
ENDIF ! C3/C4
!
! estimate assimilation and conductance for each LAI level
!
DO jl = 1, nlai
!
nic=0
!
calculate(:) = .FALSE.
!
IF (nia .GT. 0) then
!
!OCL NOVREC
DO inia=1,nia
!
calculate(index_assi(inia)) = (laitab(jl) .LE. lai(index_assi(inia),jv) )
!
IF ( calculate(index_assi(inia)) ) THEN
!
nic=nic+1
index_calc(nic)=index_assi(inia)
!
ENDIF
!
ENDDO
!
ENDIF
!
! Vmax is scaled into the canopy due to reduction of nitrogen
!
x_1 = ( un - .7_r_std * ( un - light(jv,jl) ) )
!
IF ( nic .GT. 0 ) THEN
!
DO inic=1,nic
!
vc2(index_calc(inic)) = vc(index_calc(inic)) * x_1
vj2(index_calc(inic)) = vj(index_calc(inic)) * x_1
!
ENDDO
!
ENDIF
!
IF ( is_c4(jv) ) THEN
!
! assimilation for C4 plants (Collatz & al. 91)
!
DO ji = 1, kjpindex
!
assimi(ji) = 0.
!
ENDDO
!
IF (nic .GT. 0) THEN
!
!OCL NOVREC
DO inic=1,nic
!
x_1 = - ( vc2(index_calc(inic)) + 0.092 * 2.3* swdown(index_calc(inic)) * &
ext_coef(jv) * light(jv,jl) )
x_2 = vc2(index_calc(inic)) * 0.092 * 2.3 * swdown(index_calc(inic)) * &
ext_coef(jv) * light(jv,jl)
x_3 = ( -x_1 - sqrt( x_1*x_1 - 4.0 * xc4_1 * x_2 ) ) / (2.0*xc4_1)
x_4 = - ( x_3 + kt(index_calc(inic)) * leaf_ci(index_calc(inic),jv,jl) * &
1.0e-6 )
x_5 = x_3 * kt(index_calc(inic)) * leaf_ci(index_calc(inic),jv,jl) * 1.0e-6
assimi(index_calc(inic)) = ( -x_4 - sqrt( x_4*x_4 - 4. * xc4_2 * x_5 ) ) / (2.*xc4_2)
assimi(index_calc(inic)) = assimi(index_calc(inic)) - &
rt(index_calc(inic))
!
ENDDO
!
ENDIF
!
ELSE
!
! assimilation for C3 plants (Farqhuar & al. 80)
!
DO ji = 1, kjpindex
!
assimi(ji) = 0.
!
ENDDO
!
IF (nic .GT. 0) THEN
!
!OCL NOVREC
DO inic=1,nic
!
x_1 = vc2(index_calc(inic)) * leaf_ci(index_calc(inic),jv,jl) / &
( leaf_ci(index_calc(inic),jv,jl) + Kc(index_calc(inic)) * &
( 1._r_std + 210000._r_std / Ko(index_calc(inic)) ) )
x_2 = .8855_r_std*swdown(index_calc(inic))*ext_coef(jv)*light(jv,jl)
x_3 = x_2+vj2(index_calc(inic))
x_4 = ( x_3 - sqrt( x_3*x_3 - (4._r_std*.7_r_std*x_2*vj2(index_calc(inic))) ) ) / &
(2._r_std*.7_r_std)
x_5 = x_4 * leaf_ci(index_calc(inic),jv,jl) / &
( 4.5_r_std * leaf_ci(index_calc(inic),jv,jl) + &
10.5_r_std*CP(index_calc(inic)) )
x_6 = MIN( x_1, x_5 )
assimi(index_calc(inic)) = x_6 * ( 1._r_std - CP(index_calc(inic))/&
leaf_ci(index_calc(inic),jv,jl) ) - .011_r_std * vc2(index_calc(inic))
!
ENDDO
!
ENDIF
!
ENDIF
!
IF (nic .GT. 0) THEN
!
!OCL NOVREC
!cdir NODEP
DO inic=1,nic
!
! estimate conductance (Ball & al. 86)
!
icinic=index_calc(inic)
! gs(icinic) = water_lim(icinic) * &
gs(icinic) = &
( gsslope(jv) * assimi(icinic) * &
air_relhum(icinic) / ccanopy(icinic) ) &
+ gsoffset(jv)
gs(icinic) = MAX( gs(icinic), gsoffset(jv) )
ENDDO
!
DO inic=1,nic
icinic=index_calc(inic)
!
! the new ci is calculated with
! dci/dt=(ccanopy-ci)*gs/1.6-A
! ci=ci+((ccanopy(icinic)-ci)*gs/1.6-&
! assimi(icinic))*dtradia
! we verify that ci is not out of possible values
!
ci_gs(icinic) = MIN( ccanopy(icinic), MAX( CP(icinic), &
( ccanopy(icinic) - 1.6_r_std * assimi(icinic) / &
gs(icinic) ) ) ) - leaf_ci(icinic,jv,jl)
ENDDO
!cdir NODEP
DO inic=1,nic
icinic=index_calc(inic)
!to avoid some problem of numerical stability, the leaf_ci is bufferized
leaf_ci(icinic,jv,jl) = leaf_ci(icinic,jv,jl) + ci_gs(icinic)/6.
ENDDO
!
DO inic=1,nic
icinic=index_calc(inic)
!
! this might be the last level for which Ci is calculated. Store it for
! initialization of the remaining levels of the Ci array.
!
leaf_ci_lowest(icinic) = leaf_ci(icinic,jv,jl)
ENDDO
!
!cdir NODEP
DO inic=1,nic
icinic=index_calc(inic)
!
! total assimilation and conductance
assimtot(icinic) = assimtot(icinic) + &
assimi(icinic) * (laitab(jl+1)-laitab(jl))
gstot(icinic) = gstot(icinic) + &
gs(icinic) * (laitab(jl+1)-laitab(jl))
!
ilai(icinic) = jl
!
ENDDO
!
ENDIF
!
! keep stomatal conductance of topmost level
!
IF ( jl .EQ. 1 ) THEN
!
leaf_gs_top(:) = 0.
!
IF ( nic .GT. 0 ) then
!
!OCL NOVREC
DO inic=1,nic
!
leaf_gs_top(index_calc(inic)) = gs(index_calc(inic))
!
ENDDO
!
ENDIF
!
ENDIF
!
IF (nia .GT. 0) THEN
!
!OCL NOVREC
DO inia=1,nia
!
IF ( .NOT. calculate(index_assi(inia)) ) THEN
!
! a) for plants that are doing photosynthesis, but whose LAI is lower
! than the present LAI step, initialize it to the Ci of the lowest
! canopy level
!
leaf_ci(index_assi(inia),jv,jl) = leaf_ci_lowest(index_assi(inia))
!
ENDIF
!
ENDDO
!
ENDIF
!
ENDDO ! loop over LAI steps
!
! final calculations: resistances
!
IF (nia .GT. 0) THEN
!
!OCL NOVREC
!cdir NODEP
DO inia=1,nia
!
iainia=index_assi(inia)
!
! conversion from mmol/m2/s to m/s
!
gstot(iainia) = .0244*(temp_air(iainia)/tp_00)*&
(1013./pb(iainia))*gstot(iainia)
gstop(iainia) = .0244 * (temp_air(iainia)/tp_00)*&
(1013./pb(iainia))*leaf_gs_top(iainia)*&
laitab(ilai(iainia)+1)
!
rveget(iainia,jv) = 1./gstop(iainia)
!
ENDDO
!
DO inia=1,nia
!
iainia=index_assi(inia)
!
! rstruct is the difference between rtot (=1./gstot) and rveget
!
! Correction Nathalie - le 27 Mars 2006 - Interdire a rstruct d'etre negatif
!rstruct(iainia,jv) = 1./gstot(iainia) - &
! rveget(iainia,jv)
rstruct(iainia,jv) = MAX( 1./gstot(iainia) - &
rveget(iainia,jv), min_sechiba)
!
ENDDO
!
DO inia=1,nia
!
iainia=index_assi(inia)
!
speed = MAX(min_wind, wind(index_assi(inia)))
!
! beta for transpiration
!
! Corrections Nathalie - le 28 mars 2006 - sur conseils Fred Hourdin
! Introduction d'un potentiometre (rveg_pft) pour regler la somme rveg+rstruct
!vbeta3(iainia,jv) = veget_max(iainia,jv) * &
! (un - zqsvegrap(iainia)) * &
! (un / (un + speed * q_cdrag(iainia) * (rveget(iainia,jv) + &
! rstruct(iainia,jv))))
vbeta3(iainia,jv) = veget(iainia,jv) * &
(un - zqsvegrap(iainia)) * &
(un / (un + speed * q_cdrag(iainia) * (rveg_pft(jv)*(rveget(iainia,jv) + &
rstruct(iainia,jv))))) + &
!!$ ! Ajout Nathalie - Juin 2006
!!$ vbeta3(iainia,jv) = vbeta3(iainia,jv) + &
MIN( vbeta23(iainia,jv), veget(iainia,jv) * &
zqsvegrap(iainia) * humrel(iainia,jv) * &
(un / (un + speed * q_cdrag(iainia) * &
(rveg_pft(jv)*(rveget(iainia,jv) + rstruct(iainia,jv))))) )
! Fin ajout Nathalie
!
! beta for assimilation. The difference is that surface
! covered by rain (un - zqsvegrap(iainia)) is not taken into account
! 1.6 is conversion for H2O to CO2 conductance
! vbetaco2(iainia,jv) = veget(iainia,jv) * &
! (un / (un + q_cdrag(iainia) * &
! (rveget(iainia,jv))))/1.6
!
vbetaco2(iainia,jv) = veget(iainia,jv) * &
(un / (un + speed * q_cdrag(iainia) * &
(rveget(iainia,jv) + rstruct(iainia,jv)))) / 1.6
!
! cimean is the "mean ci" calculated in such a way that assimilation
! calculated in enerbil is equivalent to assimtot
!
cimean(iainia,jv) = ccanopy(iainia) - &
assimtot(iainia) / &
( vbetaco2(iainia,jv)/veget(iainia,jv) * &
rau(iainia) * speed * q_cdrag(iainia))
!
ENDDO
!
ENDIF
!
END DO ! loop over vegetation types
!
IF (long_print) WRITE (numout,*) ' diffuco_trans_co2 done '
END SUBROUTINE diffuco_trans_co2
!! This routine combines previous partial beta coeeficient and calculates
!! alpha and complete beta coefficient
!!
! Ajout qsintmax dans les arguments de la routine Nathalie / le 13-03-2006
SUBROUTINE diffuco_comb (kjpindex, dtradia, humrel, rau, u, v, q_cdrag, pb, qair, temp_sol, temp_air, &
& snow, veget, frac_bare, vbeta1, vbeta2, vbeta3 , vbeta4, valpha, vbeta, qsintmax)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !! Surface drag
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol !! Skin temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! lower air temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: snow !! Snow mass
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: frac_bare !! Bare soil fraction per vegetation
! Ajout Nathalie / le 13-03-2006
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintmax !! Maximum water on vegetation
! modified fields
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: vbeta1 !! Beta for sublimation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: vbeta4 !! Beta for Bare soil evaporation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: humrel !! Soil moisture stress
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: vbeta2 !! Beta for Interception for
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: vbeta3 !! Beta for Transpiration
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: valpha !! TotalAlpha coefficient
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vbeta !! Total beta coefficient
! local declaration
INTEGER(i_std) :: ji, jv
REAL(r_std) :: zevtest, zsoil_moist, zrapp
REAL(r_std), DIMENSION(kjpindex) :: vbeta2sum, vbeta3sum
REAL(r_std), DIMENSION(kjpindex) :: vegetsum, vegetsum2
REAL(r_std), DIMENSION(kjpindex) :: qsatt
LOGICAL, DIMENSION(kjpindex) :: toveg, tosnow
vbeta2sum(:) = 0.
vbeta3sum(:) = 0.
DO jv = 1, nvm
vbeta2sum(:) = vbeta2sum(:) + vbeta2(:,jv)
vbeta3sum(:) = vbeta3sum(:) + vbeta3(:,jv)
ENDDO
!
! 1. The beta and alpha coefficients are calculated.
!
vbeta(:) = un
valpha(:) = un
!
! 2. if snow is lower than critical value
!
DO ji = 1, kjpindex
IF (snow(ji) .LT. snowcri) THEN
vbeta(ji) = vbeta4(ji) + vbeta2sum(ji) + vbeta3sum(ji)
IF (vbeta(ji) .LT. min_sechiba) THEN
vbeta(ji) = zero
END IF
END IF
ENDDO
!
! 3. If we are in presence of dew.
!
! for vectorization: some arrays
vegetsum(:) = 0.
DO jv = 1, nvm
vegetsum(:) = vegetsum(:) + veget(:,jv)
ENDDO
vegetsum2(:) = 0.
DO jv = 2, nvm
vegetsum2(:) = vegetsum2(:) + veget(:,jv)
ENDDO
CALL qsatcalc (kjpindex, temp_sol, pb, qsatt)
!
! 3.1 decide where the water goes (soil, vegetation, or snow)
! when air moisture exceeds saturation.
!
toveg(:) = .FALSE.
tosnow(:) = .FALSE.
DO ji = 1, kjpindex
IF ( qsatt(ji) .LT. qair(ji) ) THEN
IF (temp_air(ji) .GT. tp_00) THEN
!
! 3.1.1 If it is not freezing dew is put into the
! interception reservoir and on the bare soil.
toveg(ji) = .TRUE.
ELSE
!
! 3.1.2 If it is freezing water is put into the
! snow reservoir.
tosnow(ji) = .TRUE.
ENDIF
ENDIF
END DO
! 3.1.3 now modify valpha and vbetas where necessary.
!
! 3.1.3.1 Soil and snow (2d)
!
DO ji = 1, kjpindex
IF ( toveg(ji) ) THEN
vbeta1(ji) = zero
vbeta4(ji) = zero
DO jv = 1, nvm
vbeta4(ji) = vbeta4(ji) + frac_bare(ji,jv) * veget(ji,jv)
ENDDO
! Correction Nathalie - le 13-03-2006: le vbeta ne sera calcule qu'une fois tous les vbeta2 redefinis
!vbeta(ji) = vegetsum(ji)
vbeta(ji) = vbeta4(ji)
valpha(ji) = un
ENDIF
IF ( tosnow(ji) ) THEN
vbeta1(ji) = un
vbeta4(ji) = zero
vbeta(ji) = un
valpha(ji) = un
ENDIF
ENDDO
!
! 3.1.3.2 vegetation (3d)
!
DO jv = 1, nvm
!
DO ji = 1, kjpindex
!
! Correction Nathalie - 13-03-2006 / si qsintmax=0, vbeta2=0
IF ( toveg(ji) ) THEN
IF (qsintmax(ji,jv) .GT. min_sechiba) THEN
vbeta2(ji,jv) = veget(ji,jv)
ELSE
vbeta2(ji,jv) = zero
ENDIF
vbeta(ji) = vbeta(ji) + vbeta2(ji,jv)
ENDIF
IF ( tosnow(ji) ) vbeta2(ji,jv) = zero
!
ENDDO
!
ENDDO
!
! 3.2 In any case there is no transpiration when air moisture is too high.
!
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( qsatt(ji) .LT. qair(ji) ) THEN
vbeta3(ji,jv) = zero
humrel(ji,jv) = zero
ENDIF
ENDDO
ENDDO
!
! 3.2_bis In any case there is no interception loss on bare soil.
!
DO ji = 1, kjpindex
IF ( qsatt(ji) .LT. qair(ji) ) THEN
vbeta2(ji,1) = zero
ENDIF
ENDDO
IF (long_print) WRITE (numout,*) ' diffuco_comb done '
END SUBROUTINE diffuco_comb
SUBROUTINE diffuco_raerod (kjpindex, u, v, q_cdrag, raero)
!
! Simply computes the aerodynamic resistance. For the moment it is
! only used as a diagnostic but that may change !
!
IMPLICIT NONE
!
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !! Surface drag
! output filed
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: raero !! Aerodynamic resistance
!
! local declaration
INTEGER(i_std) :: ji
REAL(r_std) :: speed
!
DO ji=1,kjpindex
!
speed = MAX(min_wind, wind(ji))
raero(ji) = un / (q_cdrag(ji)*speed)
!
ENDDO
!
END SUBROUTINE diffuco_raerod
END MODULE diffuco
ORCHIDEE/src_sechiba/enerbil.f90 0000754 0103600 0005670 00000142361 11164403473 016141 0 ustar acamlmd lmdjus !!
!! This module computes energy bilan on continental surface
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.21 $, $Date: 2007/06/12 20:02:37 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/enerbil.f90,v 1.21 2007/06/12 20:02:37 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE enerbil
! routines called : restput, restget
!
USE ioipsl
!
! modules used :
USE constantes
USE constantes_veg
USE sechiba_io
USE parallel
! USE write_field_p, only : WriteFieldI_p
IMPLICIT NONE
! public routines :
! enerbil_main
! enerbil_fusion
PRIVATE
PUBLIC :: enerbil_main, enerbil_fusion,enerbil_clear
!
! variables used inside enerbil module : declaration and initialisation
!
LOGICAL, SAVE :: l_first_enerbil=.TRUE. !! Initialisation has to be done one time
CHARACTER(LEN=80), SAVE :: file_ext !! Extention for I/O filename
CHARACTER(LEN=80), SAVE :: var_name !! To store variables names for I/O
! one dimension array allocated, computed and used in enerbil module exclusively
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: psold !! Old surface dry static energy
!! saturated specific humudity for old temperature
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: qsol_sat
!! derivative of satured specific humidity at the old temperature
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: pdqsold
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: psnew !! New surface static energy
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: qsol_sat_new !! New saturated surface air moisture
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: netrad !! Net radiation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: lwabs !! LW radiation absorbed by the surface
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: lwup !! Long-wave up radiation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: lwnet !! Net Long-wave radiation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: fluxsubli !! Energy of sublimation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: qsat_air !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tair !!
CONTAINS
!!
!! Main routine for *enerbil* module
!! - called only one time for initialisation
!! - called every time step
!! - called one more time at last time step for writing _restart_ file
!!
!! Algorithm:
!! - call enerbil_begin for initialisation
!! - call enerbil_surftemp for psnew and qsol_sat_new
!! - call enerbil_flux for tsol_new, netrad, vevapp, fluxlat and fluxsens
!! - call enerbil_evapveg for evaporation and transpiration
!!
!! @call enerbil_begin
!! @call enerbil_surftemp
!! @call enerbil_flux
!! @call enerbil_evapveg
!!
SUBROUTINE enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
! & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef, &
!MG
& index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef, &
& qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, &
! & cimean, ccanopy, emis, soilflx, soilcap, q_cdrag, humrel, fluxsens, fluxlat, &
!MG
& rveget, rstruct, cimean, ccanopy, emis, soilflx, soilcap, q_cdrag, humrel, fluxsens, fluxlat, &
& vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
! & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id )
!MG
& temp_sol_new, qsurf, evapot, evapot_corr, etm, rest_id, hist_id, hist2_id )
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std),INTENT (in) :: rest_id,hist_id !! _Restart_ file and _history_ file identifier
INTEGER(i_std),INTENT (in) :: hist2_id !! _history_ file 2 identifier
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for _restart_ file to write
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
!MG
INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in) :: indexveg !! Indeces of the points on the 3D map
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: lwdown !! Down-welling long-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: epot_air !! Air potential energy
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Air temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! zonal wind (m/s)
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! north-south wind (m/s)
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: petAcoef !! PetAcoef
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: petBcoef !! PetBcoef
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: peqAcoef !! PeqAcoef
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: peqBcoef !! PeqBcoef
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta !! Resistance coefficient
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: valpha !! Resistance coefficient
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta1 !! Snow resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta4 !! Bare soil resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta5 !! Floodplains resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: emis !! Emissivity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: soilflx !! Soil flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: soilcap !! Soil calorific capacity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !! This is the cdrag without the wind multiplied
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: ccanopy !! CO2 concentration in the canopy
REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (in) :: humrel !! Relative humidity
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbeta2 !! Interception resistance
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbeta3 !! Vegetation resistance
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbetaco2 !! Vegetation resistance to CO2
!MG
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: rveget !! Surface resistance for the vegetatuon
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: rstruct !! Structural resistance for the vegetatuon
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: cimean !! mean Ci
! modified fields
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: evapot !! Soil Potential Evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: evapot_corr !! Soil Potential Evaporation Correction
!MG
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: etm !! Max 'evapo'transpi (taking into account the veg resistance)
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxsens !! Sensible chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxlat !! Latent chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapp !! Total of evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapnu !! Bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapsno !! Snow evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapflo !! Floodplains evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: tsol_rad !! Tsol_rad
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: temp_sol !! Soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: qsurf !! Surface specific humidity
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: transpir !! Transpiration
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: gpp !! Assimilation, gC/m**2 total area.
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vevapwet !! Interception
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: t2mdiag !! 2-meter temperature
!
! LOCAL
!
REAL(r_std),DIMENSION (kjpindex) :: epot_air_new, qair_new
!MG
INTEGER(i_std) :: ji,jv
!
! do initialisation
!
IF (l_first_enerbil) THEN
IF (long_print) WRITE (numout,*) ' l_first_enerbil : call enerbil_init '
CALL enerbil_init (kjit, ldrestart_read, kjpindex, index, rest_id, qair, temp_sol, temp_sol_new, &
& qsurf, tsol_rad, vevapp, fluxsens, fluxlat, gpp, evapot, evapot_corr)
CALL enerbil_var_init (kjpindex, temp_air, t2mdiag)
RETURN
ENDIF
!
! prepares restart file for the next simulation
!
IF (ldrestart_write) THEN
IF (long_print) WRITE (numout,*) ' we have to complete restart file with ENERBIL variables '
var_name= 'temp_sol'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, temp_sol, 'scatter', nbp_glo, index_g)
var_name= 'qsurf'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, qsurf, 'scatter', nbp_glo, index_g)
var_name= 'evapot'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, evapot, 'scatter', nbp_glo, index_g)
var_name= 'tsolrad'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, tsol_rad, 'scatter', nbp_glo, index_g)
var_name= 'evapora'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, vevapp, 'scatter', nbp_glo, index_g)
var_name= 'fluxlat'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, fluxlat, 'scatter', nbp_glo, index_g)
var_name= 'fluxsens'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, fluxsens, 'scatter', nbp_glo, index_g)
IF ( control%stomate_watchout .OR. control%ok_co2 ) THEN
! The gpp could in principle be recalculated at the beginning of the run.
! However, we would need several variables that are not stored in the restart files.
!
var_name= 'gpp'
CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, gpp, 'scatter', nbp_glo, index_g)
ENDIF
RETURN
END IF
!
!
! 1. computes some initialisation: psold, qsol_sat and pdqsold
!
CALL enerbil_begin (kjpindex, temp_sol, lwdown, swnet, pb, psold, qsol_sat, pdqsold, netrad, emis)
!
! 2. computes psnew and qsol_sat_new
!
CALL enerbil_surftemp (kjpindex, dtradia, zlev, emis, &
& epot_air, petAcoef, petBcoef, qair, peqAcoef, peqBcoef, soilflx, rau, u, v, q_cdrag, vbeta,&
& valpha, vbeta1, vbeta5, soilcap, lwdown, swnet, psnew, qsol_sat_new, temp_sol_new, &
& qair_new, epot_air_new)
!
! 3. computes tsol_new, netrad, vevapp, fluxlat, fluxsubli and fluxsens
!
CALL enerbil_flux (kjpindex, dtradia, emis, temp_sol, rau, u, v, q_cdrag, vbeta, valpha, vbeta1, vbeta5, &
! & qair_new, epot_air_new, psnew, qsurf, &
!MG
& rveget, rstruct, qair_new, epot_air_new, psnew, qsurf, &
& fluxsens , fluxlat , fluxsubli, vevapp, temp_sol_new, lwdown, swnet, lwup, lwnet, pb, tsol_rad,&
! & netrad, evapot, evapot_corr)
!MG
& netrad, evapot, evapot_corr,etm)
!
! 4. computes in details evaporation and transpiration
!
CALL enerbil_evapveg (kjpindex, dtradia, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, cimean, &
& ccanopy, rau, u, v, q_cdrag, qair_new, humrel, vevapsno, vevapnu , vevapflo, vevapwet, transpir, gpp, evapot)
! DO jv = 1, nvm
! DO ji = 1, kjpindex
! IF (transpir(ji,jv)-etm(ji,jv) .GT. min_sechiba) THEN
! PRINT *,"Warning: transpir greater than etm, etm, transpir",etm(ji,jv),transpir(ji,jv)
! PRINT *,"At point: ji, jv", ji, jv
! ENDIF
! ENDDO
! ENDDO
!
! 5. diagnose 2-meter temperatures
!
CALL enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'netrad', kjit, netrad, kjpindex, index)
CALL histwrite(hist_id, 'evapot', kjit, evapot, kjpindex, index)
CALL histwrite(hist_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
!MG
CALL histwrite(hist_id, 'etm', kjit, etm, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'lwdown', kjit, lwabs, kjpindex, index)
CALL histwrite(hist_id, 'lwnet', kjit, lwnet, kjpindex, index)
IF ( hist2_id > 0 ) THEN
CALL histwrite(hist2_id, 'netrad', kjit, netrad, kjpindex, index)
CALL histwrite(hist2_id, 'evapot', kjit, evapot, kjpindex, index)
CALL histwrite(hist2_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
!MG
CALL histwrite(hist2_id, 'etm', kjit, etm, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'lwdown', kjit, lwabs, kjpindex, index)
CALL histwrite(hist2_id, 'lwnet', kjit, lwnet, kjpindex, index)
ENDIF
ELSE
CALL histwrite(hist_id, 'LWnet', kjit, lwnet, kjpindex, index)
CALL histwrite(hist_id, 'Qv', kjit, fluxsubli, kjpindex, index)
CALL histwrite(hist_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
IF ( hist2_id > 0 ) THEN
CALL histwrite(hist2_id, 'LWnet', kjit, lwnet, kjpindex, index)
CALL histwrite(hist2_id, 'Qv', kjit, fluxsubli, kjpindex, index)
CALL histwrite(hist2_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
ENDIF
ENDIF
IF (long_print) WRITE (numout,*) ' enerbil_main Done '
END SUBROUTINE enerbil_main
!! Algorithm:
!! - dynamic allocation for local array
!!
SUBROUTINE enerbil_init (kjit, ldrestart_read, kjpindex, index, rest_id, qair, temp_sol, temp_sol_new, &
& qsurf, tsol_rad, vevapp, fluxsens, fluxlat, gpp, evapot, evapot_corr)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjit !! Time step number
LOGICAL ,INTENT (in) :: ldrestart_read !! Logical for _restart_ file to read
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std), INTENT (in) :: rest_id !! _Restart_ file identifier
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
! output scalar
! output fields, they need to initialized somehow for the model forcing ORCHIDEE.
!
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: temp_sol !! Soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: qsurf !! near surface specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: tsol_rad !! Tsol_rad
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapp !! Total of evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxsens !! Sensible chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxlat !! Latent chaleur flux
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: gpp !! Assimilation, gC/m**2 total area.
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: evapot !! Soil Potential Evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: evapot_corr !! Soil Potential Evaporation
! local declaration
INTEGER(i_std) :: ier
! initialisation
IF (l_first_enerbil) THEN
l_first_enerbil=.FALSE.
ELSE
WRITE (numout,*) ' l_first_enerbil false . we stop '
STOP 'enerbil_init'
ENDIF
ALLOCATE (psold(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in psold allocation. We stop.We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (qsol_sat(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsol_sat allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (pdqsold(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in pdqsold allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (psnew(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in psnew allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (qsol_sat_new(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsol_sat_new allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (netrad(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in netrad allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (lwabs(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in lwabs allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (lwup(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in lwup allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (lwnet(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in lwnet allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (fluxsubli(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in fluxsubli allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (qsat_air(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsat_air allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
ALLOCATE (tair(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tair allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'enerbil_init'
END IF
! open restart input file done by enerbil_init
! and read data from restart input file for ENERBIL process
IF (ldrestart_read) THEN
IF (long_print) WRITE (numout,*) ' we have to read a restart file for HYDROLOGIC variables'
var_name='temp_sol'
CALL ioconf_setatt('UNITS', 'K')
CALL ioconf_setatt('LONG_NAME','Surface temperature')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp_sol, "gather", nbp_glo, index_g)
!
!Config Key = ENERBIL_TSURF
!Config Desc = Initial temperature if not found in restart
!Config Def = 280.
!Config Help = The initial value of surface temperature if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (temp_sol, val_exp,'ENERBIL_TSURF', 280._r_std)
!
var_name= 'qsurf'
CALL ioconf_setatt('UNITS', 'g/g')
CALL ioconf_setatt('LONG_NAME','near surface specific humidity')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., qsurf, "gather", nbp_glo, index_g)
IF ( ALL( qsurf(:) .EQ. val_exp ) ) THEN
qsurf(:) = qair(:)
ENDIF
!
var_name= 'evapot'
CALL ioconf_setatt('UNITS', 'mm/d')
CALL ioconf_setatt('LONG_NAME','Soil Potential Evaporation')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., evapot, "gather", nbp_glo, index_g)
!
!Config Key = ENERBIL_EVAPOT
!Config Desc = Initial Soil Potential Evaporation
!Config Def = 0.0
!Config Help = The initial value of soil potential evaporation if its value
!Config is not found in the restart file. This should only be used if
!Config the model is started without a restart file.
!
CALL setvar_p (evapot, val_exp, 'ENERBIL_EVAPOT', 0.0_r_std)
evapot_corr(:) = evapot(:)
!
var_name= 'tsolrad'
CALL ioconf_setatt('UNITS', 'K')
CALL ioconf_setatt('LONG_NAME','Radiative surface temperature')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., tsol_rad, "gather", nbp_glo, index_g)
IF ( ALL( tsol_rad(:) .EQ. val_exp ) ) THEN
tsol_rad(:) = temp_sol(:)
ENDIF
!
! Set the fluxes so that we have something reasonable and not NaN on some machines
!
var_name= 'evapora'
CALL ioconf_setatt('UNITS', 'Kg/m^2/dt')
CALL ioconf_setatt('LONG_NAME','Evaporation')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vevapp, "gather", nbp_glo, index_g)
IF ( ALL( vevapp(:) .EQ. val_exp ) ) THEN
vevapp(:) = 0.0_r_std
ENDIF
!
var_name= 'fluxlat'
CALL ioconf_setatt('UNITS', 'W/m^2')
CALL ioconf_setatt('LONG_NAME','Latent heat flux')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., fluxlat, "gather", nbp_glo, index_g)
IF ( ALL( fluxlat(:) .EQ. val_exp ) ) THEN
fluxlat(:) = 0.0_r_std
ENDIF
!
var_name= 'fluxsens'
CALL ioconf_setatt('UNITS', 'W/m^2')
CALL ioconf_setatt('LONG_NAME','Sensible heat flux')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., fluxsens, "gather", nbp_glo, index_g)
IF ( ALL( fluxsens(:) .EQ. val_exp ) ) THEN
fluxsens(:) = 0.0_r_std
ENDIF
!
! If we are with STOMATE
!
IF ( control%stomate_watchout .OR. control%ok_co2 ) THEN
! The gpp could in principle be recalculated at the beginning of the run.
! However, we would need several variables that are not stored in the restart files.
var_name= 'gpp'
CALL ioconf_setatt('UNITS', 'gC/m**2/time step')
CALL ioconf_setatt('LONG_NAME','Gross primary productivity')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., gpp, "gather", nbp_glo, index_g)
IF ( ALL( gpp(:,:) .EQ. val_exp ) ) THEN
gpp(:,:) = 0.0
ENDIF
ENDIF
ENDIF
! initialises temp_sol_new
temp_sol_new(:) = temp_sol(:)
IF (long_print) WRITE (numout,*) ' enerbil_init done '
END SUBROUTINE enerbil_init
SUBROUTINE enerbil_clear ()
l_first_enerbil=.TRUE.
IF ( ALLOCATED (psold)) DEALLOCATE (psold)
IF ( ALLOCATED (qsol_sat)) DEALLOCATE (qsol_sat)
IF ( ALLOCATED (pdqsold)) DEALLOCATE (pdqsold)
IF ( ALLOCATED (psnew)) DEALLOCATE (psnew)
IF ( ALLOCATED (qsol_sat_new)) DEALLOCATE (qsol_sat_new)
IF ( ALLOCATED (netrad)) DEALLOCATE (netrad)
IF ( ALLOCATED (lwabs)) DEALLOCATE (lwabs)
IF ( ALLOCATED (lwup)) DEALLOCATE (lwup)
IF ( ALLOCATED (lwnet)) DEALLOCATE (lwnet)
IF ( ALLOCATED (fluxsubli)) DEALLOCATE (fluxsubli)
IF ( ALLOCATED (qsat_air)) DEALLOCATE (qsat_air)
IF ( ALLOCATED (tair)) DEALLOCATE (tair)
!
! open restart input file done by enerbil_init
! and read data from restart input file for ENERBIL process
END SUBROUTINE enerbil_clear
SUBROUTINE enerbil_var_init (kjpindex, temp_air, t2mdiag)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Air temperature in Kelvin
! modified fields
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: t2mdiag !! 2-meter temperature
CALL enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
IF (long_print) WRITE (numout,*) ' enerbil_var_init done '
END SUBROUTINE enerbil_var_init
!! This routines computes psold, qsol_sat, pdqsold and netrad
!!
SUBROUTINE enerbil_begin (kjpindex, temp_sol, lwdown, swnet, pb, psold, qsol_sat, pdqsold, netrad, emis)
! interface description
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol !! Soil temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: lwdown !! Down-welling long-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: emis !! Emissivity
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: psold !! Old surface dry static energy
!! Saturated specific humudity for old temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: qsol_sat
!! Derivative of satured specific humidity at the old temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: pdqsold
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: netrad !! Net radiation
! local declaration
INTEGER(i_std) :: ji
REAL(r_std), DIMENSION(kjpindex) :: dev_qsol
REAL(r_std), PARAMETER :: missing = 999998.
! initialisation
!
! 1. computes psold
!
psold(:) = temp_sol(:)*cp_air
!
! 2. computes qsol_sat
!
CALL qsatcalc (kjpindex, temp_sol, pb, qsol_sat)
IF ( diag_qsat ) THEN
IF ( ANY(ABS(qsol_sat(:)) .GT. missing) ) THEN
DO ji = 1, kjpindex
IF ( ABS(qsol_sat(ji)) .GT. missing) THEN
WRITE(numout,*) 'ERROR on ji = ', ji
WRITE(numout,*) 'temp_sol(ji), pb(ji) :', temp_sol(ji), pb(ji)
CALL ipslerr (3,'enerbil_begin', &
& 'qsol too high ','','')
ENDIF
ENDDO
ENDIF
ENDIF
!
! 3. computes pdqsold
!
CALL dev_qsatcalc (kjpindex, temp_sol, pb, dev_qsol)
DO ji = 1, kjpindex
pdqsold(ji) = dev_qsol(ji) * ( pb(ji)**kappa ) / cp_air
ENDDO
IF ( diag_qsat ) THEN
IF ( ANY(ABS( pdqsold(:)) .GT. missing) ) THEN
DO ji = 1, kjpindex
IF ( ABS( pdqsold(ji)) .GT. missing ) THEN
WRITE(numout,*) 'ERROR on ji = ', ji
WRITE(numout,*) 'temp_sol(ji), pb(ji) :', temp_sol(ji), pb(ji)
CALL ipslerr (3,'enerbil_begin', &
& 'pdqsold too high ','','')
ENDIF
ENDDO
ENDIF
ENDIF
!
! 4. computes netrad and absorbed LW radiation absorbed at the surface
!
lwabs(:) = emis(:) * lwdown(:)
netrad(:) = lwdown(:) + swnet (:) - (emis(:) * c_stefan * temp_sol(:)**4 + (un - emis(:)) * lwdown(:))
!
IF (long_print) WRITE (numout,*) ' enerbil_begin done '
END SUBROUTINE enerbil_begin
!! This routine computes psnew and qsol_sat_new
!!
!! Computes the energy balance at the surface with an implicit scheme
!! that is connected to the Richtmyer and Morton algorithm of the PBL.
!!
SUBROUTINE enerbil_surftemp (kjpindex, dtradia, zlev, emis, epot_air, &
& petAcoef, petBcoef, qair, peqAcoef, peqBcoef, soilflx, rau, u, v, q_cdrag, vbeta,&
& valpha, vbeta1, vbeta5, soilcap, lwdown, swnet, psnew, qsol_sat_new, temp_sol_new, &
& qair_new, epot_air_new)
! interface
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT(in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: emis !! Emissivity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: epot_air !! Air potential energy
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: petAcoef !! PetAcoef
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: petBcoef !! PetBcoef
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: peqAcoef !! PeqAcoef
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: peqBcoef !! PeqBcoef
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: soilflx !! Soil flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u, v !! Wind
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !!
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta !! Resistance coefficient
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: valpha !! Resistance coefficient
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta1 !! Snow resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta5 !! Floodplains resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: soilcap !! Soil calorific capacity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: lwdown !! Down-welling long-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swnet !! Net surface short-wave flux
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: psnew !! New surface static energy
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: qsol_sat_new !! New saturated surface air moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: qair_new !! New air moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: epot_air_new !! New air temperature
! local declaration
INTEGER(i_std) :: ji
REAL(r_std),DIMENSION (kjpindex) :: zicp
REAL(r_std) :: fevap
REAL(r_std) :: sensfl_old, larsub_old, lareva_old, dtheta, sum_old, sum_sns
REAL(r_std) :: zikt, zikq, netrad_sns, sensfl_sns, larsub_sns, lareva_sns
REAL(r_std) :: speed
zicp = un / cp_air
!
DO ji=1,kjpindex
!
!
! Help variables
!
!
speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
!
zikt = 1/(rau(ji) * speed * q_cdrag(ji))
zikq = 1/(rau(ji) * speed * q_cdrag(ji))
!
!
! The first step is to compute the fluxes for the old surface conditions
!
!
sensfl_old = (petBcoef(ji) - psold(ji)) / (zikt - petAcoef(ji))
larsub_old = chalsu0 * vbeta1(ji) * (un - vbeta5(ji)) * (peqBcoef(ji) - qsol_sat(ji)) / (zikq - peqAcoef(ji))
lareva_old = chalev0 * (un - vbeta1(ji)) * (un - vbeta5(ji)) * vbeta(ji) * &
& (peqBcoef(ji) - valpha(ji) * qsol_sat(ji)) / (zikq - peqAcoef(ji)) &
& + chalev0 * vbeta5(ji) * (peqBcoef(ji) - qsol_sat(ji)) / (zikq - peqAcoef(ji))
!
!
! Next the sensitivity terms are computed
!
!
netrad_sns = zicp(ji) * quatre * emis(ji) * c_stefan * ((zicp(ji) * psold(ji))**3)
sensfl_sns = un / (zikt - petAcoef(ji))
larsub_sns = chalsu0 * vbeta1(ji) * (un - vbeta5(ji)) * zicp(ji) * pdqsold(ji) / (zikq - peqAcoef(ji))
lareva_sns = chalev0 * ((un - vbeta1(ji))*(un - vbeta5(ji)) * vbeta(ji) * valpha(ji) + vbeta5(ji)) * &
& zicp(ji) * pdqsold(ji) / (zikq - peqAcoef(ji))
!
!
! Now we are solving the energy balance
!
!
sum_old = netrad(ji) + sensfl_old + larsub_old + lareva_old + soilflx(ji)
sum_sns = netrad_sns + sensfl_sns + larsub_sns + lareva_sns
dtheta = dtradia * sum_old / (zicp(ji) * soilcap(ji) + dtradia * sum_sns)
!
!
psnew(ji) = psold(ji) + dtheta
!
qsol_sat_new(ji) = qsol_sat(ji) + zicp(ji) * pdqsold(ji) * dtheta
!
temp_sol_new(ji) = psnew(ji) / cp_air
!
epot_air_new(ji) = zikt * (sensfl_old - sensfl_sns * dtheta) + psnew(ji)
!
fevap = (lareva_old - lareva_sns * dtheta) + (larsub_old - larsub_sns * dtheta)
IF ( ABS(fevap) < EPSILON(un) ) THEN
qair_new(ji) = qair(ji)
ELSE
qair_new(ji) = zikq * un / ( chalsu0 * vbeta1(ji) * (un - vbeta5(ji)) + &
& chalev0 * ((un - vbeta1(ji))*(un - vbeta5(ji)) * vbeta(ji) * valpha(ji) + vbeta5(ji)) ) &
& * fevap + qsol_sat_new(ji)
ENDIF
!
!
ENDDO
IF (long_print) WRITE (numout,*) ' enerbil_surftemp done '
END SUBROUTINE enerbil_surftemp
!! This routine computes tsol_new, netrad, vevapp, fluxlat, fluxsubli and fluxsens
!!
SUBROUTINE enerbil_flux (kjpindex, dtradia, emis, temp_sol, rau, u, v, q_cdrag, vbeta, valpha, vbeta1, vbeta5, &
! & qair, epot_air, psnew, qsurf, fluxsens, fluxlat, fluxsubli, vevapp, temp_sol_new, &
!MG
& rveget, rstruct, qair, epot_air, psnew, qsurf, fluxsens, fluxlat, fluxsubli, vevapp, temp_sol_new, &
! & lwdown, swnet, lwup, lwnet, pb, tsol_rad, netrad, evapot, evapot_corr)
!MG
& lwdown, swnet, lwup, lwnet, pb, tsol_rad, netrad, evapot, evapot_corr, etm)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT(in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: emis !! Emissivity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol !! Soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u,v !! wind
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !!
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta !! Resistance coefficient
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: valpha !! Resistance coefficient
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta1 !! Snow resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta5 !! Flood resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: epot_air !! Air potential energy
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: psnew !! New surface static energy
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
!MG
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: rveget !! Surface resistance for the vegetatuon
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: rstruct !! Structural resistance for the vegetatuon
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: qsurf !! Surface specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxsens !! Sensible chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxlat !! Latent chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxsubli !! Energy of sublimation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapp !! Total of evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: lwdown !! Downward Long-wave radiation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swnet !! Net SW radiation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: lwup !! Long-wave up radiation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: lwnet !! Long-wave net radiation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: tsol_rad !! Radiative surface temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: netrad !! Net radiation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: evapot !! Soil Potential Evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: evapot_corr !! Soil Potential Evaporation Correction
!MG
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: etm !! Max 'evapo'transpi (taking into account the veg resistance)
! local declaration
INTEGER(i_std) :: ji,jv
REAL(r_std),DIMENSION (kjpindex) :: grad_qsat
REAL(r_std) :: correction
REAL(r_std) :: speed, qc
! initialisation
!
! 1. computes temp_sol_new, netrad, vevapp, fluxlat, fluxsubli, fluxsens
!
DO ji=1,kjpindex
speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
qc = speed * q_cdrag(ji)
lwup(ji) = emis(ji) * c_stefan * temp_sol(ji)**4 + &
& quatre * emis(ji) * c_stefan * temp_sol(ji)**3 * &
& (temp_sol_new(ji) - temp_sol(ji))
!!
!! Add the reflected LW radiation
!!
lwup(ji) = lwup(ji) + (un - emis(ji)) * lwdown(ji)
!! tsol_rad(ji) = (lwup(ji)/ (emis(ji) * c_stefan)) **(1./quatre)
!! Need to check the equations
!!
tsol_rad(ji) = emis(ji) * c_stefan * temp_sol(ji)**4 + lwup(ji)
!!
!! This is a simple diagnostic which will be used by the GCM to compute the dependence of
!! of the surface layer stability on moisture.
!!
qsurf(ji) = (vbeta1(ji) * (un - vbeta5(ji)) + vbeta5(ji)) * qsol_sat_new(ji) + &
& (un - vbeta1(ji))*(un - vbeta5(ji)) * vbeta(ji) * valpha(ji) * qsol_sat_new(ji)
qsurf(ji) = MAX(qsurf(ji), qair(ji))
netrad(ji) = lwdown(ji) + swnet(ji) - lwup(ji)
vevapp(ji) = dtradia * rau(ji) * qc * (vbeta1(ji) * (un - vbeta5(ji)) + vbeta5(ji)) * &
& (qsol_sat_new(ji) - qair(ji)) + &
& dtradia * rau(ji) * qc * (un - vbeta1(ji))*(un-vbeta5(ji)) * vbeta(ji) * &
& (valpha(ji) * qsol_sat_new(ji) - qair(ji))
fluxlat(ji) = chalsu0 * rau(ji) * qc * vbeta1(ji) * (un - vbeta5(ji)) * &
& (qsol_sat_new(ji) - qair(ji)) + &
& chalev0 * rau(ji) * qc * vbeta5(ji) *&
& (qsol_sat_new(ji) - qair(ji)) + &
& chalev0 * rau(ji) * qc * (un - vbeta1(ji)) * (un - vbeta5(ji)) * vbeta(ji) * &
& (valpha(ji) * qsol_sat_new(ji) - qair(ji))
fluxsubli(ji) = chalsu0 * rau(ji) * qc * vbeta1(ji) * (un - vbeta5(ji)) * &
& (qsol_sat_new(ji) - qair(ji))
fluxsens(ji) = rau(ji) * qc * (psnew(ji) - epot_air(ji))
lwnet(ji) = lwdown(ji) - lwup(ji)
evapot(ji) = MAX(zero, dtradia * rau(ji) * qc * (qsol_sat_new(ji) - qair(ji)))
!
tair(ji) = epot_air(ji) / cp_air
!
ENDDO
! define qsat_air avec subroutine de src_parameter:
CALL qsatcalc(kjpindex, tair, pb, qsat_air)
CALL dev_qsatcalc(kjpindex, tair, pb, grad_qsat)
! grad_qsat(:)= (qsol_sat_new(:)- qsat_air(:)) / ((psnew(:) - epot_air(:)) / cp_air) ! * dtradia
!- Penser a sortir evapot en meme temps qu'evapot_corr tdo.
DO ji=1,kjpindex
speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
qc = speed * q_cdrag(ji)
IF ((evapot(ji) .GT. zero) .AND. ((psnew(ji) - epot_air(ji)) .NE. zero )) THEN
correction = (quatre * emis(ji) * c_stefan * tair(ji)**3 + rau(ji) * qc * cp_air + &
& chalev0 * rau(ji) * qc * grad_qsat(ji) * vevapp(ji) / evapot(ji) )
IF (ABS(correction) .GT. min_sechiba) THEN
correction = chalev0 * rau(ji) * qc * grad_qsat(ji) * (un - vevapp(ji)/evapot(ji)) / correction
ELSE
PRINT *, "Denominateur de la correction de milly nul! Aucune correction appliquee"
ENDIF
ELSE
correction = zero
ENDIF
correction = MAX (zero, correction)
evapot_corr(ji) = evapot(ji) / (un + correction)
!MG
!!! Calculer le etm ici avec les donnees du dessus:
DO jv = 1, nvm
etm(ji,jv) = evapot_corr(ji) / (un + qc * (rstruct(ji,jv) + rveget(ji,jv)) * &
& cp_air / (chalev0 * grad_qsat(ji) + cp_air))
ENDDO
ENDDO
IF (long_print) WRITE (numout,*) ' enerbil_flux done '
END SUBROUTINE enerbil_flux
!! This routine computes evaporation and transpiration
!!
SUBROUTINE enerbil_evapveg (kjpindex, dtradia, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, cimean, &
& ccanopy, rau, u, v, q_cdrag, qair, humrel, vevapsno, vevapnu , vevapflo, vevapwet, transpir, gpp, evapot)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT(in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta1 !! Snow resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta4 !! Bare soil resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vbeta5 !! Floodplains resistance
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: rau !! Density
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u, v !! Wind
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q_cdrag !!
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: ccanopy !! CO2 concentration in the canopy
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot !! Soil Potential Evaporation
REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (in) :: humrel !! Relative humidity
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbeta2 !! Interception resistance
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbeta3 !! Vegetation resistance
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vbetaco2 !! Vegetation resistance to CO2
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: cimean !! mean Ci
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapsno !! Snow evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapnu !! Bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapflo !! Floodplains evaporation
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: transpir !! Transpiration
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: gpp !! Assimilation, gC/m**2 total area.
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vevapwet !! Interception
! local declaration
INTEGER(i_std) :: ji, jv
REAL(r_std), DIMENSION(kjpindex) :: vbeta2sum, vbeta3sum
REAL(r_std), DIMENSION(kjpindex) :: xx
REAL(r_std) :: speed
! initialisation: utile pour calculer l'evaporation des floodplains dans lesquelles il y a de la vegetation
vbeta2sum(:) = 0.
vbeta3sum(:) = 0.
DO jv = 1, nvm
vbeta2sum(:) = vbeta2sum(:) + vbeta2(:,jv)
vbeta3sum(:) = vbeta3sum(:) + vbeta3(:,jv)
ENDDO
!
! 1. computes vevapsno, vevapnu
!
DO ji=1,kjpindex
speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
!
! 1.1 snow sublimation
!
vevapsno(ji) = (un - vbeta5(ji)) * vbeta1(ji) * dtradia * rau(ji) * speed * q_cdrag(ji) * (qsol_sat_new(ji) - qair(ji))
!
! 1.2 bare soil evaporation
!
vevapnu(ji) = (un - vbeta1(ji)) * (un-vbeta5(ji)) * vbeta4(ji) * dtradia * rau(ji) * speed * q_cdrag(ji) &
& * (qsol_sat_new(ji) - qair(ji))
!
! 1.3 floodplains evaporation - transpiration et interception prioritaires dans les floodplains
!
vevapflo(ji) = vbeta5(ji) * (1 - vbeta2sum(ji) - vbeta3sum(ji)) &
& * dtradia * rau(ji) * speed * q_cdrag(ji) * (qsol_sat_new(ji) - qair(ji))
END DO
!
! 2. computes transpir and vevapwet
!
DO ji = 1, kjpindex
!
speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
!
xx(ji) = dtradia * (un-vbeta1(ji)) * (qsol_sat_new(ji)-qair(ji)) * rau(ji) * speed * q_cdrag(ji)
!
ENDDO
!
DO jv=1,nvm
DO ji=1,kjpindex
!
! 2.1 Interception loss
!
vevapwet(ji,jv) = xx(ji) * vbeta2(ji,jv)
!
! 2.2 Transpiration
!
transpir (ji,jv) = xx(ji) * vbeta3(ji,jv)
!
END DO
END DO
!
! 3 STOMATE: Assimilation
!
IF ( control%ok_co2 ) THEN
DO jv = 1, nvm
DO ji = 1, kjpindex
speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
gpp(ji,jv) = vbetaco2(ji,jv) * dtradia * rau(ji) * speed * q_cdrag(ji) * &
(ccanopy(ji) - cimean(ji,jv)) * 12.e-6
ENDDO
ENDDO
ELSEIF ( control%stomate_watchout ) THEN
gpp(:,:) = 0.0
ENDIF
IF (long_print) WRITE (numout,*) ' enerbil_evapveg done '
END SUBROUTINE enerbil_evapveg
!! Second part of main routine for enerbil module
!! - called every time step
!!
!! Algorithm:
!! computes new soil temperature due to ice and snow melt
!!
SUBROUTINE enerbil_fusion (kjpindex, dtradia, tot_melt, soilcap, temp_sol_new, fusion )
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT(in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: tot_melt !! Total melt
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: soilcap !! Soil calorific capacity
! modified fields
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: temp_sol_new !! New soil temperature
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fusion !! Fusion
! local declaration
INTEGER(i_std) :: ji
! initialisation
IF (long_print) WRITE (numout,*) ' enerbil_fusion start ', MINVAL(soilcap), MINLOC(soilcap),&
& MAXVAL(soilcap), MAXLOC(soilcap)
!
! 1. computes new soil temperature due to ice and snow melt
!
DO ji=1,kjpindex
fusion(ji) = tot_melt(ji) * chalfu0 / dtradia
temp_sol_new(ji) = temp_sol_new(ji) - ((tot_melt(ji) * chalfu0) / soilcap(ji))
END DO
IF (long_print) WRITE (numout,*) ' enerbil_fusion done '
END SUBROUTINE enerbil_fusion
!! Diagnose 2 meter air temperature
!!
SUBROUTINE enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Air temperature in Kelvin
! modified fields
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: t2mdiag !! 2-meter temperature
t2mdiag(:) = temp_air(:)
IF (long_print) WRITE (numout,*) ' enerbil_t2mdiag done '
END SUBROUTINE enerbil_t2mdiag
END MODULE enerbil
ORCHIDEE/src_sechiba/hydrolc.f90 0000754 0103600 0005670 00000317571 11164403473 016174 0 ustar acamlmd lmdjus !!
!! This module computes hydrologic processes on continental points.
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.10 $, $Date: 2007/06/12 20:02:37 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/hydrolc.f90,v 1.10 2007/06/12 20:02:37 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE hydrolc
!
!
! routines called : restput, restget
!
USE ioipsl
!
! modules used :
USE constantes
USE constantes_soil
USE constantes_veg
USE sechiba_io
USE grid
USE parallel
! USE Write_Field_p
IMPLICIT NONE
! public routines :
! hydrol
PRIVATE
PUBLIC :: hydrolc_main,hydrolc_clear
!
! variables used inside hydrol module : declaration and initialisation
!
LOGICAL, SAVE :: l_first_hydrol=.TRUE. !! Initialisation has to be done one time
!
LOGICAL, SAVE :: ok_hdiff !! do horizontal diffusion?
CHARACTER(LEN=80) , SAVE :: file_ext !! Extention for I/O filename
CHARACTER(LEN=80) , SAVE :: var_name !! To store variables names for I/O
! one dimension array allocated, computed, saved and got in hydrol module
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: bqsb !! Hauteur d'eau dans le reservoir profond
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: gqsb !! Hauteur d'eau dans le reservoir de surface
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dsg !! Hauteur du reservoir de surface
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dsp !! Hauteur au dessus du reservoir profond
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mean_bqsb !! diagnostique du reservoir profond
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mean_gqsb !! diagnostique du reservoir de surface
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_water_beg !! Total amount of water at start of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_water_end !! Total amount of water at end of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_flux !! Total water flux
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_watveg_beg !! Total amount of water on vegetation at start of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_watveg_end !! Total amount of water on vegetation at end of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_watsoil_beg !! Total amount of water in the soil at start of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_watsoil_end !! Total amount of water in the soil at end of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snow_beg !! Total amount of snow at start of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snow_end !! Total amount of snow at end of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: delsoilmoist !! Change in soil moisture
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: delintercept !! Change in interception storage
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: delswe !! Change in SWE
! one dimension array allocated, computed and used in hydrol module exclusively
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dss !! Hauteur au dessus du reservoir de surface
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: precisol !! Eau tombee sur le sol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: subsnowveg !! Sublimation of snow on vegetation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: subsnownobio !! Sublimation of snow on other surface types (ice, lakes, ...)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snowmelt !! Quantite de neige fondue
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: icemelt !! Quantite de glace fondue
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: gdrainage !! Drainage between reservoirs
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vegtot !! Total vegetation
! The last vegetation map which was used to distribute the reservoirs
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: resdist !! Distribution of reservoirs
!! profondeur du reservoir contenant le maximum d'eau
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mx_eau_var
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: ruu_ch !! Quantite d'eau maximum
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: runoff !! Ruissellement
CONTAINS
!!
!! Main routine for *hydrol* module
!! - called only one time for initialisation
!! - called every time step
!! - called one more time at last time step for writing _restart_ file
!!
!! Algorithm:
!! - call hydrolc_snow for snow process (including age of snow)
!! - call hydrolc_canop for canopy process
!! - call hydrolc_flood for floodplain process
!! - call hydrolc_soil for bare soil process
!!
!! @call hydrolc_snow
!! @call hydrolc_canop
!! @call hydrolc_flood
!! @call hydrolc_soil
!!
SUBROUTINE hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, &
& temp_sol_new, floodout, run_off_tot, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, &
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age, tot_melt, transpir, &
& precip_rain, precip_snow, returnflow, reinfiltration,irrigation, humrel, vegstress, rsol, drysoil_frac, &
& evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, soilcap, rest_id, hist_id, hist2_id)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std),INTENT (in) :: rest_id,hist_id !! _Restart_ file and _history_ file identifier
INTEGER(i_std),INTENT (in) :: hist2_id !! _history_ file 2 identifier
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for _restart_ file to write
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in) :: indexveg !! Indeces of the points on the 3D map
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: returnflow !! Routed water which comes back into the soil
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: reinfiltration !! Routed water which comes back into the soil
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: irrigation !! Water from irrigation returning to soil moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: frac_nobio !! Fraction of ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: totfrac_nobio !! Total fraction of ice+lakes+...
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: soilcap !! Soil capacity
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vevapwet !! Interception loss
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: frac_bare !! Fraction of bare soil in each vegetation type
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintmax !! Maximum water on vegetation for interception
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: transpir !! Transpiration
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot !! Soil Potential Evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot_corr !! Soil Potential Evaporation Correction
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: flood_frac !! Flooded fraction
! modified fields
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: flood_res !! Flood reservoir estimate
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: vevapnu !! Bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: vevapsno !! Snow evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: vevapflo !! Snow evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: snow !! Snow mass [Kg/m^2]
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: snow_age !! Snow age
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio !! Water balance on ice, lakes, .. [Kg/m^2]
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio_age !! Snow age on ice, lakes, ...
!! We consider that any water on the ice is snow and we only peforme a water balance to have consistency.
!! The water balance is limite to + or - 10^6 so that accumulation is not endless
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: floodout !! flux out of floodplains
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: run_off_tot !! Complete runoff
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: drainage !! Drainage
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: humrel !! Relative humidity
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vegstress !! Veg. moisture stress (only for vegetation growth)
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: rsol !! Resistance to bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: drysoil_frac !! Fraction of visibly dry soil (between 0 and 1)
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: shumdiag !! relative soil moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: litterhumdiag !! litter humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: tot_melt !! Total melt
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: qsintveg !! Water on vegetation due to interception
!
! local declaration
!
REAL(r_std),DIMENSION (kjpindex) :: soilwet !! A temporary diagnostic of soil wetness
REAL(r_std),DIMENSION (kjpindex) :: snowdepth !! Depth of snow layer
!
! do initialisation
!
IF (l_first_hydrol) THEN
IF (long_print) WRITE (numout,*) ' l_first_hydrol : call hydrolc_init '
CALL hydrolc_init (kjit, ldrestart_read, kjpindex, index, rest_id, veget, humrel, vegstress, &
& snow, snow_age, snow_nobio, snow_nobio_age, qsintveg)
CALL hydrolc_var_init (kjpindex, veget, rsol, drysoil_frac, mx_eau_var, ruu_ch, shumdiag, litterhumdiag)
!
! If we check the water balance we first save the total amount of water
!
IF (check_waterbal) THEN
CALL hydrolc_waterbal(kjpindex, index, .TRUE., dtradia, veget, totfrac_nobio, qsintveg, snow, snow_nobio,&
& precip_rain, precip_snow, returnflow, reinfiltration, irrigation, tot_melt, vevapwet, transpir, &
& vevapnu, vevapsno, vevapflo, floodout,run_off_tot, drainage)
ENDIF
!
IF (almaoutput) THEN
CALL hydrolc_alma(kjpindex, index, .TRUE., qsintveg, snow, snow_nobio, soilwet)
ENDIF
!
! shared time step
!
IF (long_print) WRITE (numout,*) 'hydrolc pas de temps = ',dtradia
RETURN
ENDIF
!
! prepares restart file for the next simulation
!
IF (ldrestart_write) THEN
IF (long_print) WRITE (numout,*) ' we have to complete restart file with HYDROLOGIC variables '
var_name= 'humrel'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, humrel, 'scatter', nbp_glo, index_g)
!
var_name= 'vegstress'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, vegstress, 'scatter', nbp_glo, index_g)
!
var_name= 'snow'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, snow, 'scatter', nbp_glo, index_g)
!
var_name= 'snow_age'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, snow_age, 'scatter', nbp_glo, index_g)
!
var_name= 'snow_nobio'
CALL restput_p(rest_id, var_name, nbp_glo, nnobio, 1, kjit, snow_nobio, 'scatter', nbp_glo, index_g)
!
var_name= 'snow_nobio_age'
CALL restput_p(rest_id, var_name, nbp_glo, nnobio, 1, kjit, snow_nobio_age, 'scatter', nbp_glo, index_g)
!
var_name= 'bqsb'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, bqsb, 'scatter', nbp_glo, index_g)
!
var_name= 'gqsb'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, gqsb, 'scatter', nbp_glo, index_g)
!
var_name= 'dsg'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, dsg, 'scatter', nbp_glo, index_g)
!
var_name= 'dsp'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, dsp, 'scatter', nbp_glo, index_g)
!
var_name= 'qsintveg'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, qsintveg, 'scatter', nbp_glo, index_g)
!
var_name= 'resdist'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, resdist, 'scatter', nbp_glo, index_g)
RETURN
!
END IF
!
! computes snow
!
CALL hydrolc_snow(kjpindex, dtradia, precip_rain, precip_snow, temp_sol_new, soilcap, &
& frac_nobio, totfrac_nobio, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
& tot_melt, snowdepth)
!
! computes canopy
!
!
CALL hydrolc_vegupd(kjpindex, veget, ruu_ch, qsintveg, gqsb, bqsb, dsg, dss,dsp, resdist)
!
CALL hydrolc_canop(kjpindex, precip_rain, vevapwet, veget, qsintmax, qsintveg, precisol)
!
! computes surface reservoir
!
CALL hydrolc_flood(kjpindex, dtradia, vevapnu, vevapflo, flood_frac, flood_res, floodout)
!
! computes hydro_soil
!
CALL hydrolc_soil(kjpindex, vevapnu, precisol, returnflow, reinfiltration, irrigation, tot_melt, mx_eau_var, veget, &
& frac_bare, ruu_ch, transpir, gqsb, bqsb, dsg, dss, rsol, drysoil_frac, dsp, runoff, run_off_tot, drainage, humrel, &
& vegstress, shumdiag, litterhumdiag)
!
! computes horizontal diffusion between the water reservoirs
!
IF ( ok_hdiff ) THEN
CALL hydrolc_hdiff(kjpindex, dtradia, veget, ruu_ch, gqsb, bqsb, dsg, dss, dsp)
ENDIF
!
! If we check the water balance we end with the comparison of total water change and fluxes
!
IF (check_waterbal) THEN
CALL hydrolc_waterbal(kjpindex, index, .FALSE., dtradia, veget, totfrac_nobio, qsintveg, snow, snow_nobio,&
& precip_rain, precip_snow, returnflow, reinfiltration, irrigation, tot_melt, vevapwet, transpir, vevapnu, vevapsno,&
& vevapflo, floodout, run_off_tot, drainage )
ENDIF
!
! If we use the ALMA standards
!
IF (almaoutput) THEN
CALL hydrolc_alma(kjpindex, index, .FALSE., qsintveg, snow, snow_nobio, soilwet)
ENDIF
!
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'bqsb', kjit, mean_bqsb, kjpindex, index)
CALL histwrite(hist_id, 'gqsb', kjit, mean_gqsb, kjpindex, index)
CALL histwrite(hist_id, 'runoff', kjit, run_off_tot, kjpindex, index)
CALL histwrite(hist_id, 'drainage', kjit, drainage, kjpindex, index)
CALL histwrite(hist_id, 'floodout', kjit, floodout, kjpindex, index)
CALL histwrite(hist_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'rain', kjit, precip_rain, kjpindex, index)
CALL histwrite(hist_id, 'snowf', kjit, precip_snow, kjpindex, index)
CALL histwrite(hist_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'humrel', kjit, humrel, kjpindex*nvm, indexveg)
ELSE
CALL histwrite(hist_id, 'Snowf', kjit, precip_snow, kjpindex, index)
CALL histwrite(hist_id, 'Rainf', kjit, precip_rain, kjpindex, index)
CALL histwrite(hist_id, 'Qs', kjit, run_off_tot, kjpindex, index)
CALL histwrite(hist_id, 'Qsb', kjit, drainage, kjpindex, index)
CALL histwrite(hist_id, 'Qsm', kjit, tot_melt, kjpindex, index)
CALL histwrite(hist_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
CALL histwrite(hist_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
!
CALL histwrite(hist_id, 'SoilMoist', kjit, tot_watsoil_end, kjpindex, index)
CALL histwrite(hist_id, 'SoilWet', kjit, soilwet, kjpindex, index)
!
CALL histwrite(hist_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
CALL histwrite(hist_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
!
CALL histwrite(hist_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
!
ENDIF
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist2_id, 'bqsb', kjit, mean_bqsb, kjpindex, index)
CALL histwrite(hist2_id, 'gqsb', kjit, mean_gqsb, kjpindex, index)
CALL histwrite(hist2_id, 'runoff', kjit, run_off_tot, kjpindex, index)
CALL histwrite(hist2_id, 'drainage', kjit, drainage, kjpindex, index)
CALL histwrite(hist2_id, 'floodout', kjit, floodout, kjpindex, index)
CALL histwrite(hist2_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'rain', kjit, precip_rain, kjpindex, index)
CALL histwrite(hist2_id, 'snowf', kjit, precip_snow, kjpindex, index)
CALL histwrite(hist2_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'humrel', kjit, humrel, kjpindex*nvm, indexveg)
!
IF (check_waterbal) THEN
CALL histwrite(hist2_id, 'TotWater', kjit, tot_water_end, kjpindex, index)
CALL histwrite(hist2_id, 'TotWaterFlux', kjit, tot_flux, kjpindex, index)
ENDIF
ELSE
CALL histwrite(hist2_id, 'Snowf', kjit, precip_snow, kjpindex, index)
CALL histwrite(hist2_id, 'Rainf', kjit, precip_rain, kjpindex, index)
CALL histwrite(hist2_id, 'Qs', kjit, run_off_tot, kjpindex, index)
CALL histwrite(hist2_id, 'Qsb', kjit, drainage, kjpindex, index)
CALL histwrite(hist2_id, 'Qsm', kjit, tot_melt, kjpindex, index)
CALL histwrite(hist2_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
CALL histwrite(hist2_id, 'DelSWE', kjit, delswe, kjpindex, index)
CALL histwrite(hist2_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
!
CALL histwrite(hist2_id, 'SoilMoist', kjit, tot_watsoil_end, kjpindex, index)
CALL histwrite(hist2_id, 'SoilWet', kjit, soilwet, kjpindex, index)
!
CALL histwrite(hist2_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
CALL histwrite(hist2_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
!
CALL histwrite(hist2_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
!
ENDIF
ENDIF
!
IF (long_print) WRITE (numout,*) ' hydrolc_main Done '
END SUBROUTINE hydrolc_main
!! Algorithm:
!! - dynamic allocation for local array
!! - _restart_ file reading for HYDROLOGIC variables
!!
SUBROUTINE hydrolc_init(kjit, ldrestart_read, kjpindex, index, rest_id, veget, humrel, vegstress, &
& snow, snow_age, snow_nobio, snow_nobio_age, qsintveg)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjit !! Time step number
LOGICAL,INTENT (in) :: ldrestart_read !! Logical for _restart_ file to read
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std), INTENT (in) :: rest_id !! _Restart_ file identifier
! input fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Carte de vegetation
! output fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: humrel !! Stress hydrique, relative humidity
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vegstress !! Veg. moisture stress (only for vegetation growth)
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: snow !! Snow mass [Kg/m^2]
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: snow_age !! Snow age
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: snow_nobio !! Snow on ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: snow_nobio_age !! Snow age on ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: qsintveg !! Water on vegetation due to interception
! local declaration
INTEGER(i_std) :: ier,ipdt
INTEGER(i_std) :: ji,jv,ik
REAL(r_std), DIMENSION (kjpindex,nvm) :: zdsp
REAL(r_std), ALLOCATABLE, DIMENSION (:,:) :: dsp_g
REAL(r_std), ALLOCATABLE, DIMENSION (:,:) :: zdsp_g
! initialisation
IF (l_first_hydrol) THEN
l_first_hydrol=.FALSE.
ELSE
WRITE (numout,*) ' l_first_hydrol false . we stop '
STOP 'hydrolc_init'
ENDIF
!Config Key = HYDROL_OK_HDIFF
!Config Desc = do horizontal diffusion?
!Config Def = n
!Config Help = If TRUE, then water can diffuse horizontally between
!Config the PFTs' water reservoirs.
ok_hdiff = .FALSE.
CALL getin_p('HYDROL_OK_HDIFF',ok_hdiff)
! make dynamic allocation with good dimension
! one dimension array allocation with possible restart value
ALLOCATE (bqsb(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in bqsb allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (gqsb(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in gqsb allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (dsg(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in dsg allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (dsp(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in dsp allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
! one dimension array allocation
ALLOCATE (mean_bqsb(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in mean_bqsb allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (mean_gqsb(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in mean_gqsb allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (dss(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in dss allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (precisol(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in precisol allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (gdrainage(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in precisol allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (subsnowveg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in subsnowveg allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (subsnownobio(kjpindex,nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in subsnownobio allocation. We stop. We need kjpindex*nnobio words = ', &
kjpindex*nnobio
STOP 'hydrolc_init'
END IF
ALLOCATE (snowmelt(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snowmelt allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (icemelt(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in icemelt allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (mx_eau_var(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in mx_eau_var allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (ruu_ch(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in ruu_ch allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (vegtot(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vegtot allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'hydrolc_init'
END IF
ALLOCATE (resdist(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in resdist allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'hydrolc_init'
END IF
ALLOCATE (runoff(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in runoff allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'hydrolc_init'
END IF
!
! If we check the water balance we need two more variables
!
IF ( check_waterbal ) THEN
ALLOCATE (tot_water_beg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_water_beg allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (tot_water_end(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_water_end allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (tot_flux(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_flux allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ENDIF
!
! If we use the almaoutputs we need four more variables
!
IF ( almaoutput ) THEN
ALLOCATE (tot_watveg_beg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_watveg_beg allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (tot_watveg_end(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_watveg_end allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (tot_watsoil_beg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_watsoil_beg allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (tot_watsoil_end(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_watsoil_end allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (delsoilmoist(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in delsoilmoist allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (delintercept(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in delintercept. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (delswe(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in delswe. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrolc_init'
ENDIF
ALLOCATE (snow_beg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_beg allocation. We stop. We need kjpindex words =',kjpindex
STOP 'hydrolc_init'
END IF
ALLOCATE (snow_end(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_end allocation. We stop. We need kjpindex words =',kjpindex
STOP 'hydrolc_init'
END IF
ENDIF
! open restart input file done by sechiba_init
! and read data from restart input file for HYDROLOGIC process
IF (ldrestart_read) THEN
IF (long_print) WRITE (numout,*) ' we have to read a restart file for HYDROLOGIC variables'
var_name= 'snow'
CALL ioconf_setatt('UNITS', 'kg/m^2')
CALL ioconf_setatt('LONG_NAME','Snow mass')
CALL restget_p (rest_id, var_name, nbp_glo, 1 , 1, kjit, .TRUE., snow, "gather", nbp_glo, index_g)
!!$ ! correction for old restart
!!$ DO ik=1, kjpindex
!!$ if(snow(ik).gt.maxmass_glacier) snow(ik)=maxmass_glacier
!!$ ENDDO
!
var_name= 'snow_age'
CALL ioconf_setatt('UNITS', 'd')
CALL ioconf_setatt('LONG_NAME','Snow age')
CALL restget_p (rest_id, var_name, nbp_glo, 1 , 1, kjit, .TRUE., snow_age, "gather", nbp_glo, index_g)
!
var_name= 'snow_nobio'
CALL ioconf_setatt('UNITS', 'kg/m^2')
CALL ioconf_setatt('LONG_NAME','Snow on other surface types')
CALL restget_p (rest_id, var_name, nbp_glo, nnobio , 1, kjit, .TRUE., snow_nobio, "gather", nbp_glo, index_g)
!!$ ! correction for old restart
!!$ DO ik=1, kjpindex
!!$ if(snow_nobio(ik,iice).gt.maxmass_glacier) snow_nobio(ik,iice)=maxmass_glacier
!!$ ENDDO
!
var_name= 'snow_nobio_age'
CALL ioconf_setatt('UNITS', 'd')
CALL ioconf_setatt('LONG_NAME','Snow age on other surface types')
CALL restget_p (rest_id, var_name, nbp_glo, nnobio , 1, kjit, .TRUE., snow_nobio_age, "gather", nbp_glo, index_g)
!
var_name= 'humrel'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Soil moisture stress')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., humrel, "gather", nbp_glo, index_g)
!
var_name= 'vegstress'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Vegetation growth moisture stress')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., vegstress, "gather", nbp_glo, index_g)
!
var_name= 'bqsb'
CALL ioconf_setatt('UNITS', 'kg/m^2')
CALL ioconf_setatt('LONG_NAME','Deep soil moisture')
CALL restget_p (rest_id, var_name, nbp_glo, nvm , 1, kjit, .TRUE., bqsb, "gather", nbp_glo, index_g)
!
var_name= 'gqsb'
CALL ioconf_setatt('UNITS', 'kg/m^2')
CALL ioconf_setatt('LONG_NAME','Surface soil moisture')
CALL restget_p (rest_id, var_name, nbp_glo, nvm , 1, kjit, .TRUE., gqsb, "gather", nbp_glo, index_g)
!
var_name= 'dsg'
CALL ioconf_setatt('UNITS', 'm')
CALL ioconf_setatt('LONG_NAME','Depth of upper reservoir')
CALL restget_p (rest_id, var_name, nbp_glo, nvm , 1, kjit, .TRUE., dsg, "gather", nbp_glo, index_g)
!
var_name= 'dsp'
CALL ioconf_setatt('UNITS', 'm')
CALL ioconf_setatt('LONG_NAME','Depth to lower reservoir')
CALL restget_p (rest_id, var_name, nbp_glo, nvm , 1, kjit, .TRUE., dsp, "gather", nbp_glo, index_g)
!
var_name= 'qsintveg'
CALL ioconf_setatt('UNITS', 'kg/m^2')
CALL ioconf_setatt('LONG_NAME','Intercepted moisture')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., qsintveg, "gather", nbp_glo, index_g)
!
var_name= 'resdist'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Distribution of reservoirs')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., resdist, "gather", nbp_glo, index_g)
!
! get restart values if non were found in the restart file
!
!Config Key = HYDROL_SNOW
!Config Desc = Initial snow mass if not found in restart
!Config Def = 0.0
!Config Help = The initial value of snow mass if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', 0.0_r_std)
!
!Config Key = HYDROL_SNOWAGE
!Config Desc = Initial snow age if not found in restart
!Config Def = 0.0
!Config Help = The initial value of snow age if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (snow_age, val_exp, 'HYDROL_SNOWAGE', 0.0_r_std)
!
!Config Key = HYDROL_SNOW_NOBIO
!Config Desc = Initial snow amount on ice, lakes, etc. if not found in restart
!Config Def = 0.0
!Config Help = The initial value of snow if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (snow_nobio, val_exp, 'HYDROL_SNOW_NOBIO', 0.0_r_std)
!
!Config Key = HYDROL_SNOW_NOBIO_AGE
!Config Desc = Initial snow age on ice, lakes, etc. if not found in restart
!Config Def = 0.0
!Config Help = The initial value of snow age if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (snow_nobio_age, val_exp, 'HYDROL_SNOW_NOBIO_AGE', 0.0_r_std)
!
!Config Key = HYDROL_HUMR
!Config Desc = Initial soil moisture stress if not found in restart
!Config Def = 1.0
!Config Help = The initial value of soil moisture stress if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (humrel, val_exp,'HYDROL_HUMR', 1.0_r_std)
CALL setvar_p (vegstress, val_exp,'HYDROL_HUMR', 1.0_r_std)
!
!Config Key = HYDROL_SOIL_DEPTH
!Config If = NOT CWRR
!Config Desc = Total depth of soil reservoir
!Config Def = 2.
!
dpu_cste=2.
CALL getin_p ("HYDROL_SOIL_DEPTH", dpu_cste)
!
!Config Key = HYDROL_BQSB
!Config Desc = Initial restart deep soil moisture if not found in restart
!Config Def = DEF
!Config Help = The initial value of deep soil moisture if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file. Default behaviour is a saturated soil.
!
CALL setvar_p (bqsb, val_exp, 'HYDROL_BQSB', mx_eau_eau*dpu_cste)
!
!Config Key = HYDROL_GQSB
!Config Desc = Initial upper soil moisture if not found in restart
!Config Def = 0.0
!Config Help = The initial value of upper soil moisture if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (gqsb, val_exp, 'HYDROL_GQSB', 0.0_r_std)
!
!Config Key = HYDROL_DSG
!Config Desc = Initial upper reservoir depth if not found in restart
!Config Def = 0.0
!Config Help = The initial value of upper reservoir depth if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (dsg, val_exp, 'HYDROL_DSG', 0.0_r_std)
! set inital value for dsp if needed
!
!Config Key = HYDROL_DSP
!Config Desc = Initial dry soil above upper reservoir if not found in restart
!Config Def = DEF
!Config Help = The initial value of dry soil above upper reservoir if its value
!Config is not found in the restart file. This should only be used if
!Config the model is started without a restart file. The default behaviour
!Config is to compute it from the variables above. Should be OK most of
!Config the time.
!
zdsp(:,:) = dpu_cste - bqsb(:,:) / mx_eau_eau
dsp(1,1) = val_exp
call getin_p('HYDROL_DSP', dsp(1,1))
IF (dsp(1,1) == val_exp) THEN
dsp(:,:) = zdsp(:,:)
ELSE
IF (is_root_prc) &
ALLOCATE(zdsp_g(nbp_glo,nvm),dsp_g(nbp_glo,nvm))
CALL gather(zdsp,zdsp_g)
IF (is_root_prc) &
CALL setvar (dsp_g, val_exp, 'HYDROL_DSP', zdsp_g)
CALL scatter(dsp_g,dsp)
IF (is_root_prc) &
DEALLOCATE(zdsp_g, dsp_g)
ENDIF
!
!Config Key = HYDROL_QSV
!Config Desc = Initial water on canopy if not found in restart
!Config Def = 0.0
!Config Help = The initial value of moisture on canopy if its value
!Config is not found in the restart file. This should only be used if
!Config the model is started without a restart file.
!
CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', 0.0_r_std)
dss = dsg - gqsb / mx_eau_eau
!
! There is no need to configure the initialisation of resdist. If not available it is the vegetation map
!
IF ( MINVAL(resdist) .EQ. MAXVAL(resdist) .AND. MINVAL(resdist) .EQ. val_exp) THEN
resdist = veget
ENDIF
!
! Remember that it is only frac_nobio + SUM(veget(,:)) that is equal to 1. Thus we need vegtot
!
DO ji = 1, kjpindex
vegtot(ji) = SUM(veget(ji,:))
ENDDO
!
ENDIF
!
! Where vegetation fraction is zero, set water to that of bare soil.
! This does not create any additional water.
!
DO jv = 2, nvm
DO ji = 1, kjpindex
IF ( veget(ji,jv) .LT. EPSILON(un) ) THEN
gqsb(ji,jv) = gqsb(ji,1)
bqsb(ji,jv) = bqsb(ji,1)
dsg(ji,jv) = dsg(ji,1)
dss(ji,jv) = dss(ji,1)
dsp(ji,jv) = dsp(ji,1)
ENDIF
ENDDO
ENDDO
!
DO ik=1, kjpindex
if(snow(ik).gt.maxmass_glacier) then
WRITE(6,*)' il faut diminuer le stock de neige car snow > maxmass_glacier dans restart'
snow(ik)=maxmass_glacier
endif
if(snow_nobio(ik,iice).gt.maxmass_glacier) then
WRITE(6,*)' il faut diminuer le stock de neige car snow_nobio > maxmass_glacier dans restart'
snow_nobio(ik,iice)=maxmass_glacier
endif
ENDDO
!
IF (long_print) WRITE (numout,*) ' hydrolc_init done '
!
END SUBROUTINE hydrolc_init
!
!-------------------------------------
!
SUBROUTINE hydrolc_clear()
l_first_hydrol=.TRUE.
IF (ALLOCATED (bqsb)) DEALLOCATE (bqsb)
IF (ALLOCATED (gqsb)) DEALLOCATE (gqsb)
IF (ALLOCATED (dsg)) DEALLOCATE (dsg)
IF (ALLOCATED (dsp)) DEALLOCATE (dsp)
IF (ALLOCATED (mean_bqsb)) DEALLOCATE (mean_bqsb)
IF (ALLOCATED (mean_gqsb)) DEALLOCATE (mean_gqsb)
IF (ALLOCATED (dss)) DEALLOCATE (dss)
IF (ALLOCATED (precisol)) DEALLOCATE (precisol)
IF (ALLOCATED (gdrainage)) DEALLOCATE (gdrainage)
IF (ALLOCATED (subsnowveg)) DEALLOCATE (subsnowveg)
IF (ALLOCATED (subsnownobio)) DEALLOCATE (subsnownobio)
IF (ALLOCATED (snowmelt)) DEALLOCATE (snowmelt)
IF (ALLOCATED (icemelt)) DEALLOCATE (icemelt)
IF (ALLOCATED (mx_eau_var)) DEALLOCATE (mx_eau_var)
IF (ALLOCATED (ruu_ch)) DEALLOCATE (ruu_ch)
IF (ALLOCATED (vegtot)) DEALLOCATE (vegtot)
IF (ALLOCATED (resdist)) DEALLOCATE (resdist)
IF (ALLOCATED (runoff)) DEALLOCATE (runoff)
IF (ALLOCATED (tot_water_beg)) DEALLOCATE (tot_water_beg)
IF (ALLOCATED (tot_water_end)) DEALLOCATE (tot_water_end)
IF (ALLOCATED (tot_flux)) DEALLOCATE (tot_flux)
IF (ALLOCATED (tot_watveg_beg)) DEALLOCATE (tot_watveg_beg)
IF (ALLOCATED (tot_watveg_end)) DEALLOCATE (tot_watveg_end)
IF (ALLOCATED (tot_watsoil_beg)) DEALLOCATE (tot_watsoil_beg)
IF (ALLOCATED (tot_watsoil_end)) DEALLOCATE (tot_watsoil_end)
IF (ALLOCATED (delsoilmoist)) DEALLOCATE (delsoilmoist)
IF (ALLOCATED (delintercept)) DEALLOCATE (delintercept)
IF (ALLOCATED (snow_beg)) DEALLOCATE (snow_beg)
IF (ALLOCATED (snow_end)) DEALLOCATE (snow_end)
IF (ALLOCATED (delswe)) DEALLOCATE (delswe)
!
END SUBROUTINE hydrolc_clear
!! This routine initializes HYDROLOGIC variables
!! - mx_eau_var
!! - ruu_ch
!!
SUBROUTINE hydrolc_var_init (kjpindex, veget, rsol, drysoil_frac, mx_eau_var, ruu_ch, shumdiag, litterhumdiag)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation type
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: rsol !! Resistance to bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: drysoil_frac !! Fraction of visible dry soil
!! Profondeur du reservoir contenant le maximum d'eau
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: mx_eau_var !!
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: ruu_ch !! Quantite d'eau maximum
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: shumdiag !! relative soil moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: litterhumdiag !! litter humidity
! local declaration
INTEGER(i_std) :: ji,jv, jd
REAL(r_std), DIMENSION(kjpindex) :: mean_dsg
REAL(r_std) :: gtr, btr
REAL(r_std), DIMENSION(nbdl+1) :: tmp_dl
!
! initialisation
tmp_dl(1) = 0
tmp_dl(2:nbdl+1) = diaglev(1:nbdl)
!
mx_eau_var(:) = 0.0
!
DO ji = 1,kjpindex
DO jv = 1,nvm
mx_eau_var(ji) = mx_eau_var(ji) + veget(ji,jv)*wmax_veg(jv)*dpu_cste
END DO
IF (vegtot(ji) .GT. zero) THEN
mx_eau_var(ji) = mx_eau_var(ji)/vegtot(ji)
ELSE
mx_eau_var(ji) = mx_eau_eau*dpu_cste
ENDIF
ruu_ch(ji) = mx_eau_var(ji) / dpu_cste
END DO
!
!
! could be done with SUM instruction but this kills vectorization
mean_bqsb(:) = 0.0
mean_gqsb(:) = 0.0
mean_dsg(:) = 0.0
DO jv = 1, nvm
DO ji = 1, kjpindex
mean_bqsb(ji) = mean_bqsb(ji) + resdist(ji,jv)*bqsb(ji,jv)
mean_gqsb(ji) = mean_gqsb(ji) + resdist(ji,jv)*gqsb(ji,jv)
mean_dsg(ji) = mean_dsg(ji) + resdist(ji,jv)*dsg(ji,jv)
ENDDO
ENDDO
mean_dsg(:) = MAX( mean_dsg(:), mean_gqsb(:)/ruu_ch(:) )
DO ji = 1, kjpindex
IF (vegtot(ji) .GT. zero) THEN
mean_bqsb(ji) = mean_bqsb(ji)/vegtot(ji)
mean_gqsb(ji) = mean_gqsb(ji)/vegtot(ji)
mean_dsg(ji) = mean_dsg(ji)/vegtot(ji)
ENDIF
ENDDO
DO ji = 1,kjpindex
!
DO jd = 1,nbdl
IF ( tmp_dl(jd+1) .LT. mean_dsg(ji)) THEN
shumdiag(ji,jd) = mean_gqsb(ji)/mx_eau_var(ji)
ELSE
IF ( tmp_dl(jd) .LT. mean_dsg(ji)) THEN
gtr = (mean_dsg(ji)-tmp_dl(jd))/(tmp_dl(jd+1)-tmp_dl(jd))
btr = 1 - gtr
shumdiag(ji,jd) = gtr*mean_gqsb(ji)/mx_eau_var(ji) + &
& btr*mean_bqsb(ji)/mx_eau_var(ji)
ELSE
shumdiag(ji,jd) = mean_bqsb(ji)/mx_eau_var(ji)
ENDIF
ENDIF
shumdiag(ji,jd) = MAX(MIN(shumdiag(ji,jd), un), zero)
ENDDO
ENDDO
!
! litter humidity.
!
DO ji = 1, kjpindex
litterhumdiag(ji) = EXP( - dss(ji,1) / hcrit_litter )
ENDDO
! special case: it has just been raining a few drops. The upper soil
! reservoir is ridiculously small, but the dry soil height is zero.
! Don't take it into account.
DO ji = 1, kjpindex
IF ( ( dss(ji,1) .LT. min_sechiba ) .AND. &
( mean_dsg(ji) .GT. min_sechiba ) .AND. &
( mean_dsg(ji) .LT. 5.E-4 ) ) THEN
litterhumdiag(ji) = 0.0
ENDIF
ENDDO
! The fraction of soil which is visibly dry (dry when dss = 0.1 m)
drysoil_frac(:) = MIN(MAX(dss(:,1),0.)*10._r_std, un)
!
! Compute the resistance to bare soil evaporation
!
rsol(:) = -un
DO ji = 1, kjpindex
IF (veget(ji,1) .GE. min_sechiba) THEN
!
! Correction Nathalie - le 28 mars 2006 - sur conseils Fred Hourdin
! on modifie le rsol pour que la resistance croisse subitement si on s'approche
! du fond. En gros, rsol=hdry*rsol_cste pour hdry < 1m70
!Ancienne formulation
rsol(ji) = dss(ji,1) * rsol_cste
!Nouvelle formulation Nath
!rsol(ji) = ( drysoil_frac(ji) + 1./(10.*(dpu_cste - drysoil_frac(ji))+1.e-10)**2 ) * rsol_cste
ENDIF
ENDDO
!
IF (long_print) WRITE (numout,*) ' hydrolc_var_init done '
END SUBROUTINE hydrolc_var_init
!! This routine computes snow processes
!!
SUBROUTINE hydrolc_snow (kjpindex, dtradia, precip_rain, precip_snow , temp_sol_new, soilcap,&
& frac_nobio, totfrac_nobio, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
& tot_melt, snowdepth)
!
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: precip_rain !! Rainfall
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: precip_snow !! Snow precipitation
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: temp_sol_new !! New soil temperature
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: soilcap !! Soil capacity
REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio !! Fraction of continental ice, lakes, ...
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: totfrac_nobio !! Total fraction of continental ice+lakes+ ...
! modified fields
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: vevapnu !! Bare soil evaporation
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: vevapsno !! Snow evaporation
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: snow !! Snow mass [Kg/m^2]
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: snow_age !! Snow age
REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout) :: snow_nobio !! Ice water balance
REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout) :: snow_nobio_age!! Snow age on ice, lakes, ...
! output fields
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: tot_melt !! Total melt
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: snowdepth !! Snow depth
!
! local declaration
!
INTEGER(i_std) :: ji, jv
REAL(r_std), DIMENSION (kjpindex) :: d_age !! Snow age change
REAL(r_std), DIMENSION (kjpindex) :: xx !! temporary
REAL(r_std) :: snowmelt_tmp !! The name says it all !
LOGICAL, DIMENSION (kjpindex) :: warnings
LOGICAL :: any_warning
!
! for continental points
!
!
! 0. initialisation
!
DO jv = 1, nnobio
DO ji=1,kjpindex
subsnownobio(ji,jv) = zero
ENDDO
ENDDO
DO ji=1,kjpindex
subsnowveg(ji) = zero
snowmelt(ji) = zero
icemelt(ji) = zero
tot_melt(ji) = zero
ENDDO
!
! 1. On vegetation
!
!cdir NODEP
DO ji=1,kjpindex
!
! 1.1. It is snowing
!
snow(ji) = snow(ji) + (un - totfrac_nobio(ji))*precip_snow(ji)
ENDDO
!
DO ji=1,kjpindex
!
! 1.2. Sublimation - separate between vegetated and no-veget fractions
! Care has to be taken as we might have sublimation from the
! the frac_nobio while there is no snow on the rest of the grid.
!
IF ( snow(ji) > snowcri ) THEN
subsnownobio(ji,iice) = frac_nobio(ji,iice)*vevapsno(ji)
subsnowveg(ji) = vevapsno(ji) - subsnownobio(ji,iice)
ELSE
! Correction Nathalie - Juillet 2006.
! On doit d'abord tester s'il existe un frac_nobio!
! Pour le moment je ne regarde que le iice
IF ( frac_nobio(ji,iice) .GT. min_sechiba) THEN
subsnownobio(ji,iice) = vevapsno(ji)
subsnowveg(ji) = zero
ELSE
subsnownobio(ji,iice) = zero
subsnowveg(ji) = vevapsno(ji)
ENDIF
ENDIF
ENDDO
!
warnings(:) = .FALSE.
any_warning = .FALSE.
!cdir NODEP
DO ji=1,kjpindex
!
! 1.2.1 Check that sublimation on the vegetated fraction is possible.
!
IF (subsnowveg(ji) .GT. snow(ji)) THEN
! What could not be sublimated goes into bare soil evaporation
! Nathalie - Juillet 2006 - il faut avant tout tester s'il existe du
! frac_nobio sur ce pixel pour eviter de puiser dans le sol!
IF ( frac_nobio(ji,iice) .GT. min_sechiba) THEN
subsnownobio(ji,iice) = subsnownobio(ji,iice) + (subsnowveg(ji) - snow(ji))
ELSE
vevapnu(ji) = vevapnu(ji) + (subsnowveg(ji) - snow(ji))
warnings(ji) = .TRUE.
any_warning = .TRUE.
ENDIF
! Sublimation is thus limited to what is available
subsnowveg(ji) = snow(ji)
snow(ji) = zero
vevapsno(ji) = subsnowveg(ji) + subsnownobio(ji,iice)
ELSE
snow(ji) = snow(ji) - subsnowveg(ji)
ENDIF
ENDDO
IF ( any_warning ) THEN
DO ji=1,kjpindex
IF ( warnings(ji) ) THEN
WRITE(numout,*)' ATTENTION on prend de l eau au sol nu car evapsno est trop fort!'
WRITE(numout,*)' ',ji,' vevapnu (en mm/jour) = ',vevapnu(ji)*one_day/dtradia
ENDIF
ENDDO
ENDIF
!
warnings(:) = .FALSE.
any_warning = .FALSE.
!cdir NODEP
DO ji=1,kjpindex
!
! 1.3. snow melt only if temperature positive
!
IF (temp_sol_new(ji).GT.tp_00) THEN
!
IF (snow(ji).GT.sneige) THEN
!
snowmelt(ji) = (1. - frac_nobio(ji,iice))*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0
!
! 1.3.1.1 enough snow for melting or not
!
IF (snowmelt(ji).LT.snow(ji)) THEN
snow(ji) = snow(ji) - snowmelt(ji)
ELSE
snowmelt(ji) = snow(ji)
snow(ji) = zero
END IF
!
ELSEIF (snow(ji).GE.zero) THEN
!
! 1.3.2 not enough snow
!
snowmelt(ji) = snow(ji)
snow(ji) = zero
ELSE
!
! 1.3.3 negative snow - now snow melt
!
snow(ji) = zero
snowmelt(ji) = zero
warnings(ji) = .TRUE.
any_warning = .TRUE.
!
END IF
ENDIF
ENDDO
IF ( any_warning ) THEN
DO ji=1,kjpindex
IF ( warnings(ji) ) THEN
WRITE(numout,*) 'hydrolc_snow: WARNING! snow was negative and was reset to zero for point ',ji,'. '
ENDIF
ENDDO
ENDIF
!
DO ji=1,kjpindex
!
! 1.4. Ice melt only if there is more than a given mass : maxmass_glacier,
! i.e. only weight melts glaciers !
! Ajouts Edouard Davin / Nathalie de Noblet add extra to melting
!
IF ( snow(ji) .GT. maxmass_glacier ) THEN
snowmelt(ji) = snowmelt(ji) + (snow(ji) - maxmass_glacier)
snow(ji) = maxmass_glacier
ENDIF
!
END DO
!
! 2. On Land ice
!
DO ji=1,kjpindex
!
! 2.1. It is snowing
!
snow_nobio(ji,iice) = snow_nobio(ji,iice) + frac_nobio(ji,iice)*precip_snow(ji) + &
& frac_nobio(ji,iice)*precip_rain(ji)
!
! 2.2. Sublimation - was calculated before it can give us negative snow_nobio but that is OK
! Once it goes below a certain values (-maxmass_glacier for instance) we should kill
! the frac_nobio(ji,iice) !
!
snow_nobio(ji,iice) = snow_nobio(ji,iice) - subsnownobio(ji,iice)
!
! 2.3. snow melt only for continental ice fraction
!
snowmelt_tmp = zero
IF (temp_sol_new(ji) .GT. tp_00) THEN
!
! 2.3.1 If there is snow on the ice-fraction it can melt
!
snowmelt_tmp = frac_nobio(ji,iice)*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0
!
IF ( snowmelt_tmp .GT. snow_nobio(ji,iice) ) THEN
snowmelt_tmp = MAX( zero, snow_nobio(ji,iice))
ENDIF
snowmelt(ji) = snowmelt(ji) + snowmelt_tmp
snow_nobio(ji,iice) = snow_nobio(ji,iice) - snowmelt_tmp
!
ENDIF
!
! 2.4 Ice melt only if there is more than a given mass : maxmass_glacier,
! i.e. only weight melts glaciers !
!
IF ( snow_nobio(ji,iice) .GT. maxmass_glacier ) THEN
icemelt(ji) = snow_nobio(ji,iice) - maxmass_glacier
snow_nobio(ji,iice) = maxmass_glacier
ENDIF
!
END DO
!
! 3. On other surface types - not done yet
!
IF ( nnobio .GT. 1 ) THEN
WRITE(numout,*) 'WE HAVE',nnobio-1,' SURFACE TYPES I DO NOT KNOW'
WRITE(numout,*) 'CANNOT TREAT SNOW ON THESE SURFACE TYPES'
STOP 'in hydrolc_snow'
ENDIF
!
! 4. computes total melt (snow and ice)
!
DO ji = 1, kjpindex
tot_melt(ji) = icemelt(ji) + snowmelt(ji)
ENDDO
!
! 5. computes snow age on veg and ice (for albedo)
!
DO ji = 1, kjpindex
!
! 5.1 Snow age on vegetation
!
IF (snow(ji) .LE. zero) THEN
snow_age(ji) = zero
ELSE
snow_age(ji) =(snow_age(ji) + (un - snow_age(ji)/max_snow_age) * dtradia/one_day) &
& * EXP(-precip_snow(ji) / snow_trans)
ENDIF
!
! 5.2 Snow age on ice
!
! age of snow on ice: a little bit different because in cold regions, we really
! cannot negect the effect of cold temperatures on snow metamorphism any more.
!
IF (snow_nobio(ji,iice) .LE. zero) THEN
snow_nobio_age(ji,iice) = zero
ELSE
!
d_age(ji) = ( snow_nobio_age(ji,iice) + &
& (un - snow_nobio_age(ji,iice)/max_snow_age) * dtradia/one_day ) * &
& EXP(-precip_snow(ji) / snow_trans) - snow_nobio_age(ji,iice)
IF (d_age(ji) .GT. 0. ) THEN
xx(ji) = MAX( tp_00 - temp_sol_new(ji), zero )
xx(ji) = ( xx(ji) / 7._r_std ) ** 4._r_std
d_age(ji) = d_age(ji) / (un+xx(ji))
ENDIF
snow_nobio_age(ji,iice) = MAX( snow_nobio_age(ji,iice) + d_age(ji), zero )
!
ENDIF
ENDDO
!
! 6.0 Diagnose the depth of the snow layer
!
DO ji = 1, kjpindex
snowdepth(ji) = snow(ji) /sn_dens
ENDDO
IF (long_print) WRITE (numout,*) ' hydrolc_snow done '
END SUBROUTINE hydrolc_snow
!! This routine computes canopy processes
!!
SUBROUTINE hydrolc_canop (kjpindex, precip_rain, vevapwet, veget, qsintmax, qsintveg, precisol)
!
! interface description
!
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: precip_rain !! Rain precipitation
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in) :: vevapwet !! Interception loss
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in) :: veget !! Fraction of vegetation type
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in) :: qsintmax !! Maximum water on vegetation for interception
! modified fields
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: qsintveg !! Water on vegetation due to interception
! output fields
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out) :: precisol !! Eau tombee sur le sol
!
! local declaration
!
INTEGER(i_std) :: ji, jv
REAL(r_std), DIMENSION (kjpindex,nvm) :: zqsintvegnew
LOGICAL, SAVE :: firstcall=.TRUE.
REAL(r_std), SAVE, DIMENSION(nvm) :: throughfall_by_pft
IF ( firstcall ) THEN
!Config Key = PERCENT_THROUGHFALL_PFT
!Config Desc = Percent by PFT of precip that is not intercepted by the canopy
!Config Def = 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30.
!Config Help = During one rainfall event, PERCENT_THROUGHFALL_PFT% of the incident rainfall
!Config will get directly to the ground without being intercepted, for each PFT.
throughfall_by_pft = (/ 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30. /)
CALL getin_p('PERCENT_THROUGHFALL_PFT',throughfall_by_pft)
throughfall_by_pft = throughfall_by_pft / 100.
firstcall=.FALSE.
ENDIF
! calcul de qsintmax a prevoir a chaque pas de temps
! dans ini_sechiba
! boucle sur les points continentaux
! calcul de qsintveg au pas de temps suivant
! par ajout du flux interception loss
! calcule par enerbil en fonction
! des calculs faits dans diffuco
! calcul de ce qui tombe sur le sol
! avec accumulation dans precisol
! essayer d'harmoniser le traitement du sol nu
! avec celui des differents types de vegetation
! fait si on impose qsintmax ( ,1) = 0.0
!
! loop for continental subdomain
!
!
! 1. evaporation off the continents
!
! 1.1 The interception loss is take off the canopy.
DO jv=1,nvm
qsintveg(:,jv) = qsintveg(:,jv) - vevapwet(:,jv)
END DO
! 1.2 It is raining : precip_rain is shared for each vegetation
! type
! sum (veget (1,nvm)) must be egal to 1-totfrac_nobio.
! iniveget computes veget each day
!
DO jv=1,nvm
! Correction Nathalie - Juin 2006 - une partie de la pluie arrivera toujours sur le sol
! sorte de throughfall supplementaire
!Ancienne formulation
qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * precip_rain(:)
!Nouvelle formulation Nath
!qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * ((1-throughfall_by_pft(jv))*precip_rain(:))
END DO
!
! 1.3 Limits the effect and sum what receives soil
!
precisol(:,:) = zero
DO jv=1,nvm
DO ji = 1, kjpindex
zqsintvegnew(ji,jv) = MIN (qsintveg(ji,jv),qsintmax(ji,jv))
! correction throughfall Nathalie - Juin 2006
!Ancienne formulation
precisol(ji,jv) = qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
!Nouvelle formulation Nath
!precisol(ji,jv) = (veget(ji,jv)*throughfall_by_pft(jv)*precip_rain(ji)) + qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
ENDDO
ENDDO
!
! 1.4 swap qsintveg to the new value
!
DO jv=1,nvm
qsintveg(:,jv) = zqsintvegnew (:,jv)
END DO
IF (long_print) WRITE (numout,*) ' hydrolc_canop done '
END SUBROUTINE hydrolc_canop
!!
!!
!!
SUBROUTINE hydrolc_vegupd(kjpindex, veget, ruu_ch, qsintveg, gqsb, bqsb, dsg, dss, dsp, resdist)
!
!
! The vegetation cover has changed and we need to adapt the reservoir distribution.
! You may note that this occurs after evaporation and so on have been computed. It is
! not a problem as a new vegetation fraction will start with humrel=0 and thus will have no
! evaporation. If this is not the case it should have been caught above.
!
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex
! input fields
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in) :: veget !! New vegetation map
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: ruu_ch !! Quantite d'eau maximum
! modified fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: qsintveg !! Water on vegetation due to interception
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: gqsb !! Hauteur d'eau dans le reservoir de surface
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: bqsb !! Hauteur d'eau dans le reservoir profond
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsg !! Hauteur du reservoir de surface
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dss !! Hauteur au dessus du reservoir de surface
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsp !! Hauteur au dessus du reservoir profond
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(inout) :: resdist !! Old vegetation map
!
!
! local declaration
!
INTEGER(i_std) :: ji,jv
!
REAL(r_std),DIMENSION (kjpindex,nvm) :: qsintveg2 !! Water on vegetation due to interception over old veget
REAL(r_std), DIMENSION (kjpindex,nvm) :: bdq, gdq, qsdq
REAL(r_std), DIMENSION (kjpindex,nvm) :: vmr !! variation of veget
REAL(r_std), DIMENSION(kjpindex) :: gtr, btr, vtr, qstr, fra
REAL(r_std), DIMENSION(kjpindex) :: vegchtot
REAL(r_std), PARAMETER :: EPS1 = EPSILON(un)
!
!
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( ABS(veget(ji,jv)-resdist(ji,jv)) .GT. EPS1 ) THEN
vmr(ji,jv) = veget(ji,jv)-resdist(ji,jv)
ELSE
vmr(ji,jv) = 0.0
ENDIF
!
IF (resdist(ji,jv) .GT. 0.) THEN
qsintveg2(ji,jv) = qsintveg(ji,jv)/resdist(ji,jv)
ELSE
qsintveg2(ji,jv) = zero
ENDIF
ENDDO
ENDDO
!
vegchtot(:) = 0.
DO jv = 1, nvm
DO ji = 1, kjpindex
vegchtot(ji) = vegchtot(ji) + ABS( vmr(ji,jv) )
ENDDO
ENDDO
!
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( vegchtot(ji) .GT. 0. ) THEN
gdq(ji,jv) = ABS(vmr(ji,jv)) * gqsb(ji,jv)
bdq(ji,jv) = ABS(vmr(ji,jv)) * bqsb(ji,jv)
qsdq(ji,jv) = ABS(vmr(ji,jv)) * qsintveg2(ji,jv)
ENDIF
ENDDO
ENDDO
!
! calculate water mass that we have to redistribute
!
gtr(:) = zero
btr(:) = zero
qstr(:) = zero
vtr(:) = zero
!
!
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( ( vegchtot(ji) .GT. 0. ) .AND. ( vmr(ji,jv) .LT. 0. ) ) THEN
gtr(ji) = gtr(ji) + gdq(ji,jv)
btr(ji) = btr(ji) + bdq(ji,jv)
qstr(ji) = qstr(ji) + qsdq(ji,jv)
vtr(ji) = vtr(ji) - vmr(ji,jv)
ENDIF
ENDDO
ENDDO
!
! put it into reservoir of plant whose surface area has grown
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( vegchtot(ji) .GT. 0. .AND. ABS(vtr(ji)) .GT. EPS1) THEN
fra(ji) = vmr(ji,jv) / vtr(ji)
IF ( vmr(ji,jv) .GT. 0.) THEN
IF (veget(ji,jv) .GT. 0.) THEN
gqsb(ji,jv) = (resdist(ji,jv)*gqsb(ji,jv) + fra(ji)*gtr(ji))/veget(ji,jv)
bqsb(ji,jv) = (resdist(ji,jv)*bqsb(ji,jv) + fra(ji)*btr(ji))/veget(ji,jv)
ENDIF
qsintveg(ji,jv) = qsintveg(ji,jv) + fra(ji)* qstr(ji)
ELSE
qsintveg(ji,jv) = qsintveg(ji,jv) - qsdq(ji,jv)
ENDIF
!
! dss is not altered so that this transfer of moisture does not directly
! affect transpiration
IF (gqsb(ji,jv) .LT. min_sechiba) THEN
dsg(ji,jv) = 0.0
ELSE
dsg(ji,jv) = (dss(ji,jv) * ruu_ch(ji) + gqsb(ji,jv)) &
/ ruu_ch(ji)
ENDIF
dsp(ji,jv) = dpu_cste - bqsb(ji,jv) / ruu_ch(ji)
ENDIF
ENDDO
ENDDO
! Now that the work is done resdist needs an update !
DO jv = 1, nvm
resdist(:,jv) = veget(:,jv)
ENDDO
!
! Where vegetation fraction is zero, set water to that of bare soil.
! This does not create any additional water.
!
DO jv = 2, nvm
DO ji = 1, kjpindex
IF ( veget(ji,jv) .LT. EPS1 ) THEN
gqsb(ji,jv) = gqsb(ji,1)
bqsb(ji,jv) = bqsb(ji,1)
dsg(ji,jv) = dsg(ji,1)
dss(ji,jv) = dss(ji,1)
dsp(ji,jv) = dsp(ji,1)
ENDIF
ENDDO
ENDDO
RETURN
!
END SUBROUTINE hydrolc_vegupd
!!
!! this routine computes the evolution of the surface reservoir (floodplain)
!!
SUBROUTINE hydrolc_flood (kjpindex, dtradia, vevapnu, vevapflo, flood_frac, flood_res, floodout)
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex
! input fields
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: flood_frac !! Fraction of floodplains in grid box
! modified fields
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: floodout !! Flux to take out from floodplains
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: flood_res !! Floodplains reservoir estimate
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: vevapnu !! Bare soil evaporation
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: vevapflo !! Evaporation over floodplains
! local declaration
INTEGER(i_std) :: ji, jst, jv !! indices
REAL(r_std) :: k_m !! conductivity in the soil
REAL(r_std) :: temp !!
!-
!- 1. Take out vevapflo from the reservoir and transfer the remaining to vevapnu
!-
DO ji = 1,kjpindex
temp = MIN(flood_res(ji), vevapflo(ji))
flood_res(ji) = flood_res(ji) - temp
vevapnu(ji) = vevapnu(ji) + vevapflo(ji) - temp
vevapflo(ji) = temp
ENDDO
!-
!- 2. Compute the total flux from floodplain floodout (transfered to routing)
!-
DO ji = 1,kjpindex
floodout(ji) = vevapflo(ji) - flood_frac(ji) * SUM(precisol(ji,:))
ENDDO
!-
!- 3. Discriminate between precip over land and over floodplain
!-
DO jv=1, nvm
DO ji = 1,kjpindex
precisol(ji,jv) = precisol(ji,jv) * (1 - flood_frac(ji))
ENDDO
ENDDO
IF (long_print) WRITE (numout,*) ' hydrol_flood done'
END SUBROUTINE hydrolc_flood
!!
!! This routines computes soil processes
!!
SUBROUTINE hydrolc_soil(kjpindex, vevapnu, precisol, returnflow, reinfiltration, irrigation, tot_melt, mx_eau_var, &
& veget, frac_bare, ruu_ch, transpir,gqsb, bqsb, dsg, dss, rsol, drysoil_frac, dsp, runoff, run_off_tot, drainage, &
& humrel, vegstress, shumdiag, litterhumdiag)
!
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex
! input fields
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: vevapnu !! Bare soil evaporation
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in) :: precisol !! Eau tombee sur le sol
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: returnflow !! Water returning to the deep reservoir
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: reinfiltration !! Water returning to the top reservoir
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: irrigation !! Irrigation
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: tot_melt !! Total melt
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: mx_eau_var !! Profondeur du reservoir contenant le
!! maximum d'eau
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in) :: veget !! Vegetation map
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in) :: frac_bare !! Bare soil fraction in each tile
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: ruu_ch !! Quantite d'eau maximum
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in) :: transpir !! Transpiration
! modified fields
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: gqsb !! Hauteur d'eau dans le reservoir de surface
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: bqsb !! Hauteur d'eau dans le reservoir profond
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsg !! Hauteur du reservoir de surface
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dss !! Hauteur au dessus du reservoir de surface
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsp !! Hauteur au dessus du reservoir profond
! output fields
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out) :: runoff !! Ruissellement
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: run_off_tot !! Complete runoff
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: drainage !! Drainage
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out) :: humrel !! Relative humidity
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out) :: vegstress !! Veg. moisture stress (only for vegetation growth)
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out) :: shumdiag !! relative soil moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: litterhumdiag !! litter humidity
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: rsol !! resistance to bare soil evaporation
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: drysoil_frac !! Fraction of visible fry soil
!
! local declaration
!
INTEGER(i_std) :: ji,jv, jd
REAL(r_std), DIMENSION(kjpindex) :: zhumrel_lo, zhumrel_up
REAL(r_std), DIMENSION(kjpindex,nvm) :: zeflux !! Soil evaporation
REAL(r_std), DIMENSION(kjpindex,nvm) :: zpreci !! Soil precipitation
LOGICAL, DIMENSION(kjpindex,nvm) :: warning
REAL(r_std) :: gtr, btr
REAL(r_std), DIMENSION(kjpindex) :: mean_dsg
LOGICAL :: OnceMore
INTEGER(i_std), PARAMETER :: nitermax = 100
INTEGER(i_std) :: niter
INTEGER(i_std) :: nbad
LOGICAL, DIMENSION(kjpindex,nvm) :: lbad
REAL(r_std) :: gqseuil , eausup, wd1
REAL(r_std), DIMENSION(nbdl+1) :: tmp_dl
REAL(r_std), DIMENSION(kjpindex) :: tot_frac_bare
! Ajout Nathalie - le 28 Mars 2006 - sur conseils Fred Hourdin
! Modifs stabilite
REAL(r_std), PARAMETER :: dsg_min = 0.001
REAL(r_std), DIMENSION(kjpindex,nvm) :: a_subgrd
!
! 0. we have only one flux field corresponding to water evaporated from the surface
!
DO jv=1,nvm
DO ji = 1, kjpindex
IF ( veget(ji,jv) .GT. zero ) THEN
zeflux(ji,jv) = transpir(ji,jv)/veget(ji,jv)
zpreci(ji,jv) = precisol(ji,jv)/veget(ji,jv)
ELSE
zeflux(ji,jv) = zero
zpreci(ji,jv) = zero
ENDIF
ENDDO
ENDDO
!
! We need a test on the bare soil fraction because we can have bare soil evaporation even when
! there is no bare soil because of transfers (snow for instance). This should only apply if there
! is vegetation but we do not test this case.
!
tot_frac_bare(:) = zero
DO jv = 1, nvm
DO ji = 1, kjpindex
tot_frac_bare(ji) = tot_frac_bare(ji) + veget(ji,jv) * frac_bare(ji,jv)
ENDDO
ENDDO
! case 1 and 2 are treated in the same loop (vegetation with or without bare soil)
DO ji = 1, kjpindex
IF (vegtot(ji) .GT. zero) THEN
IF (tot_frac_bare(ji) .GT. min_sechiba) THEN
zeflux(ji,:) = zeflux(ji,:) + vevapnu(ji) * frac_bare(ji,:) / tot_frac_bare(ji)
ELSE
zeflux(ji,:) = zeflux(ji,:) + vevapnu(ji)/vegtot(ji)
ENDIF
ENDIF
ENDDO
!
! 0.1 Other temporary variables
!
tmp_dl(1) = 0
tmp_dl(2:nbdl+1) = diaglev(1:nbdl)
!
!
! 1.1 Transpiration for each vegetation type
! Evaporated water is taken out of the ground.
!
!
DO jv=1,nvm
DO ji=1,kjpindex
!
gqsb(ji,jv) = gqsb(ji,jv) - zeflux(ji,jv)
!
! 1.2 Add snow and ice melt, troughfall from vegetation, reinfiltration and irrigation.
!
IF(vegtot(ji) .NE. zero) THEN
! snow and ice melt, reinfiltration and troughfall from vegetation
gqsb(ji,jv) = gqsb(ji,jv) + zpreci(ji,jv) + (tot_melt(ji)+reinfiltration(ji))/vegtot(ji)
!
! We take care to add the irrigation only to the vegetated part if possible
!
IF (ABS(vegtot(ji)-veget(ji,1)) .LE. min_sechiba) THEN
gqsb(ji,jv) = gqsb(ji,jv) + irrigation(ji)/vegtot(ji)
ELSE
IF ( jv > 1 ) THEN
! Only add the irrigation to the upper soil if there is a reservoir.
! Without this the water evaporates right away.
IF ( gqsb(ji,jv) > zero ) THEN
gqsb(ji,jv) = gqsb(ji,jv) + irrigation(ji)/(vegtot(ji)-veget(ji,1))
ELSE
bqsb(ji,jv) = bqsb(ji,jv) + irrigation(ji)/(vegtot(ji)-veget(ji,1))
ENDIF
ENDIF
ENDIF
!
! 1.3 We add the water returned from rivers to the lower reservoir.
!
bqsb(ji,jv) = bqsb(ji,jv) + returnflow(ji)/vegtot(ji)
!
ENDIF
!
END DO
ENDDO
!
! 1.3 Computes run-off
!
runoff(:,:) = zero
!
! 1.4 Soil moisture is updated
!
warning(:,:) = .FALSE.
DO jv=1,nvm
DO ji = 1, kjpindex
!
runoff(ji,jv) = MAX(gqsb(ji,jv) + bqsb(ji,jv) - mx_eau_var(ji), zero)
!
IF (mx_eau_var(ji) .LE. (gqsb(ji,jv) + bqsb(ji,jv))) THEN
!
! 1.4.1 Plus de reservoir de surface: le sol est sature
! d'eau. Le reservoir de surface est inexistant
! Tout est dans le reservoir de fond.
! Le ruissellement correspond a ce qui deborde.
!
gqsb(ji,jv) = zero
dsg(ji,jv) = zero
bqsb(ji,jv) = mx_eau_var(ji)
dsp(ji,jv) = zero
dss(ji,jv) = dsp (ji,jv)
ELSEIF ((gqsb(ji,jv) + bqsb(ji,jv)).GE.zero) THEN
!
IF (gqsb(ji,jv) .GT. dsg(ji,jv) * ruu_ch(ji)) THEN
!
! 1.4.2 On agrandit le reservoir de surface
! car il n y a pas eu ruissellement
! et toute l'eau du reservoir de surface
! tient dans un reservoir dont la taille
! est plus importante que l actuel.
! La hauteur de sol sec dans le reservoir
! de surface est alors nulle.
! Le reste ne bouge pas.
!
dsg(ji,jv) = gqsb(ji,jv) / ruu_ch(ji)
dss(ji,jv) = zero
ELSEIF (gqsb(ji,jv) .GT. zero ) THEN
!
! 1.4.3 L eau tient dans le reservoir de surface
! tel qu il existe.
! Calcul de la nouvelle hauteur de sol sec
! dans la couche de surface.
! Le reste ne bouge pas.
!
dss(ji,jv) = ((dsg(ji,jv) * ruu_ch(ji)) - gqsb(ji,jv)) / ruu_ch(ji)
ELSE
!
! 1.4.4 La quantite d eau du reservoir de surface
! est negative. Cela revient a enlever
! cette quantite au reservoir profond.
! Le reservoir de surface est alors vide.
! (voir aussi 1.4.1)
!
bqsb(ji,jv) = bqsb(ji,jv) + gqsb(ji,jv)
dsp(ji,jv) = dpu_cste - bqsb(ji,jv) / ruu_ch(ji)
gqsb(ji,jv) = zero
dsg(ji,jv) = zero
dss(ji,jv) = dsp(ji,jv)
END IF
ELSE
!
! 1.4.5 Le reservoir profond est aussi asseche.
! La quantite d eau a enlever depasse la quantite
! disponible dans le reservoir profond.
!
!
! Ceci ne devrait jamais arriver plus d'une fois par point. C-a-d une fois la valeur negative
! atteinte les flux doivent etre nuls. On ne signal que ce cas donc.
!
IF ( ( zeflux(ji,jv) .GT. 0.0 ) .AND. &
( gqsb(ji,jv) + bqsb(ji,jv) .LT. -1.e-10 ) ) THEN
warning(ji,jv) = .TRUE.
! WRITE (numout,*) 'WARNING! Soil Moisture will be negative'
! WRITE (numout,*) 'ji, jv = ', ji,jv
! WRITE (numout,*) 'mx_eau_var = ', mx_eau_var(ji)
! WRITE (numout,*) 'veget, resdist =', veget(ji,jv), resdist(ji,jv)
! WRITE (numout,*) 'bqsb = ', bqsb(ji,jv)
! WRITE (numout,*) 'gqsb = ', gqsb(ji,jv)
! WRITE (numout,*) 'dss = ', dss(ji,jv)
! WRITE (numout,*) 'dsg = ', dsg(ji,jv)
! WRITE (numout,*) 'dsp = ', dsp(ji,jv)
! WRITE (numout,*) 'humrel = ', humrel(ji, jv)
! WRITE (numout,*) 'Soil evaporation = ', zeflux(ji,jv)
! WRITE (numout,*) 'input = ',precisol(ji, jv), tot_melt(ji)
! WRITE (numout,*) '============================'
ENDIF
!
bqsb(ji,jv) = gqsb(ji,jv) + bqsb(ji,jv)
dsp(ji,jv) = dpu_cste
gqsb(ji,jv) = zero
dsg(ji,jv) = zero
dss(ji,jv) = dsp(ji,jv)
!
ENDIF
!
ENDDO
ENDDO
!
nbad = COUNT( warning(:,:) .EQV. .TRUE. )
IF ( nbad .GT. 0 ) THEN
WRITE(numout,*) 'hydrolc_soil: WARNING! Soil moisture was negative at', &
nbad, ' points:'
!DO jv = 1, nvm
! DO ji = 1, kjpindex
! IF ( warning(ji,jv) ) THEN
! WRITE(numout,*) ' ji,jv = ', ji,jv
! WRITE (numout,*) 'mx_eau_var = ', mx_eau_var(ji)
! WRITE (numout,*) 'veget, resdist =', veget(ji,jv), resdist(ji,jv)
! WRITE (numout,*) 'bqsb = ', bqsb(ji,jv)
! WRITE (numout,*) 'gqsb = ', gqsb(ji,jv)
! WRITE (numout,*) 'runoff = ',runoff(ji,jv)
! WRITE (numout,*) 'dss = ', dss(ji,jv)
! WRITE (numout,*) 'dsg = ', dsg(ji,jv)
! WRITE (numout,*) 'dsp = ', dsp(ji,jv)
! WRITE (numout,*) 'humrel = ', humrel(ji, jv)
! WRITE (numout,*) 'Soil evaporation = ', zeflux(ji,jv)
! WRITE (numout,*) 'Soil precipitation = ',zpreci(ji,jv)
! WRITE (numout,*) 'input = ',precisol(ji, jv), tot_melt(ji)
! WRITE (numout,*) 'returnflow = ',returnflow(ji)
! WRITE (numout,*) '============================'
! ENDIF
! ENDDO
!ENDDO
ENDIF
!
! 2.0 Very large upper reservoirs or very close upper and lower reservoirs
! can be deadlock situations for Choisnel. They are handled here
!
IF (long_print) WRITE(numout,*) 'hydro_soil 2.0 : Resolve deadlocks'
DO jv=1,nvm
DO ji=1,kjpindex
!
! 2.1 the two reservoirs are very close to each other
!
IF ( ABS(dsp(ji,jv)-dsg(ji,jv)) .LT. min_resdis ) THEN
bqsb(ji,jv) = bqsb(ji,jv) + gqsb(ji,jv)
dsp(ji,jv) = dpu_cste - bqsb(ji,jv) / ruu_ch(ji)
gqsb(ji,jv) = zero
dsg(ji,jv) = zero
dss(ji,jv) = dsp(ji,jv)
ENDIF
!
! 2.2 Draine some water from the upper to the lower reservoir
!
gqseuil = min_resdis * deux * ruu_ch(ji)
eausup = dsg(ji,jv) * ruu_ch(ji)
wd1 = .75*eausup
!
IF (eausup .GT. gqseuil) THEN
gdrainage(ji,jv) = min_drain * (gqsb(ji,jv)/eausup)
!
IF ( gqsb(ji,jv) .GE. wd1 .AND. dsg(ji,jv) .GT. 0.10 ) THEN
!
gdrainage(ji,jv) = gdrainage(ji,jv) + &
(max_drain-min_drain)*((gqsb(ji,jv)-wd1) / (eausup-wd1))**exp_drain
!
ENDIF
!
gdrainage(ji,jv)=MIN(gdrainage(ji,jv), MAX(gqsb(ji,jv), zero))
!
ELSE
gdrainage(ji,jv)=zero
ENDIF
!
gqsb(ji,jv) = gqsb(ji,jv) - gdrainage(ji,jv)
bqsb(ji,jv) = bqsb(ji,jv) + gdrainage(ji,jv)
dsg(ji,jv) = dsg(ji,jv) - gdrainage(ji,jv) / ruu_ch(ji)
dsp(ji,jv) = dpu_cste - bqsb(ji,jv)/ruu_ch(ji)
!
!
ENDDO
!
ENDDO
!
! 3.0 Diffusion of water between the reservoirs of the different plants
!
IF (long_print) WRITE(numout,*) 'hydrolc_soil 3.0 : Vertical diffusion'
mean_bqsb(:) = 0.
mean_gqsb(:) = 0.
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( vegtot(ji) .GT. zero ) THEN
mean_bqsb(ji) = mean_bqsb(ji) + veget(ji,jv)/vegtot(ji)*bqsb(ji,jv)
mean_gqsb(ji) = mean_gqsb(ji) + veget(ji,jv)/vegtot(ji)*gqsb(ji,jv)
ENDIF
ENDDO
ENDDO
OnceMore = .TRUE.
niter = 0
! nitermax prevents infinite loops (should actually never occur)
DO WHILE ( OnceMore .AND. ( niter .LT. nitermax ) )
!
niter = niter + 1
!
! where do we have to do something?
lbad(:,:) = ( ( dsp(:,:) .LT. dsg(:,:) ) .AND. &
( dsg(:,:) .GT. zero ) .AND. &
( veget(:,:) .GT. zero ) )
!
! if there are no such points any more, we'll do no more iteration
IF ( COUNT( lbad(:,:) ) .EQ. 0 ) OnceMore = .FALSE.
!
DO jv = 1, nvm
!
DO ji = 1, kjpindex
IF ( veget(ji,jv) .GT. 0. ) THEN
!
bqsb(ji,jv) = mean_bqsb(ji)
dsp(ji,jv) = dpu_cste - bqsb(ji,jv)/ruu_ch(ji)
ENDIF
!
ENDDO
!
DO ji = 1, kjpindex
IF ( lbad(ji,jv) ) THEN
!
runoff(ji,jv) = runoff(ji,jv) + &
MAX( bqsb(ji,jv) + gqsb(ji,jv) - mx_eau_var(ji), zero)
!
bqsb(ji,jv) = MIN( bqsb(ji,jv) + gqsb(ji,jv), mx_eau_var(ji))
!
gqsb(ji,jv) = zero
dsp(ji,jv) = dpu_cste - bqsb(ji,jv)/ruu_ch(ji)
dss(ji,jv) = dsp(ji,jv)
dsg(ji,jv) = zero
!
ENDIF
ENDDO
!
ENDDO
!
mean_bqsb(:) = 0.
mean_gqsb(:) = 0.
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( vegtot(ji) .GT. zero ) THEN
mean_bqsb(ji) = mean_bqsb(ji) + veget(ji,jv)/vegtot(ji)*bqsb(ji,jv)
mean_gqsb(ji) = mean_gqsb(ji) + veget(ji,jv)/vegtot(ji)*gqsb(ji,jv)
ENDIF
ENDDO
ENDDO
!
ENDDO
!
! 4. computes total runoff
!
IF (long_print) WRITE(numout,*) 'hydro_soil 4.0: Computes total runoff'
run_off_tot(:) = zero
DO ji = 1, kjpindex
IF ( vegtot(ji) .GT. zero ) THEN
DO jv = 1, nvm
run_off_tot(ji) = run_off_tot(ji) + (runoff(ji,jv)*veget(ji,jv))
ENDDO
ELSE
run_off_tot(ji) = tot_melt(ji) + irrigation(ji) + reinfiltration(ji)
ENDIF
ENDDO
!
! 4.1 We estimate some drainage !
drainage(:) = 0.95 * run_off_tot(:)
run_off_tot(:) = run_off_tot(:) - drainage(:)
!
! 5. Some averaged diagnostics
!
IF (long_print) WRITE(numout,*) 'hydro_soil 5.0: Diagnostics'
!
! 5.1 reset dsg if necessary
!
WHERE (gqsb(:,:) .LE. zero) dsg(:,:) = zero
!
DO ji=1,kjpindex
!
! 5.2 Compute an average moisture profile
!
mean_dsg(ji) = mean_gqsb(ji)/ruu_ch(ji)
!
ENDDO
!
! 6. Compute the moisture stress on vegetation
!
IF (long_print) WRITE(numout,*) 'hydro_soil 6.0 : Moisture stress'
a_subgrd(:,:) = zero
DO jv = 1, nvm
DO ji=1,kjpindex
!
! computes relative surface humidity
!
! Only use the standard formulas if total soil moisture is larger than zero.
! Else stress functions are set to zero.
! This will avoid that large negative soil moisture accumulate over time by the
! the creation of small skin reservoirs which evaporate quickly.
!
IF ( gqsb(ji,jv)+bqsb(ji,jv) .GT. zero ) THEN
!
IF (dsg(ji,jv).EQ. zero .OR. gqsb(ji,jv).EQ.zero) THEN
humrel(ji,jv) = EXP( - humcste(jv) * dpu_cste * (dsp(ji,jv)/dpu_cste) )
dsg(ji,jv) = zero
!
! if the dry soil height is larger than the one corresponding
! to the wilting point, or negative lower soil moisture : humrel is 0.0
!
IF (dsp(ji,jv).GT.(dpu_cste - (qwilt / ruu_ch(ji))) .OR. bqsb(ji,jv).LT.zero) THEN
humrel(ji,jv) = zero
ENDIF
!
! In this case we can take for vegetation growth the same values for humrel and vegstress
!
vegstress(ji,jv) = humrel(ji,jv)
!
ELSE
! Corrections Nathalie - le 28 Mars 2006 - sur conseils Fred Hourdin
!Ancienne formulation
zhumrel_lo(ji) = EXP( - humcste(jv) * dpu_cste * (dsp(ji,jv)/dpu_cste) )
zhumrel_up(ji) = EXP( - humcste(jv) * dpu_cste * (dss(ji,jv)/dsg(ji,jv)) )
humrel(ji,jv) = MAX(zhumrel_lo(ji),zhumrel_up(ji))
!
! As we need a slower variable for vegetation growth the stress is computed
! differently than in humrel.
!
!Nouvelle formulation Nathalie
!zhumrel_lo(ji) = EXP( - humcste(jv) * dsp(ji,jv))
!zhumrel_up(ji) = EXP( - humcste(jv) * dss(ji,jv))
! Ajouts Nathalie - Fred - le 28 Mars 2006
!a_subgrd(ji,jv)=MIN(MAX(dsg(ji,jv)-dss(ji,jv),0.)/dsg_min,1.)
!humrel(ji,jv)=a_subgrd(ji,jv)*zhumrel_up(ji)+(1.-a_subgrd(ji,jv))*zhumrel_lo(ji)
!
vegstress(ji,jv) = zhumrel_lo(ji) + zhumrel_up(ji) - EXP( - humcste(jv) * dsg(ji,jv) )
!
ENDIF
!
ELSE
!
humrel(ji,jv) = zero
vegstress(ji,jv) = zero
!
ENDIF
!
ENDDO
ENDDO
!
! 7. Diagnostics which are needed to carry information to other modules
!
! 7.2 Relative soil moisture
!
DO jd = 1,nbdl
DO ji = 1, kjpindex
IF ( tmp_dl(jd+1) .LT. mean_dsg(ji)) THEN
shumdiag(ji,jd) = mean_gqsb(ji)/mx_eau_var(ji)
ELSE
IF ( tmp_dl(jd) .LT. mean_dsg(ji)) THEN
gtr = (mean_dsg(ji)-tmp_dl(jd))/(tmp_dl(jd+1)-tmp_dl(jd))
btr = 1 - gtr
shumdiag(ji,jd) = gtr*mean_gqsb(ji)/mx_eau_var(ji) + &
& btr*mean_bqsb(ji)/mx_eau_var(ji)
ELSE
shumdiag(ji,jd) = mean_bqsb(ji)/mx_eau_var(ji)
ENDIF
ENDIF
shumdiag(ji,jd) = MAX(MIN(shumdiag(ji,jd), un), zero)
ENDDO
ENDDO
!
! 8. litter humidity.
!
litterhumdiag(:) = EXP( - dss(:,1) / hcrit_litter )
! special case: it has just been raining a few drops. The upper soil
! reservoir is ridiculously small, but the dry soil height is zero.
! Don't take it into account.
WHERE ( ( dss(:,1) .LT. min_sechiba ) .AND. &
( mean_dsg(:) .GT. min_sechiba ) .AND. ( mean_dsg(:) .LT. 5.E-4 ) )
litterhumdiag(:) = 0.0
ENDWHERE
! The fraction of visibly dry soil (dry when dss(:,1) = 0.1 m)
! Correction Nathalie - le 28 Mars 2006 - re-ecriture drysoil_frac/hdry - Fred Hourdin
!Ancienne formulation
drysoil_frac(:) = MIN(MAX(dss(:,1),0.)*10._r_std, un)
!Nouvelle formulation Nathalie
!drysoil_frac(:) = a_subgrd(:,1)*dss(:,1) + (1.-a_subgrd(:,1))*dsp(:,1)
!
! Compute the resistance to bare soil evaporation.
!
rsol(:) = -un
DO ji = 1, kjpindex
!MG selon tristan le 10.01.08
! IF (veget(ji,1) .GE. min_sechiba) THEN
IF (tot_frac_bare(ji) .GE. min_sechiba) THEN
rsol(ji) = zero
DO jv = 1, nvm
rsol(ji) = rsol(ji) + dss(ji,jv) * rsol_cste * &
& frac_bare(ji,jv) * veget(ji,jv) / tot_frac_bare(ji)
ENDDO
!
! Correction Nathalie - le 28 mars 2006 - sur conseils Fred Hourdin
! on modifie le rsol pour que la resistance croisse subitement si on s'approche
! du fond. En gros, rsol=hdry*rsol_cste pour hdry < 1m70
!Ancien calcul de rsol
rsol(ji) = dss(ji,1) * rsol_cste
!Nathalie calcul rsol
!rsol(ji) = ( drysoil_frac(ji) + 1./(10.*(dpu_cste - drysoil_frac(ji))+1.e-10)**2 ) * rsol_cste
ENDIF
ENDDO
!
IF (long_print) WRITE (numout,*) ' hydrolc_soil done '
END SUBROUTINE hydrolc_soil
!!
!! This routines checks the water balance. First it gets the total
!! amount of water and then it compares the increments with the fluxes.
!! The computation is only done over the soil area as over glaciers (and lakes?)
!! we do not have water conservation.
!!
!! This verification does not make much sense in REAL*4 as the precision is the same as some
!! of the fluxes
!!
SUBROUTINE hydrolc_waterbal (kjpindex, index, first_call, dtradia, veget, totfrac_nobio, qsintveg, snow, snow_nobio,&
& precip_rain, precip_snow, returnflow, reinfiltration, irrigation, tot_melt, vevapwet, transpir, vevapnu, &
& vevapsno, vevapflo, floodout, run_off_tot, drainage)
!
!
!
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
LOGICAL, INTENT (in) :: first_call !! At which time is this routine called ?
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
!
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: totfrac_nobio!! Total fraction of continental ice+lakes+...
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintveg !! Water on vegetation due to interception
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: snow !! Snow mass [Kg/m^2]
REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout) :: snow_nobio !!Ice water balance
!
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: returnflow !! Water returning from routing to the deep reservoir
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: reinfiltration !! Water returning from routing to the top reservoir
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: irrigation !! Water from irrigation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: tot_melt !! Total melt
!
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vevapwet !! Interception loss
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: transpir !! Transpiration
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vevapnu !! Bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vevapflo !! Open water evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vevapsno !! Snow evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: floodout !! Outflow from floodplains
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: run_off_tot !! Total runoff
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: drainage !! Drainage
!
! LOCAL
!
INTEGER(i_std) :: ji, jv, jn
REAL(r_std) :: allowed_err
REAL(r_std),DIMENSION (kjpindex) :: watveg, delta_water, sum_snow_nobio, sum_vevapwet, sum_transpir
!
!
!
IF ( first_call ) THEN
tot_water_beg(:) = zero
watveg(:) = zero
sum_snow_nobio(:) = zero
!cdir NODEP
DO jv = 1, nvm
watveg(:) = watveg(:) + qsintveg(:,jv)
ENDDO
!cdir NODEP
DO jn = 1, nnobio
sum_snow_nobio(:) = sum_snow_nobio(:) + snow_nobio(:,jn)
ENDDO
!cdir NODEP
DO ji = 1, kjpindex
tot_water_beg(ji) = (mean_bqsb(ji) + mean_gqsb(ji))*vegtot(ji) + &
& watveg(ji) + snow(ji) + sum_snow_nobio(ji)
ENDDO
tot_water_end(:) = tot_water_beg(:)
tot_flux(:) = zero
RETURN
ENDIF
!
! Check the water balance
!
tot_water_end(:) = zero
tot_flux(:) = zero
!
DO ji = 1, kjpindex
!
! If the fraction of ice, lakes, etc. does not complement the vegetation fraction then we do not
! need to go any further
!
! Modif Nathalie
! IF ( (un - (totfrac_nobio(ji) + vegtot(ji))) .GT. EPSILON(un) ) THEN
IF ( (un - (totfrac_nobio(ji) + vegtot(ji))) .GT. (100*EPSILON(un)) ) THEN
WRITE(numout,*) 'HYDROL problem in vegetation or frac_nobio on point ', ji
WRITE(numout,*) 'totfrac_nobio : ', totfrac_nobio(ji)
WRITE(numout,*) 'vegetation fraction : ', vegtot(ji)
!STOP 'in hydrolc_waterbal'
ENDIF
ENDDO
!
watveg(:) = zero
sum_vevapwet(:) = zero
sum_transpir(:) = zero
sum_snow_nobio(:) = zero
!cdir NODEP
DO jv = 1,nvm
watveg(:) = watveg(:) + qsintveg(:,jv)
sum_vevapwet(:) = sum_vevapwet(:) + vevapwet(:,jv)
sum_transpir(:) = sum_transpir(:) + transpir(:,jv)
ENDDO
!cdir NODEP
DO jn = 1,nnobio
sum_snow_nobio(:) = sum_snow_nobio(:) + snow_nobio(:,jn)
ENDDO
!
!cdir NODEP
DO ji = 1, kjpindex
tot_water_end(ji) = (mean_bqsb(ji) + mean_gqsb(ji))*vegtot(ji) + &
& watveg(ji) + snow(ji) + sum_snow_nobio(ji)
ENDDO
!
DO ji = 1, kjpindex
!
delta_water(ji) = tot_water_end(ji) - tot_water_beg(ji)
!
tot_flux(ji) = precip_rain(ji) + precip_snow(ji) + returnflow(ji) + reinfiltration(ji) + irrigation(ji) - &
& sum_vevapwet(ji) - sum_transpir(ji) - vevapnu(ji) - vevapsno(ji) - vevapflo(ji) + &
& floodout(ji) - run_off_tot(ji) - drainage(ji)
!
ENDDO
!
! Set some precision ! This is a wild guess and corresponds to what works on an IEEE machine
! under double precision (REAL*8).
!
allowed_err = 50000*EPSILON(un)
!
DO ji = 1, kjpindex
IF ( ABS(delta_water(ji)-tot_flux(ji)) .GT. allowed_err ) THEN
WRITE(numout,*) 'HYDROL does not conserve water. The erroneous point is : ', ji
WRITE(numout,*) 'The error in mm/d is :', (delta_water(ji)-tot_flux(ji))/(dtradia/one_day), &
& ' and in mm/dt : ', delta_water(ji)-tot_flux(ji)
WRITE(numout,*) 'delta_water : ', delta_water(ji), ' tot_flux : ', tot_flux(ji)
WRITE(numout,*) 'Actual and allowed error : ', ABS(delta_water(ji)-tot_flux(ji)), allowed_err
WRITE(numout,*) 'vegtot : ', vegtot(ji)
WRITE(numout,*) 'precip_rain : ', precip_rain(ji)
WRITE(numout,*) 'precip_snow : ', precip_snow(ji)
WRITE(numout,*) 'Water from irrigation : ', reinfiltration(ji), returnflow(ji), irrigation(ji)
WRITE(numout,*) 'Total water in soil :', mean_bqsb(ji) + mean_gqsb(ji)
WRITE(numout,*) 'Water on vegetation :', watveg(ji)
WRITE(numout,*) 'Snow mass :', snow(ji)
WRITE(numout,*) 'Snow mass on ice :', sum_snow_nobio(ji)
WRITE(numout,*) 'Melt water :', tot_melt(ji)
WRITE(numout,*) 'evapwet : ', vevapwet(ji,:)
WRITE(numout,*) 'transpir : ', transpir(ji,:)
WRITE(numout,*) 'sum_evapwet : ', sum_vevapwet(ji)
WRITE(numout,*) 'sum_transpir : ', sum_transpir(ji)
WRITE(numout,*) 'evapnu, evapsno, evapflo : ', vevapnu(ji), vevapsno(ji), vevapflo(ji)
WRITE(numout,*) 'floodout : ', floodout(ji)
WRITE(numout,*) 'drainage : ', drainage(ji)
waterbal_error=.TRUE.
! STOP 'in hydrolc_waterbal'
ENDIF
!
ENDDO
!
! Transfer the total water amount at the end of the current timestep top the begining of the next one.
!
tot_water_beg = tot_water_end
!
END SUBROUTINE hydrolc_waterbal
!
! This routine computes the changes in soil moisture and interception storage for the ALMA outputs
!
SUBROUTINE hydrolc_alma (kjpindex, index, first_call, qsintveg, snow, snow_nobio, soilwet)
!
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
LOGICAL, INTENT (in) :: first_call !! At which time is this routine called ?
!
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintveg !! Water on vegetation due to interception
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: snow !! Snow water equivalent
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: soilwet !! Soil wetness
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: snow_nobio !! Water balance on ice, lakes, .. [Kg/m^2]
!
! LOCAL
!
INTEGER(i_std) :: ji
REAL(r_std) :: watveg
!
!
!
IF ( first_call ) THEN
tot_watveg_beg(:) = zero
tot_watsoil_beg(:) = zero
snow_beg(:) = zero
!
DO ji = 1, kjpindex
watveg = SUM(qsintveg(ji,:))
tot_watveg_beg(ji) = watveg
tot_watsoil_beg(ji) = mean_bqsb(ji) + mean_gqsb(ji)
snow_beg(ji) = snow(ji)+ SUM(snow_nobio(ji,:))
ENDDO
!
tot_watveg_end(:) = tot_watveg_beg(:)
tot_watsoil_end(:) = tot_watsoil_beg(:)
snow_end(:) = snow_beg(:)
RETURN
ENDIF
!
! Calculate the values for the end of the time step
!
tot_watveg_end(:) = zero
tot_watsoil_end(:) = zero
snow_end(:) = zero
delintercept(:) = zero
delsoilmoist(:) = zero
delswe(:) = zero
!
DO ji = 1, kjpindex
watveg = SUM(qsintveg(ji,:))
tot_watveg_end(ji) = watveg
tot_watsoil_end(ji) = mean_bqsb(ji) + mean_gqsb(ji)
snow_end(ji) = snow(ji)+ SUM(snow_nobio(ji,:))
!
delintercept(ji) = tot_watveg_end(ji) - tot_watveg_beg(ji)
delsoilmoist(ji) = tot_watsoil_end(ji) - tot_watsoil_beg(ji)
delswe(ji) = snow_end(ji) - snow_beg(ji)
!
!
ENDDO
!
!
! Transfer the total water amount at the end of the current timestep top the begining of the next one.
!
tot_watveg_beg = tot_watveg_end
tot_watsoil_beg = tot_watsoil_end
snow_beg(:) = snow_end(:)
!
DO ji = 1,kjpindex
soilwet(ji) = tot_watsoil_end(ji) / mx_eau_var(ji)
ENDDO
!
END SUBROUTINE hydrolc_alma
!-
SUBROUTINE hydrolc_hdiff(kjpindex, dtradia, veget, ruu_ch, gqsb, bqsb, dsg, dss, dsp)
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! time step (s)
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: ruu_ch !! Quantite d'eau maximum
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: gqsb !! Hauteur d'eau dans le reservoir de surface
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: bqsb !! Hauteur d'eau dans le reservoir profond
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsg !! Hauteur du reservoir de surface
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dss !! Hauteur au dessus du reservoir de surface
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsp !! Hauteur au dessus du reservoir profond
REAL(r_std), DIMENSION (kjpindex) :: bqsb_mean
REAL(r_std), DIMENSION (kjpindex) :: gqsb_mean
REAL(r_std), DIMENSION (kjpindex) :: dss_mean
REAL(r_std), DIMENSION (kjpindex) :: vegtot
REAL(r_std) :: x
INTEGER(i_std) :: ji,jv
REAL(r_std), SAVE :: tau_hdiff
LOGICAL, SAVE :: firstcall=.TRUE.
IF ( firstcall ) THEN
!Config Key = HYDROL_TAU_HDIFF
!Config Desc = time scale (s) for horizontal diffusion of water
!Config Def = 86400.
!Config If = HYDROL_OK_HDIFF
!Config Help = Defines how fast diffusion occurs horizontally between
!Config the individual PFTs' water reservoirs. If infinite, no
!Config diffusion.
tau_hdiff = 86400.
CALL getin_p('HYDROL_TAU_HDIFF',tau_hdiff)
WRITE (numout,*) 'Hydrol: Horizontal diffusion, tau (s)=',tau_hdiff
firstcall = .FALSE.
ENDIF
! Calculate mean values
! could be done with SUM instruction but this kills vectorization
!
bqsb_mean(:) = 0.0
gqsb_mean(:) = 0.0
dss_mean(:) = 0.0
vegtot(:) = 0.0
!
DO jv = 1, nvm
DO ji = 1, kjpindex
bqsb_mean(ji) = bqsb_mean(ji) + veget(ji,jv)*bqsb(ji,jv)
gqsb_mean(ji) = gqsb_mean(ji) + veget(ji,jv)*gqsb(ji,jv)
dss_mean(ji) = dss_mean(ji) + veget(ji,jv)*dss(ji,jv)
vegtot(ji) = vegtot(ji) + veget(ji,jv)
ENDDO
ENDDO
DO ji = 1, kjpindex
IF (vegtot(ji) .GT. zero) THEN
bqsb_mean(ji) = bqsb_mean(ji)/vegtot(ji)
gqsb_mean(ji) = gqsb_mean(ji)/vegtot(ji)
dss_mean(ji) = dss_mean(ji)/vegtot(ji)
ENDIF
ENDDO
! relax values towards mean.
!
x = MAX( zero, MIN( dtradia/tau_hdiff, un ) )
!
DO jv = 1, nvm
DO ji = 1, kjpindex
!
bqsb(ji,jv) = (un-x) * bqsb(ji,jv) + x * bqsb_mean(ji)
gqsb(ji,jv) = (un-x) * gqsb(ji,jv) + x * gqsb_mean(ji)
dss(ji,jv) = (un-x) * dss(ji,jv) + x * dss_mean(ji)
!
IF (gqsb(ji,jv) .LT. min_sechiba) THEN
dsg(ji,jv) = 0.0
ELSE
dsg(ji,jv) = (dss(ji,jv) * ruu_ch(ji) + gqsb(ji,jv)) / ruu_ch(ji)
ENDIF
dsp(ji,jv) = dpu_cste - bqsb(ji,jv) / ruu_ch(ji)
!
ENDDO
ENDDO
END SUBROUTINE hydrolc_hdiff
!
END MODULE hydrolc
ORCHIDEE/src_sechiba/intersurf.f90 0000754 0103600 0005670 00001151213 11164403473 016537 0 ustar acamlmd lmdjus
!! This subroutine is the interface between the main program
!! (LMDZ or dim2_driver) and SECHIBA.
!! - Input fields are gathered to keep just continental points
!! - call sechiba_main That's SECHIBA process.
!! - Output fields are scattered to complete global fields
!!
!! @call sechiba_main
!! @Version : $Revision: 1.57 $, $Date: 2007/06/21 09:54:45 $
!!
!! @author Marie-Alice Foujols and Jan Polcher
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/intersurf.f90,v 1.57 2007/06/21 09:54:45 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
!f90doc MODULEintersurf
MODULE intersurf
USE IOIPSL
USE defprec
USE sechiba
USE constantes
USE constantes_soil
USE constantes_veg
USE parallel
USE grid
USE netcdf
! USE Write_Field_p
IMPLICIT NONE
PRIVATE
PUBLIC :: intersurf_main, stom_define_history
INTERFACE intersurf_main
MODULE PROCEDURE intersurf_main_2d, intersurf_main_1d, intersurf_gathered, intersurf_gathered_2m
END INTERFACE
!
! Global variables
!
INTEGER(i_std),PARAMETER :: max_hist_level = 10
!
LOGICAL, SAVE :: l_first_intersurf=.TRUE. !! Initialisation has to be done one time
!
INTEGER(i_std), SAVE :: hist_id, rest_id !! IDs for history and restart files
INTEGER(i_std), SAVE :: hist2_id !! ID for the second history files (Hi-frequency ?)
INTEGER(i_std), SAVE :: hist_id_stom, rest_id_stom !! Dito for STOMATE
!
INTEGER(i_std), SAVE :: itau_offset !! This offset is used to phase the
! !! calendar of the GCM or the driver.
REAL(r_std) :: date0_shifted
!
TYPE(control_type), SAVE :: control_flags !! Flags that (de)activate parts of the model
!
!
! At module level we need the ids of the variables for the ORCHIDEE_WATCH. They will be
! shared by the intersurf_initwatch and intersurf_wrtwatch routines.
! The flag which will control all this is watchout
!
LOGICAL,SAVE :: watchout = .FALSE.
REAL, SAVE :: dt_watch = 0.
INTEGER, SAVE :: last_action_watch = 0, &
& last_check_watch = 0
INTEGER(i_std),SAVE :: time_id, timestp_id
INTEGER(i_std),SAVE :: watchfid, zlevid, soldownid, rainfid, snowfid, lwradid, &
& psolid, tairid, eairid, qairid, uid, vid, &
& solnetid, petAcoefid, peqAcoefid, petBcoefid, peqBcoefid, cdragid
INTEGER(i_std),SAVE :: watchoffset
CHARACTER(LEN=80),SAVE :: watchout_file
REAL, ALLOCATABLE, DIMENSION(:), SAVE :: sum_rain, sum_snow
REAL, ALLOCATABLE, DIMENSION(:), SAVE :: sum_swdown
REAL :: dt_split_watch
!
LOGICAL :: check_INPUTS = .FALSE. !! (very) long print of INPUTs in intersurf
LOGICAL, SAVE :: OFF_LINE_MODE = .FALSE.
!
CONTAINS
!
!f90doc CONTAINS
!
SUBROUTINE intersurf_main_2d (kjit, iim, jjm, kjpindex, kindex, xrdt, &
& lrestart_read, lrestart_write, lon, lat, zcontfrac, zneighbours, zresolution, date0, &
! First level conditions
& zlev, u, v, qair, temp_air, epot_air, ccanopy, &
! Variables for the implicit coupling
& cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
! Surface temperatures and surface properties
& tsol_rad, temp_sol_new, qsurf, albedo, emis, z0)
! routines called : sechiba_main
!
IMPLICIT NONE
!
! interface description for dummy arguments
! input scalar
INTEGER(i_std),INTENT (in) :: kjit !! Time step number
INTEGER(i_std),INTENT (in) :: iim, jjm !! Dimension of input fields
INTEGER(i_std),INTENT (in) :: kjpindex !! Number of continental points
REAL(r_std),INTENT (in) :: xrdt !! Time step in seconds
LOGICAL, INTENT (in) :: lrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT (in) :: lrestart_write!! Logical for _restart_ file to write'
REAL(r_std), INTENT (in) :: date0 !! Date at which kjit = 0
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: kindex !! Index for continental points
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: lwdown !! Down-welling long-wave flux
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: swnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: swdown !! Downwelling surface short-wave flux
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: temp_air !! Air temperature in Kelvin
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: epot_air !! Air potential energy
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: ccanopy !! CO2 concentration in the canopy
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: petAcoef !! Coeficients A from the PBL resolution
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: peqAcoef !! One for T and another for q
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: petBcoef !! Coeficients B from the PBL resolution
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: peqBcoef !! One for T and another for q
REAL(r_std),DIMENSION (iim,jjm), INTENT(inout) :: cdrag !! Cdrag
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: lon, lat !! Geographical coordinates
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: zcontfrac !! Fraction of continent in the grid
INTEGER, DIMENSION (iim,jjm,8), INTENT(in) :: zneighbours !! land neighbours
REAL(r_std),DIMENSION (iim,jjm,2), INTENT(in) :: zresolution !! resolution in x and y dimensions
! output fields
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: z0 !! Surface roughness
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: coastalflow !! Diffuse flow of water into the ocean (m^3/dt)
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: riverflow !! Largest rivers flowing into the ocean (m^3/dt)
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: tsol_rad !! Radiative surface temperature
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: vevapp !! Total of evaporation
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: qsurf !! Surface specific humidity
REAL(r_std),DIMENSION (iim,jjm,2), INTENT(out) :: albedo !! Albedo
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: fluxsens !! Sensible chaleur flux
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: fluxlat !! Latent chaleur flux
REAL(r_std),DIMENSION (iim,jjm), INTENT(out) :: emis !! Emissivity
! LOCAL declaration
! work arrays to scatter and/or gather information just before/after sechiba_main call's
! and to keep output value for next call
REAL(r_std),DIMENSION (kjpindex) :: zu !! Work array to keep u
REAL(r_std),DIMENSION (kjpindex) :: zv !! Work array to keep v
REAL(r_std),DIMENSION (kjpindex) :: zzlev !! Work array to keep zlev
REAL(r_std),DIMENSION (kjpindex) :: zqair !! Work array to keep qair
REAL(r_std),DIMENSION (kjpindex) :: zprecip_rain !! Work array to keep precip_rain
REAL(r_std),DIMENSION (kjpindex) :: zprecip_snow !! Work array to keep precip_snow
REAL(r_std),DIMENSION (kjpindex) :: zlwdown !! Work array to keep lwdown
REAL(r_std),DIMENSION (kjpindex) :: zswnet !! Work array to keep swnet
REAL(r_std),DIMENSION (kjpindex) :: zswdown !! Work array to keep swdown
REAL(r_std),DIMENSION (kjpindex) :: ztemp_air !! Work array to keep temp_air
REAL(r_std),DIMENSION (kjpindex) :: zepot_air !! Work array to keep epot_air
REAL(r_std),DIMENSION (kjpindex) :: zccanopy !! Work array to keep ccanopy
REAL(r_std),DIMENSION (kjpindex) :: zpetAcoef !! Work array to keep petAcoef
REAL(r_std),DIMENSION (kjpindex) :: zpeqAcoef !! Work array to keep peqAcoef
REAL(r_std),DIMENSION (kjpindex) :: zpetBcoef !! Work array to keep petBcoef
REAL(r_std),DIMENSION (kjpindex) :: zpeqBcoef !! Work array to keep peqVcoef
REAL(r_std),DIMENSION (kjpindex) :: zcdrag !! Work array to keep cdrag
REAL(r_std),DIMENSION (kjpindex) :: zpb !! Work array to keep pb
REAL(r_std),DIMENSION (kjpindex) :: zz0 !! Work array to keep z0
REAL(r_std),DIMENSION (kjpindex) :: zcoastal !! Work array to keep coastalflow
REAL(r_std),DIMENSION (kjpindex) :: zriver !! Work array to keep riverflow
REAL(r_std),DIMENSION (kjpindex) :: dcoastal !! Work array to keep coastalflow
REAL(r_std),DIMENSION (kjpindex) :: driver !! Work array to keep riverflow
REAL(r_std),DIMENSION (kjpindex) :: ztsol_rad !! Work array to keep tsol_rad
REAL(r_std),DIMENSION (kjpindex) :: zvevapp !! Work array to keep vevapp
REAL(r_std),DIMENSION (kjpindex) :: ztemp_sol_new !! Work array to keep temp_sol_new
REAL(r_std),DIMENSION (kjpindex) :: zqsurf !! Work array to keep qsurf
REAL(r_std),DIMENSION (kjpindex,2) :: zalbedo !! Work array to keep albedo
REAL(r_std),DIMENSION (kjpindex) :: zfluxsens !! Work array to keep fluxsens
REAL(r_std),DIMENSION (kjpindex) :: zfluxlat !! Work array to keep fluxlat
REAL(r_std),DIMENSION (kjpindex) :: zemis !! Work array to keep emis
!
! Local variables with shape of the inputs
!
REAL(r_std),DIMENSION (iim,jjm) :: dswnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (iim,jjm) :: dswdown !! Incident surface short-wave flux
!
INTEGER(i_std) :: i, j, ik
INTEGER(i_std) :: itau_sechiba
REAL(r_std) :: zlev_mean
LOGICAL :: do_watch !! if it's time, write watchout
LOGICAL :: check = .FALSE.
!
IF (l_first_intersurf) THEN
! CALL Init_WriteField_p(kindex)
!
IF ( check ) WRITE(numout,*) 'Initialisation of intersurf'
!
OFF_LINE_MODE = .TRUE.
!
DO ik=1,kjpindex
j = ((kindex(ik)-1)/iim) + 1
i = (kindex(ik) - (j-1)*iim)
!- Create the internal coordinate table
!-
lalo(ik,1) = lat(i,j)
lalo(ik,2) = lon(i,j)
!
!- Store the fraction of the continents only once so that the user
!- does not change them afterwards.
!-
contfrac(ik) = zcontfrac(i,j)
ENDDO
CALL gather(contfrac,contfrac_g)
CALL gather(lalo,lalo_g)
CALL gather2D(lon,lon_g)
CALL gather2D(lat,lat_g)
CALL gather2D(zlev,zlev_g)
!
! Configuration of SSL specific parameters
!
CALL intsurf_config(control_flags, xrdt)
!
CALL intsurf_restart(kjit, iim, jjm, lon, lat, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
!
CALL intsurf_history(iim, jjm, lon, lat, kjit+itau_offset, date0_shifted, xrdt, control_flags, hist_id, &
& hist2_id, hist_id_stom)
!
IF ( watchout ) THEN
IF (is_root_prc) THEN
zlev_mean = 0.
DO ik=1, nbp_glo
j = ((index_g(ik)-1)/iim_g) + 1
i = (index_g(ik) - (j-1)*iim_g)
zlev_mean = zlev_mean + zlev_g(i,j)
ENDDO
zlev_mean = zlev_mean / REAL(nbp_glo,r_std)
ENDIF
last_action_watch = kjit+itau_offset
last_check_watch = last_action_watch
! Only root proc write watchout file
IF (is_root_prc) &
CALL intersurf_initwatch(iim_g, jjm_g, nbp_glo, &
& date0_shifted, kjit+itau_offset, dt_watch, index_g, lon_g, lat_g, zlev_mean)
ALLOCATE(sum_rain(kjpindex), sum_snow(kjpindex))
ALLOCATE(sum_swdown(kjpindex))
sum_rain(:) = 0.0
sum_snow(:) = 0.0
sum_swdown(:) = 0.0
ENDIF
!
IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
!
ENDIF
!
! Shift the time step to phase the two models
!
itau_sechiba = kjit + itau_offset
!
! 1. gather input fields from kindex array
! Warning : I'm not sure this interface with one dimension array is the good one
!
DO ik=1, kjpindex
j = ((kindex(ik)-1)/iim) + 1
i = (kindex(ik) - (j-1)*iim)
zu(ik) = u(i,j)
zv(ik) = v(i,j)
zzlev(ik) = zlev(i,j)
zqair(ik) = qair(i,j)
zprecip_rain(ik) = precip_rain(i,j)*xrdt
zprecip_snow(ik) = precip_snow(i,j)*xrdt
zlwdown(ik) = lwdown(i,j)
zswnet(ik) = swnet(i,j)
zswdown(ik) = swdown(i,j)
ztemp_air(ik) = temp_air(i,j)
zepot_air(ik) = epot_air(i,j)
zccanopy(ik) = ccanopy(i,j)
zpetAcoef(ik) = petAcoef(i,j)
zpeqAcoef(ik) = peqAcoef(i,j)
zpetBcoef(ik) = petBcoef(i,j)
zpeqBcoef(ik) = peqBcoef(i,j)
zcdrag(ik) = cdrag(i,j)
zpb(ik) = pb(i,j)
ENDDO
!
IF (check_INPUTS) THEN
print *,"Intersurf_main_2D :"
print *,"Time step number = ",kjit
print *,"Dimension of input fields = ",iim, jjm
print *,"Number of continental points = ",kjpindex
print *,"Time step in seconds = ",xrdt
print *,"Logical for _restart_ file to read, write = ",lrestart_read,lrestart_write
print *,"Date at which kjit = 0 = ",date0
print *,"Index for continental points = ",kindex
print *,"Lowest level wind speed North = ",zu
print *,"Lowest level wind speed East = ",zv
print *,"Height of first layer = ",zzlev
print *,"Lowest level specific humidity = ",zqair
print *,"Rain precipitation = ",zprecip_rain
print *,"Snow precipitation = ",zprecip_snow
print *,"Down-welling long-wave flux = ",zlwdown
print *,"Net surface short-wave flux = ",zswnet
print *,"Downwelling surface short-wave flux = ",zswdown
print *,"Air temperature in Kelvin = ",ztemp_air
print *,"Air potential energy = ",zepot_air
print *,"CO2 concentration in the canopy = ",zccanopy
print *,"Coeficients A from the PBL resolution = ",zpetAcoef
print *,"One for T and another for q = ",zpeqAcoef
print *,"Coeficients B from the PBL resolution = ",zpetBcoef
print *,"One for T and another for q = ",zpeqBcoef
print *,"Cdrag = ",zcdrag
print *,"Lowest level pressure = ",zpb
print *,"Geographical coordinates lon = ", (/ ( lon(ilandindex(ik), jlandindex(ik)), ik=1,kjpindex ) /)
print *,"Geographical coordinates lat = ", (/ ( lat(ilandindex(ik), jlandindex(ik)), ik=1,kjpindex ) /)
print *,"Fraction of continent in the grid = ",contfrac
ENDIF
!
IF ( watchout ) THEN
do_watch = .FALSE.
call isittime &
& (itau_sechiba,date0_shifted,xrdt,dt_watch,&
& last_action_watch,last_check_watch,do_watch)
last_check_watch = itau_sechiba
IF ( .NOT. l_first_intersurf .AND. do_watch) THEN
IF (long_print) THEN
print *,"intersurf : write watchout for date ",date0,date0_shifted,itau_sechiba,last_action_watch,last_check_watch
ENDIF
last_action_watch = itau_sechiba
sum_rain(:) = sum_rain(:) + zprecip_rain(:)
sum_snow(:) = sum_snow(:) + zprecip_snow(:)
sum_rain(:) = sum_rain(:) / dt_split_watch
sum_snow(:) = sum_snow(:) / dt_split_watch
sum_swdown(:) = sum_swdown(:) + zswdown(:)
sum_swdown(:) = sum_swdown(:) / dt_split_watch
CALL intersurf_wrtwatch_p(kjpindex, itau_sechiba, xrdt, zzlev, sum_swdown, sum_rain, &
& sum_snow, zlwdown, zpb, ztemp_air, zepot_air, zqair, zu, zv, &
& zswnet, zpetAcoef, zpeqAcoef, zpetBcoef, zpeqBcoef, zcdrag )
sum_rain(:) = 0.0
sum_snow(:) = 0.0
sum_swdown(:) = 0.0
ELSE
sum_rain(:) = sum_rain(:) + zprecip_rain(:)
sum_snow(:) = sum_snow(:) + zprecip_snow(:)
sum_swdown(:) = sum_swdown(:) + zswdown(:)
ENDIF
ENDIF
!
! 3. call sechiba for continental points only
!
IF ( check ) WRITE(numout,*) 'Calling sechiba'
!
CALL sechiba_main (itau_sechiba, iim*jjm, kjpindex, kindex, xrdt, date0_shifted, &
& lrestart_read, lrestart_write, control_flags, &
& lalo, contfrac, neighbours, resolution, &
! First level conditions
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul rveget
! & zzlev, zu, zv, zqair, ztemp_air, zepot_air, zccanopy, &
& zzlev, zu, zv, zqair, zqair, ztemp_air, ztemp_air, zepot_air, zccanopy, &
! Variables for the implicit coupling
& zcdrag, zpetAcoef, zpeqAcoef, zpetBcoef, zpeqBcoef, &
! Rain, snow, radiation and surface pressure
& zprecip_rain ,zprecip_snow, zlwdown, zswnet, zswdown, zpb, &
! Output : Fluxes
& zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, &
! Surface temperatures and surface properties
& ztsol_rad, ztemp_sol_new, zqsurf, zalbedo, zemis, zz0, &
! File ids
& rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom )
!
IF ( check ) WRITE(numout,*) 'out of SECHIBA'
!
! 4. scatter output fields
!
z0(:,:) = undef_sechiba
coastalflow(:,:) = undef_sechiba
riverflow(:,:) = undef_sechiba
tsol_rad(:,:) = undef_sechiba
vevapp(:,:) = undef_sechiba
temp_sol_new(:,:) = undef_sechiba
qsurf(:,:) = undef_sechiba
albedo(:,:,:) = undef_sechiba
fluxsens(:,:) = undef_sechiba
fluxlat(:,:) = undef_sechiba
emis(:,:) = undef_sechiba
cdrag(:,:) = undef_sechiba
dswnet(:,:) = undef_sechiba
dswdown(:,:) = undef_sechiba
!
DO ik=1, kjpindex
j = ((kindex(ik)-1)/iim) + 1
i = (kindex(ik) - (j-1)*iim)
z0(i,j) = zz0(ik)
coastalflow(i,j) = zcoastal(ik)/1000.
riverflow(i,j) = zriver(ik)/1000.
tsol_rad(i,j) = ztsol_rad(ik)
vevapp(i,j) = zvevapp(ik)
temp_sol_new(i,j) = ztemp_sol_new(ik)
qsurf(i,j) = zqsurf(ik)
albedo(i,j,1) = zalbedo(ik,1)
albedo(i,j,2) = zalbedo(ik,2)
fluxsens(i,j) = zfluxsens(ik)
fluxlat(i,j) = zfluxlat(ik)
emis(i,j) = zemis(ik)
cdrag(i,j) = zcdrag(ik)
dswnet(i,j) = zswnet(ik)
dswdown(i,j) = zswdown(ik)
ENDDO
!
! Modified fields for variables scattered during the writing
!
dcoastal(:) = (zcoastal(:))/1000.
driver(:) = (zriver(:))/1000.
!
IF ( .NOT. l_first_intersurf) THEN
!
CALL histwrite(hist_id, 'LandPoints', itau_sechiba, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
CALL histwrite(hist_id, 'Areas', itau_sechiba, area, kjpindex, kindex)
CALL histwrite(hist_id, 'Contfrac', itau_sechiba, contfrac, kjpindex, kindex)
IF ( hist2_id > 0 ) THEN
CALL histwrite(hist2_id, 'LandPoints', itau_sechiba, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
ENDIF
!
IF ( .NOT. almaoutput ) THEN
!
! scattered during the writing
!
CALL histwrite (hist_id, 'evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
CALL histwrite (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
!
CALL histwrite (hist_id, 'temp_sol', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist_id, 'tsol_max', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist_id, 'tsol_min', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist_id, 'fluxsens', itau_sechiba, fluxsens, iim*jjm, kindex)
CALL histwrite (hist_id, 'fluxlat', itau_sechiba, fluxlat, iim*jjm, kindex)
CALL histwrite (hist_id, 'swnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist_id, 'swdown', itau_sechiba, dswdown, iim*jjm, kindex)
CALL histwrite (hist_id, 'alb_vis', itau_sechiba, albedo(:,:,1), iim*jjm, kindex)
CALL histwrite (hist_id, 'alb_nir', itau_sechiba, albedo(:,:,2), iim*jjm, kindex)
CALL histwrite (hist_id, 'tair', itau_sechiba, temp_air, iim*jjm, kindex)
CALL histwrite (hist_id, 'qair', itau_sechiba, qair, iim*jjm, kindex)
! Ajout Nathalie - Juin 2006 - on conserve q2m/t2m
CALL histwrite (hist_id, 'q2m', itau_sechiba, qair, iim*jjm, kindex)
CALL histwrite (hist_id, 't2m', itau_sechiba, temp_air, iim*jjm, kindex)
IF ( hist2_id > 0 ) THEN
CALL histwrite (hist2_id, 'evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
CALL histwrite (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
!
CALL histwrite (hist2_id, 'temp_sol_new', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, fluxsens, iim*jjm, kindex)
CALL histwrite (hist2_id, 'fluxlat', itau_sechiba, fluxlat, iim*jjm, kindex)
CALL histwrite (hist2_id, 'swnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist2_id, 'swdown', itau_sechiba, dswdown, iim*jjm, kindex)
CALL histwrite (hist2_id, 'alb_vis', itau_sechiba, albedo(:,:,1), iim*jjm, kindex)
CALL histwrite (hist2_id, 'alb_nir', itau_sechiba, albedo(:,:,2), iim*jjm, kindex)
CALL histwrite (hist2_id, 'tair', itau_sechiba, temp_air, iim*jjm, kindex)
CALL histwrite (hist2_id, 'qair', itau_sechiba, qair, iim*jjm, kindex)
CALL histwrite (hist2_id, 'q2m', itau_sechiba, qair, iim*jjm, kindex)
CALL histwrite (hist2_id, 't2m', itau_sechiba, temp_air, iim*jjm, kindex)
ENDIF
ELSE
CALL histwrite (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist_id, 'SWnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist_id, 'Qh', itau_sechiba, fluxsens, iim*jjm, kindex)
CALL histwrite (hist_id, 'Qle', itau_sechiba, fluxlat, iim*jjm, kindex)
CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist_id, 'RadT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
IF ( hist2_id > 0 ) THEN
CALL histwrite (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist2_id, 'SWnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist2_id, 'Qh', itau_sechiba, fluxsens, iim*jjm, kindex)
CALL histwrite (hist2_id, 'Qle', itau_sechiba, fluxlat, iim*jjm, kindex)
CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist2_id, 'RadT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
ENDIF
ENDIF
!
ENDIF
!
!
! 5.0 Transform the water fluxes into Kg/m^2s and m^3/s
!
DO ik=1, kjpindex
j = ((kindex(ik)-1)/iim) + 1
i = (kindex(ik) - (j-1)*iim)
vevapp(i,j) = vevapp(i,j)/xrdt
coastalflow(i,j) = coastalflow(i,j)/xrdt
riverflow(i,j) = riverflow(i,j)/xrdt
ENDDO
!
IF ( lrestart_write .AND. watchout ) THEN
IF (is_root_prc) CALL intersurf_clowatch()
ENDIF
!
l_first_intersurf = .FALSE.
!
IF (long_print) WRITE (numout,*) ' intersurf_main done '
END SUBROUTINE intersurf_main_2d
!
SUBROUTINE intersurf_main_1d (kjit, iim, jjm, kjpindex, kindex, xrdt, &
& lrestart_read, lrestart_write, lon, lat, zcontfrac, zneighbours, zresolution, date0, &
! First level conditions
& zlev, u, v, qair, temp_air, epot_air, ccanopy, &
! Variables for the implicit coupling
& cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
! Surface temperatures and surface properties
& tsol_rad, temp_sol_new, qsurf, albedo, emis, z0)
! routines called : sechiba_main
!
IMPLICIT NONE
!
! interface description for dummy arguments
! input scalar
INTEGER(i_std),INTENT (in) :: kjit !! Time step number
INTEGER(i_std),INTENT (in) :: iim, jjm !! Dimension of input fields
INTEGER(i_std),INTENT (in) :: kjpindex !! Number of continental points
REAL(r_std),INTENT (in) :: xrdt !! Time step in seconds
LOGICAL, INTENT (in) :: lrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT (in) :: lrestart_write!! Logical for _restart_ file to write'
REAL(r_std), INTENT (in) :: date0 !! Date at which kjit = 0
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: kindex !! Index for continental points
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: lwdown !! Down-welling long-wave flux
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: swnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: swdown !! Downwelling surface short-wave flux
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: temp_air !! Air temperature in Kelvin
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: epot_air !! Air potential energy
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: ccanopy !! CO2 concentration in the canopy
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: petAcoef !! Coeficients A from the PBL resolution
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: peqAcoef !! One for T and another for q
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: petBcoef !! Coeficients B from the PBL resolution
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: peqBcoef !! One for T and another for q
REAL(r_std),DIMENSION (iim*jjm), INTENT(inout) :: cdrag !! Cdrag
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: lon, lat !! Geographical coordinates
REAL(r_std),DIMENSION (iim*jjm), INTENT(in) :: zcontfrac !! Fraction of continent
INTEGER, DIMENSION (iim*jjm,8), INTENT(in) :: zneighbours !! land neighbours
REAL(r_std),DIMENSION (iim*jjm,2), INTENT(in) :: zresolution !! resolution in x and y dimensions
! output fields
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: z0 !! Surface roughness
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: coastalflow !! Diffuse flow of water into the ocean (m^3/dt)
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: riverflow !! Largest rivers flowing into the ocean (m^3/dt)
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: tsol_rad !! Radiative surface temperature
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: vevapp !! Total of evaporation
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: qsurf !! Surface specific humidity
REAL(r_std),DIMENSION (iim*jjm,2), INTENT(out) :: albedo !! Albedo
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: fluxsens !! Sensible chaleur flux
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: fluxlat !! Latent chaleur flux
REAL(r_std),DIMENSION (iim*jjm), INTENT(out) :: emis !! Emissivity
! LOCAL declaration
! work arrays to scatter and/or gather information just before/after sechiba_main call's
! and to keep output value for next call
REAL(r_std),DIMENSION (kjpindex) :: zu !! Work array to keep u
REAL(r_std),DIMENSION (kjpindex) :: zv !! Work array to keep v
REAL(r_std),DIMENSION (kjpindex) :: zzlev !! Work array to keep zlev
REAL(r_std),DIMENSION (kjpindex) :: zqair !! Work array to keep qair
REAL(r_std),DIMENSION (kjpindex) :: zprecip_rain !! Work array to keep precip_rain
REAL(r_std),DIMENSION (kjpindex) :: zprecip_snow !! Work array to keep precip_snow
REAL(r_std),DIMENSION (kjpindex) :: zlwdown !! Work array to keep lwdown
REAL(r_std),DIMENSION (kjpindex) :: zswnet !! Work array to keep swnet
REAL(r_std),DIMENSION (kjpindex) :: zswdown !! Work array to keep swdown
REAL(r_std),DIMENSION (kjpindex) :: ztemp_air !! Work array to keep temp_air
REAL(r_std),DIMENSION (kjpindex) :: zepot_air !! Work array to keep epot_air
REAL(r_std),DIMENSION (kjpindex) :: zccanopy !! Work array to keep ccanopy
REAL(r_std),DIMENSION (kjpindex) :: zpetAcoef !! Work array to keep petAcoef
REAL(r_std),DIMENSION (kjpindex) :: zpeqAcoef !! Work array to keep peqAcoef
REAL(r_std),DIMENSION (kjpindex) :: zpetBcoef !! Work array to keep petBcoef
REAL(r_std),DIMENSION (kjpindex) :: zpeqBcoef !! Work array to keep peqVcoef
REAL(r_std),DIMENSION (kjpindex) :: zcdrag !! Work array to keep cdrag
REAL(r_std),DIMENSION (kjpindex) :: zpb !! Work array to keep pb
REAL(r_std),DIMENSION (kjpindex) :: zz0 !! Work array to keep z0
REAL(r_std),DIMENSION (kjpindex) :: zcoastal !! Work array to keep coastal flow
REAL(r_std),DIMENSION (kjpindex) :: zriver !! Work array to keep river out flow
REAL(r_std),DIMENSION (kjpindex) :: dcoastal !! Work array to keep coastal flow
REAL(r_std),DIMENSION (kjpindex) :: driver !! Work array to keep river out flow
REAL(r_std),DIMENSION (kjpindex) :: ztsol_rad !! Work array to keep tsol_rad
REAL(r_std),DIMENSION (kjpindex) :: zvevapp !! Work array to keep vevapp
REAL(r_std),DIMENSION (kjpindex) :: ztemp_sol_new !! Work array to keep temp_sol_new
REAL(r_std),DIMENSION (kjpindex) :: zqsurf !! Work array to keep qsurf
REAL(r_std),DIMENSION (kjpindex,2) :: zalbedo !! Work array to keep albedo
REAL(r_std),DIMENSION (kjpindex) :: zfluxsens !! Work array to keep fluxsens
REAL(r_std),DIMENSION (kjpindex) :: zfluxlat !! Work array to keep fluxlat
REAL(r_std),DIMENSION (kjpindex) :: zemis !! Work array to keep emis
!
! Local but with input shape
!
REAL(r_std),DIMENSION (iim*jjm) :: dswnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (iim*jjm) :: dswdown !! Incident surface short-wave flux
!
INTEGER(i_std) :: i, j, ik
INTEGER(i_std) :: itau_sechiba
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: tmp_lon, tmp_lat, tmp_lev
LOGICAL :: check = .FALSE.
IF (l_first_intersurf) THEN
!
IF ( check ) WRITE(numout,*) 'Initialisation of intersurf'
!
OFF_LINE_MODE = .TRUE.
!
! Create the internal coordinate table
!
IF ( (.NOT.ALLOCATED(tmp_lon))) THEN
ALLOCATE(tmp_lon(iim,jjm))
ENDIF
IF ( (.NOT.ALLOCATED(tmp_lat))) THEN
ALLOCATE(tmp_lat(iim,jjm))
ENDIF
IF ( (.NOT.ALLOCATED(tmp_lev))) THEN
ALLOCATE(tmp_lev(iim,jjm))
ENDIF
!
DO i=1,iim
DO j=1,jjm
ik = (j-1)*iim + i
tmp_lon(i,j) = lon(ik)
tmp_lat(i,j) = lat(ik)
tmp_lev(i,j) = zlev(kindex(ik))
ENDDO
ENDDO
!
lalo(:,1) = lat(:)
lalo(:,2) = lon(:)
!
!- Store the fraction of the continents only once so that the user
!- does not change them afterwards.
!
DO ik=1,kjpindex
contfrac(ik) = zcontfrac(kindex(ik))
ENDDO
contfrac_g(:) = contfrac(:)
lalo_g(:,:) = lalo(:,:)
lon_g(:,:) = tmp_lon(:,:)
lat_g(:,:) = tmp_lat(:,:)
zlev_g(:,:) = tmp_lev(:,:)
!
! Configuration of SSL specific parameters
!
CALL intsurf_config(control_flags, xrdt)
!
CALL intsurf_restart(kjit, iim, jjm, tmp_lon, tmp_lat, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
!
CALL intsurf_history(iim, jjm, tmp_lon, tmp_lat, kjit+itau_offset, &
& date0_shifted, xrdt, control_flags, hist_id, hist2_id, hist_id_stom)
!
IF ( watchout ) THEN
WRITE(numout,*) 'intersurf_main_1d : WARNING -- ORCHIDEE_watchout has not yet been '
WRITE(numout,*) ' implemented in this interface to ORCHIDEE'
ENDIF
!
IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
!
ENDIF
!
! 1. gather input fields from kindex array
!
DO ik=1, kjpindex
zu(ik) = u(kindex(ik))
zv(ik) = v(kindex(ik))
zzlev(ik) = zlev(kindex(ik))
zqair(ik) = qair(kindex(ik))
zprecip_rain(ik) = precip_rain(kindex(ik))*xrdt
zprecip_snow(ik) = precip_snow(kindex(ik))*xrdt
zlwdown(ik) = lwdown(kindex(ik))
zswnet(ik) = swnet(kindex(ik))
zswdown(ik) = swdown(kindex(ik))
ztemp_air(ik) = temp_air(kindex(ik))
zepot_air(ik) = epot_air(kindex(ik))
zccanopy(ik) = ccanopy(kindex(ik))
zpetAcoef(ik) = petAcoef(kindex(ik))
zpeqAcoef(ik) = peqAcoef(kindex(ik))
zpetBcoef(ik) = petBcoef(kindex(ik))
zpeqBcoef(ik) = peqBcoef(kindex(ik))
zcdrag(ik) = cdrag(kindex(ik))
zpb(ik) = pb(kindex(ik))
ENDDO
!
!
!
! 3. call sechiba for continental points only
!
IF ( check ) WRITE(numout,*) 'Calling sechiba'
!
! Shift the time step to phase the two models
!
itau_sechiba = kjit + itau_offset
!
CALL sechiba_main (itau_sechiba, iim*jjm, kjpindex, kindex, xrdt, date0_shifted, &
& lrestart_read, lrestart_write, control_flags, &
& lalo, contfrac, neighbours, resolution, &
! First level conditions
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul rveget
! & zzlev, zu, zv, zqair, ztemp_air, zepot_air, zccanopy, &
& zzlev, zu, zv, zqair, zqair, ztemp_air, ztemp_air, zepot_air, zccanopy, &
! Variables for the implicit coupling
& zcdrag, zpetAcoef, zpeqAcoef, zpetBcoef, zpeqBcoef, &
! Rain, snow, radiation and surface pressure
& zprecip_rain ,zprecip_snow, zlwdown, zswnet, zswdown, zpb, &
! Output : Fluxes
& zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, &
! Surface temperatures and surface properties
& ztsol_rad, ztemp_sol_new, zqsurf, zalbedo, zemis, zz0, &
! File ids
& rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom )
!
IF ( check ) WRITE(numout,*) 'out of SECHIBA'
!
! 4. scatter output fields
!
!
z0(:) = undef_sechiba
coastalflow(:) = undef_sechiba
riverflow(:) = undef_sechiba
tsol_rad(:) = undef_sechiba
vevapp(:) = undef_sechiba
temp_sol_new(:) = undef_sechiba
qsurf(:) = undef_sechiba
albedo(:,:) = undef_sechiba
fluxsens(:) = undef_sechiba
fluxlat(:) = undef_sechiba
emis(:) = undef_sechiba
cdrag(:) = undef_sechiba
dswnet(:) = undef_sechiba
dswdown(:) = undef_sechiba
!
DO ik=1, kjpindex
z0(kindex(ik)) = zz0(ik)
coastalflow(kindex(ik)) = zcoastal(ik)/1000.
riverflow(kindex(ik)) = zriver(ik)/1000.
tsol_rad(kindex(ik)) = ztsol_rad(ik)
vevapp(kindex(ik)) = zvevapp(ik)
temp_sol_new(kindex(ik)) = ztemp_sol_new(ik)
qsurf(kindex(ik)) = zqsurf(ik)
albedo(kindex(ik),1) = zalbedo(ik,1)
albedo(kindex(ik),2) = zalbedo(ik,2)
fluxsens(kindex(ik)) = zfluxsens(ik)
fluxlat(kindex(ik)) = zfluxlat(ik)
emis(kindex(ik)) = zemis(ik)
cdrag(kindex(ik)) = zcdrag(ik)
dswnet(kindex(ik)) = zswnet(ik)
dswdown(kindex(ik)) = zswdown(ik)
ENDDO
!
!
! Modified fields for variables scattered during the writing
!
dcoastal(:) = (zcoastal(:))/1000.
driver(:) = (zriver(:))/1000.
!
!
IF ( .NOT. l_first_intersurf) THEN
!
CALL histwrite(hist_id, 'LandPoints', itau_sechiba, (/ REAL(kindex) /), kjpindex, kindex)
CALL histwrite(hist_id, 'Areas', itau_sechiba, area, kjpindex, kindex)
CALL histwrite(hist_id, 'Contfrac', itau_sechiba, contfrac, kjpindex, kindex)
!
IF ( hist2_id > 0 ) THEN
CALL histwrite(hist2_id, 'LandPoints', itau_sechiba, (/ REAL(kindex) /), kjpindex, kindex)
ENDIF
!
IF ( .NOT. almaoutput ) THEN
!
! scattered during the writing
!
CALL histwrite (hist_id, 'evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
CALL histwrite (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
!
CALL histwrite (hist_id, 'temp_sol', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist_id, 'tsol_max', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist_id, 'tsol_min', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist_id, 'fluxsens', itau_sechiba, fluxsens, iim*jjm, kindex)
CALL histwrite (hist_id, 'fluxlat', itau_sechiba, fluxlat, iim*jjm, kindex)
CALL histwrite (hist_id, 'swnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist_id, 'swdown', itau_sechiba, dswdown, iim*jjm, kindex)
CALL histwrite (hist_id, 'alb_vis', itau_sechiba, albedo(:,1), iim*jjm, kindex)
CALL histwrite (hist_id, 'alb_nir', itau_sechiba, albedo(:,2), iim*jjm, kindex)
CALL histwrite (hist_id, 'tair', itau_sechiba, temp_air, iim*jjm, kindex)
CALL histwrite (hist_id, 'qair', itau_sechiba, qair, iim*jjm, kindex)
! Ajouts Nathalie - Juin 2006 - sauvegarde de t2m et q2m
CALL histwrite (hist_id, 'q2m', itau_sechiba, qair, iim*jjm, kindex)
CALL histwrite (hist_id, 't2m', itau_sechiba, temp_air, iim*jjm, kindex)
IF ( hist2_id > 0 ) THEN
CALL histwrite (hist2_id, 'evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
CALL histwrite (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
!
CALL histwrite (hist2_id, 'temp_sol', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, fluxsens, iim*jjm, kindex)
CALL histwrite (hist2_id, 'fluxlat', itau_sechiba, fluxlat, iim*jjm, kindex)
CALL histwrite (hist2_id, 'swnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist2_id, 'swdown', itau_sechiba, dswdown, iim*jjm, kindex)
CALL histwrite (hist2_id, 'alb_vis', itau_sechiba, albedo(:,1), iim*jjm, kindex)
CALL histwrite (hist2_id, 'alb_nir', itau_sechiba, albedo(:,2), iim*jjm, kindex)
CALL histwrite (hist2_id, 'tair', itau_sechiba, temp_air, iim*jjm, kindex)
CALL histwrite (hist2_id, 'qair', itau_sechiba, qair, iim*jjm, kindex)
CALL histwrite (hist2_id, 'q2m', itau_sechiba, qair, iim*jjm, kindex)
CALL histwrite (hist2_id, 't2m', itau_sechiba, temp_air, iim*jjm, kindex)
ENDIF
ELSE
CALL histwrite (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist_id, 'SWnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist_id, 'Qh', itau_sechiba, fluxsens, iim*jjm, kindex)
CALL histwrite (hist_id, 'Qle', itau_sechiba, fluxlat, iim*jjm, kindex)
CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist_id, 'RadT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
IF ( hist2_id > 0 ) THEN
CALL histwrite (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist2_id, 'SWnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist2_id, 'Qh', itau_sechiba, fluxsens, iim*jjm, kindex)
CALL histwrite (hist2_id, 'Qle', itau_sechiba, fluxlat, iim*jjm, kindex)
CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
CALL histwrite (hist2_id, 'RadT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
ENDIF
ENDIF
!
ENDIF
!
! 5.0 Transform the water fluxes into Kg/m^2s and m^3/s
!
DO ik=1, kjpindex
vevapp(kindex(ik)) = vevapp(kindex(ik))/xrdt
coastalflow(kindex(ik)) = coastalflow(kindex(ik))/xrdt
riverflow(kindex(ik)) = riverflow(kindex(ik))/xrdt
ENDDO
!
l_first_intersurf = .FALSE.
!
IF (long_print) WRITE (numout,*) ' intersurf_main done '
END SUBROUTINE intersurf_main_1d
!
!-------------------------------------------------------------------------------------
!
#ifdef CPP_PARA
SUBROUTINE intersurf_gathered (kjit, iim_glo, jjm_glo, offset, kjpindex, kindex, communicator, xrdt, &
& lrestart_read, lrestart_write, latlon, zcontfrac, zneighbours, zresolution, date0, &
! First level conditions
& zlev, u, v, qair, temp_air, epot_air, ccanopy, &
! Variables for the implicit coupling
& cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
! Surface temperatures and surface properties
& tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g)
#else
SUBROUTINE intersurf_gathered (kjit, iim_glo, jjm_glo, kjpindex, kindex, xrdt, &
& lrestart_read, lrestart_write, latlon, zcontfrac, zneighbours, zresolution, date0, &
! First level conditions
& zlev, u, v, qair, temp_air, epot_air, ccanopy, &
! Variables for the implicit coupling
& cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
! Surface temperatures and surface properties
& tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g)
#endif
! routines called : sechiba_main
!
IMPLICIT NONE
!
! interface description for dummy arguments
! input scalar
INTEGER(i_std),INTENT (in) :: kjit !! Time step number
INTEGER(i_std),INTENT (in) :: iim_glo, jjm_glo !! Dimension of global fields
#ifdef CPP_PARA
INTEGER(i_std),INTENT (in) :: offset !! offset between the first global 2D point
!! and the first local 2D point.
INTEGER(i_std),INTENT(IN) :: communicator !! Orchidee communicator
#endif
INTEGER(i_std),INTENT (in) :: kjpindex !! Number of continental points
REAL(r_std),INTENT (in) :: xrdt !! Time step in seconds
LOGICAL, INTENT (in) :: lrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT (in) :: lrestart_write!! Logical for _restart_ file to write'
REAL(r_std), INTENT (in) :: date0 !! Date at which kjit = 0
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: kindex !! Index for continental points
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: lwdown !! Down-welling long-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: swnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: swdown !! Downwelling surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: temp_air !! Air temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: epot_air !! Air potential energy
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: ccanopy !! CO2 concentration in the canopy
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: petAcoef !! Coeficients A from the PBL resolution
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: peqAcoef !! One for T and another for q
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: petBcoef !! Coeficients B from the PBL resolution
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: peqBcoef !! One for T and another for q
REAL(r_std),DIMENSION (kjpindex), INTENT(inout) :: cdrag !! Cdrag
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (kjpindex,2), INTENT(in) :: latlon !! Geographical coordinates
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: zcontfrac !! Fraction of continent
INTEGER(i_std),DIMENSION (kjpindex,8), INTENT(in) :: zneighbours !! neighbours
REAL(r_std),DIMENSION (kjpindex,2), INTENT(in) :: zresolution !! size of the grid box
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: z0 !! Surface roughness
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: coastalflow !! Diffuse flow of water into the ocean (m^3/dt)
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: riverflow !! Largest rivers flowing into the ocean (m^3/dt)
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: tsol_rad !! Radiative surface temperature
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: vevapp !! Total of evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: qsurf !! Surface specific humidity
REAL(r_std),DIMENSION (kjpindex,2), INTENT(out) :: albedo !! Albedo
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: fluxsens !! Sensible chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: fluxlat !! Latent chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: emis !! Emissivity
! LOCAL declaration
! work arrays to scatter and/or gather information just before/after sechiba_main call's
! and to keep output value for next call
REAL(r_std),DIMENSION (kjpindex) :: zccanopy !! Work array to keep ccanopy
REAL(r_std),DIMENSION (kjpindex) :: zprecip_rain !! Work array to keep precip_rain
REAL(r_std),DIMENSION (kjpindex) :: zprecip_snow !! Work array to keep precip_snow
REAL(r_std),DIMENSION (kjpindex) :: zz0 !! Work array to keep z0
REAL(r_std),DIMENSION (kjpindex) :: zcdrag !! Work array for surface drag
REAL(r_std),DIMENSION (kjpindex) :: zcoastal !! Work array to keep coastal flow
REAL(r_std),DIMENSION (kjpindex) :: zriver !! Work array to keep river out flow
REAL(r_std),DIMENSION (kjpindex) :: dcoastal !! Work array to keep coastal flow
REAL(r_std),DIMENSION (kjpindex) :: driver !! Work array to keep river out flow
REAL(r_std),DIMENSION (kjpindex) :: ztsol_rad !! Work array to keep tsol_rad
REAL(r_std),DIMENSION (kjpindex) :: zvevapp !! Work array to keep vevapp
REAL(r_std),DIMENSION (kjpindex) :: ztemp_sol_new !! Work array to keep temp_sol_new
REAL(r_std),DIMENSION (kjpindex) :: zqsurf !! Work array to keep qsurf
REAL(r_std),DIMENSION (kjpindex,2) :: zalbedo !! Work array to keep albedo
REAL(r_std),DIMENSION (kjpindex) :: zfluxsens !! Work array to keep fluxsens
REAL(r_std),DIMENSION (kjpindex) :: zfluxlat !! Work array to keep fluxlat
REAL(r_std),DIMENSION (kjpindex) :: zemis !! Work array to keep emis
!
! Optional arguments
!
REAL(r_std),DIMENSION (iim_glo,jjm_glo), INTENT(IN), OPTIONAL :: lon_scat_g, lat_scat_g !! The scattered values for longitude
!
INTEGER(i_std) :: iim,jjm !! local sizes
REAL(r_std),DIMENSION (:,:),ALLOCATABLE :: lon_scat, lat_scat !! The scattered values for longitude
! !! and latitude.
!
! Scattered variables for diagnostics
!
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dvevapp !! Diagnostic array for evaporation
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dtemp_sol !! for surface temperature
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dfluxsens !! for sensible heat flux
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dfluxlat !! for latent heat flux
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dswnet !! net solar radiation
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dswdown !! Incident solar radiation
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:,:) :: dalbedo !! albedo
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dtair !! air temperature
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dqair !! specific air humidity
!
!
INTEGER(i_std) :: i, j, ik
INTEGER(i_std) :: itau_sechiba
REAL(r_std) :: mx, zlev_mean
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: tmp_lon, tmp_lat, tmp_lev
LOGICAL :: do_watch !! if it's time, write watchout
LOGICAL :: check = .FALSE.
INTEGER(i_std),DIMENSION (kjpindex) :: kindex_p
!
LOGICAL, SAVE :: fatmco2 !! Flag to force the value of atmospheric CO2 for vegetation.
REAL(r_std), SAVE :: atmco2 !! atmospheric CO2
!
IF (l_first_intersurf) THEN
!
IF ( check ) WRITE(numout,*) 'Initialisation of intersurf'
!
CALL ioget_calendar (one_year, one_day)
!
#ifdef CPP_PARA
CALL init_para(.TRUE.,communicator)
kindex_p(:)=kindex(:) + offset
#else
CALL init_para(.FALSE.)
kindex_p(:)=kindex(:)
#endif
CALL init_data_para(iim_glo,jjm_glo,kjpindex,kindex_p)
iim=iim_glo
jjm=jj_nb
ALLOCATE(lon_scat(iim,jjm))
ALLOCATE(lat_scat(iim,jjm))
ALLOCATE(dvevapp(iim*jjm))
ALLOCATE(dtemp_sol(iim*jjm))
ALLOCATE(dfluxsens(iim*jjm))
ALLOCATE(dfluxlat(iim*jjm))
ALLOCATE(dswnet(iim*jjm))
ALLOCATE(dswdown(iim*jjm))
ALLOCATE(dalbedo(iim*jjm,2))
ALLOCATE(dtair(iim*jjm))
ALLOCATE(dqair(iim*jjm))
! CALL init_WriteField_p(kindex)
!
! Allocation of grid variables
!
CALL init_grid ( kjpindex )
!
! Create the internal coordinate table
!
lalo(:,:) = latlon(:,:)
CALL gather(lalo,lalo_g)
!
!-
!- Store variable to help describe the grid
!- once the points are gathered.
!-
neighbours(:,:) = zneighbours(:,:)
CALL gather(neighbours,neighbours_g)
!
resolution(:,:) = zresolution(:,:)
CALL gather(resolution,resolution_g)
!
!- Store the fraction of the continents only once so that the user
!- does not change them afterwards.
!
contfrac(:) = zcontfrac(:)
CALL gather(contfrac,contfrac_g)
!
!
! Create the internal coordinate table
!
IF ( (.NOT.ALLOCATED(tmp_lon))) THEN
ALLOCATE(tmp_lon(iim,jjm))
ENDIF
IF ( (.NOT.ALLOCATED(tmp_lat))) THEN
ALLOCATE(tmp_lat(iim,jjm))
ENDIF
IF ( (.NOT.ALLOCATED(tmp_lev))) THEN
ALLOCATE(tmp_lev(iim,jjm))
ENDIF
!
! Either we have the scattered coordinates as arguments or
! we have to do the work here.
!
IF ( PRESENT(lon_scat_g) .AND. PRESENT(lat_scat_g)) THEN
lon_scat(:,:)=zero
lat_scat(:,:)=zero
CALL scatter2D(lon_scat_g,lon_scat)
CALL scatter2D(lat_scat_g,lat_scat)
lon_scat(:,1)=lon_scat(:,2)
lon_scat(:,jj_nb)=lon_scat(:,2)
lat_scat(:,1)=lat_scat(iim,1)
lat_scat(:,jj_nb)=lat_scat(1,jj_nb)
tmp_lon(:,:) = lon_scat(:,:)
tmp_lat(:,:) = lat_scat(:,:)
IF (is_root_prc) THEN
lon_g(:,:) = lon_scat_g(:,:)
lat_g(:,:) = lat_scat_g(:,:)
ENDIF
ELSE IF ( PRESENT(lon_scat_g) .OR. PRESENT(lat_scat_g)) THEN
WRITE(numout,*) 'You need to provide the longitude AND latitude on the'
WRITE(numout,*) 'gathered grid in order to start ORCHIDEE.'
STOP 'intersurf_gathered'
ELSE
!
WRITE(numout,*) 'intersurf_gathered : We try to guess to full grid of the model.'
WRITE(numout,*) 'I might fail, please report if it does. '
!
tmp_lon(:,:) = val_exp
tmp_lat(:,:) = val_exp
!
DO ik=1, kjpindex
j = INT( (kindex(ik)-1) / iim ) + 1
i = kindex(ik) - (j-1) * iim
tmp_lon(i,j) = lalo(ik,2)
tmp_lat(i,j) = lalo(ik,1)
ENDDO
!
! Here we fill out the grid. To do this we do the strong hypothesis
! that the grid is regular. Will this work in all cases ????
!
DO i=1,iim
mx = MAXVAL(tmp_lon(i,:), MASK=tmp_lon(i,:) .LT. val_exp)
IF ( mx .LT. val_exp ) THEN
tmp_lon(i,:) = mx
ELSE
WRITE(numout,*) 'Could not find a continental point on this longitude. Thus the grid'
WRITE(numout,*) 'could not be completed.'
STOP 'intersurf_gathered'
ENDIF
ENDDO
!
DO j=1,jjm
mx = MAXVAL(tmp_lat(:,j), MASK=tmp_lat(:,j) .LT. val_exp)
IF ( mx .LT. val_exp ) THEN
tmp_lat(:,j) = mx
ELSE
WRITE(numout,*) 'Could not find a continental point on this latitude. Thus the grid'
WRITE(numout,*) 'could not be completed.'
STOP 'intersurf_gathered'
ENDIF
ENDDO
CALL gather2D(tmp_lon,lon_g)
CALL gather2D(tmp_lat,lat_g)
ENDIF
!
DO ik=1, kjpindex
j = INT( (kindex(ik)-1) / iim ) + 1
i = kindex(ik) - (j-1) * iim
tmp_lev(i,j) = zlev(ik)
ENDDO
CALL gather2D(tmp_lev,zlev_g)
!
!
! Configuration of SSL specific parameters
!
CALL intsurf_config(control_flags,xrdt)
!
!Config Key = FORCE_CO2_VEG
!Config Desc = Flag to force the value of atmospheric CO2 for vegetation.
!Config Def = FALSE
!Config Help = If this flag is set to true, the ATM_CO2 parameter is used
!Config to prescribe the atmospheric CO2.
!Config This Flag is only use in couple mode.
!
fatmco2=.FALSE.
CALL getin_p('FORCE_CO2_VEG',fatmco2)
!
! Next flag is only use in couple mode with a gcm in intersurf.
! In forced mode, it has already been read and set in driver.
IF ( fatmco2 ) THEN
!Config Key = ATM_CO2
!Config IF = FORCE_CO2_VEG (in not forced mode)
!Config Desc = Value for atm CO2
!Config Def = 350.
!Config Help = Value to prescribe the atm CO2.
!Config For pre-industrial simulations, the value is 286.2 .
!Config 348. for 1990 year.
!
atmco2=350.
CALL getin_p('ATM_CO2',atmco2)
WRITE(*,*) 'atmco2 ',atmco2
ENDIF
!
CALL intsurf_restart(kjit, iim, jjm, tmp_lon, tmp_lat, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
!
CALL intsurf_history(iim, jjm, tmp_lon, tmp_lat, kjit+itau_offset, &
& date0_shifted, xrdt, control_flags, hist_id, hist2_id, hist_id_stom)
!
IF ( watchout ) THEN
IF (is_root_prc) THEN
zlev_mean = 0.
DO ik=1, nbp_glo
j = ((index_g(ik)-1)/iim_g) + 1
i = (index_g(ik) - (j-1)*iim_g)
zlev_mean = zlev_mean + zlev_g(i,j)
ENDDO
zlev_mean = zlev_mean / REAL(nbp_glo,r_std)
ENDIF
last_action_watch = kjit + itau_offset
last_check_watch = last_action_watch
! Only root proc write watchout file
IF (is_root_prc) &
CALL intersurf_initwatch(iim_g, jjm_g, nbp_glo, &
& date0_shifted, kjit+itau_offset, dt_watch, index_g, lon_g, lat_g, zlev_mean)
ALLOCATE(sum_rain(kjpindex), sum_snow(kjpindex))
ALLOCATE(sum_swdown(kjpindex))
sum_rain(:) = 0.0
sum_snow(:) = 0.0
sum_swdown(:) = 0.0
ENDIF
!
IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
!
ENDIF
!
! Shift the time step to phase the two models
!
itau_sechiba = kjit + itau_offset
!
! 1. Just change the units of some input fields
!
DO ik=1, kjpindex
zprecip_rain(ik) = precip_rain(ik)*xrdt
zprecip_snow(ik) = precip_snow(ik)*xrdt
zcdrag(ik) = cdrag(ik)
ENDDO
!
!
IF (check_INPUTS) THEN
print *,"Intersurf_main_gathered :"
print *,"Time step number = ",kjit
print *,"Dimension of input fields = ",iim, jjm
print *,"Number of continental points = ",kjpindex
print *,"Time step in seconds = ",xrdt
print *,"Logical for _restart_ file to read, write = ",lrestart_read,lrestart_write
print *,"Date at which kjit = 0 = ",date0
print *,"Index for continental points = ",kindex
print *,"Lowest level wind speed North = ",u
print *,"Lowest level wind speed East = ",v
print *,"Height of first layer = ",zlev
print *,"Lowest level specific humidity = ",qair
print *,"Rain precipitation = ",zprecip_rain
print *,"Snow precipitation = ",zprecip_snow
print *,"Down-welling long-wave flux = ",lwdown
print *,"Net surface short-wave flux = ",swnet
print *,"Downwelling surface short-wave flux = ",swdown
print *,"Air temperature in Kelvin = ",temp_air
print *,"Air potential energy = ",epot_air
print *,"CO2 concentration in the canopy = ",ccanopy
print *,"Coeficients A from the PBL resolution = ",petAcoef
print *,"One for T and another for q = ",peqAcoef
print *,"Coeficients B from the PBL resolution = ",petBcoef
print *,"One for T and another for q = ",peqBcoef
print *,"Cdrag = ",zcdrag
print *,"Lowest level pressure = ",pb
print *,"Geographical coordinates lon = ", lon_scat
print *,"Geographical coordinates lat = ", lat_scat
print *,"Fraction of continent in the grid = ",zcontfrac
ENDIF
!
! 3. call sechiba for continental points only
!
IF ( check ) WRITE(numout,*) 'Calling sechiba'
!
IF ( watchout ) THEN
do_watch = .FALSE.
call isittime &
& (itau_sechiba,date0_shifted,xrdt,dt_watch,&
& last_action_watch,last_check_watch,do_watch)
last_check_watch = itau_sechiba
IF ( .NOT. l_first_intersurf .AND. do_watch) THEN
IF (long_print) THEN
print *,"intersurf : write watchout for date ",date0,date0_shifted,itau_sechiba,last_action_watch,last_check_watch
ENDIF
last_action_watch = itau_sechiba
sum_rain(:) = sum_rain(:) + zprecip_rain(:)
sum_snow(:) = sum_snow(:) + zprecip_snow(:)
sum_rain(:) = sum_rain(:) / dt_split_watch
sum_snow(:) = sum_snow(:) / dt_split_watch
sum_swdown(:) = sum_swdown(:) + swdown(:)
sum_swdown(:) = sum_swdown(:) / dt_split_watch
CALL intersurf_wrtwatch_p(kjpindex, itau_sechiba, xrdt, zlev, sum_swdown, sum_rain, &
& sum_snow, lwdown, pb, temp_air, epot_air, qair, u, v, &
& swnet, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag )
sum_rain(:) = 0.0
sum_snow(:) = 0.0
sum_swdown(:) = 0.0
ELSE
sum_rain(:) = sum_rain(:) + zprecip_rain(:)
sum_snow(:) = sum_snow(:) + zprecip_snow(:)
sum_swdown(:) = sum_swdown(:) + swdown(:)
ENDIF
ENDIF
!
IF ( fatmco2 ) THEN
zccanopy(:) = atmco2
WRITE (*,*) 'Modification of the ccanopy value. CO2 = ',atmco2
ELSE
zccanopy(:) = ccanopy(:)
ENDIF
!
CALL sechiba_main (itau_sechiba, iim*jjm, kjpindex, kindex, xrdt, date0_shifted, &
& lrestart_read, lrestart_write, control_flags, &
& lalo, contfrac, neighbours, resolution, &
! First level conditions
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul rveget
! & zlev, u, v, qair, temp_air, epot_air, ccanopy, &
& zlev, u, v, qair, qair, temp_air, temp_air, epot_air, zccanopy, &
! Variables for the implicit coupling
& zcdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& zprecip_rain ,zprecip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, &
! Surface temperatures and surface properties
& ztsol_rad, ztemp_sol_new, zqsurf, zalbedo, zemis, zz0, &
! File ids
& rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom )
!
IF ( check ) WRITE(numout,*) 'out of SECHIBA'
!
! 4. scatter output fields
!
z0(:) = undef_sechiba
coastalflow(:) = undef_sechiba
riverflow(:) = undef_sechiba
tsol_rad(:) = undef_sechiba
vevapp(:) = undef_sechiba
temp_sol_new(:) = undef_sechiba
qsurf(:) = undef_sechiba
albedo(:,1) = undef_sechiba
albedo(:,2) = undef_sechiba
fluxsens(:) = undef_sechiba
fluxlat(:) = undef_sechiba
emis(:) = undef_sechiba
cdrag(:) = undef_sechiba
!
dvevapp(:) = undef_sechiba
dtemp_sol(:) = undef_sechiba
dfluxsens(:) = undef_sechiba
dfluxlat(:) = undef_sechiba
dswnet (:) = undef_sechiba
dswdown (:) = undef_sechiba
dalbedo (:,1) = undef_sechiba
dalbedo (:,2) = undef_sechiba
dtair (:) = undef_sechiba
dqair (:) = undef_sechiba
!
DO ik=1, kjpindex
z0(ik) = zz0(ik)
coastalflow(ik) = zcoastal(ik)/1000.
riverflow(ik) = zriver(ik)/1000.
tsol_rad(ik) = ztsol_rad(ik)
vevapp(ik) = zvevapp(ik)
temp_sol_new(ik) = ztemp_sol_new(ik)
qsurf(ik) = zqsurf(ik)
albedo(ik,1) = zalbedo(ik,1)
albedo(ik,2) = zalbedo(ik,2)
fluxsens(ik) = zfluxsens(ik)
fluxlat(ik) = zfluxlat(ik)
emis(ik) = zemis(ik)
cdrag(ik) = zcdrag(ik)
! Fill up the diagnostic arrays
dvevapp(kindex(ik)) = zvevapp(ik)
dtemp_sol(kindex(ik)) = ztemp_sol_new(ik)
dfluxsens(kindex(ik)) = zfluxsens(ik)
dfluxlat(kindex(ik)) = zfluxlat(ik)
dswnet (kindex(ik)) = swnet(ik)
dswdown (kindex(ik)) = swdown(ik)
dalbedo (kindex(ik),1) = zalbedo(ik,1)
dalbedo (kindex(ik),2) = zalbedo(ik,2)
dtair (kindex(ik)) = temp_air(ik)
dqair (kindex(ik)) = qair(ik)
!
ENDDO
! Modified fields for variables scattered during the writing
!
dcoastal(:) = (zcoastal(:))/1000.
driver(:) = (zriver(:))/1000.
!
!
!
!
IF ( .NOT. l_first_intersurf) THEN
!
CALL histwrite(hist_id, 'LandPoints', itau_sechiba, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
CALL histwrite(hist_id, 'Areas', itau_sechiba, area, kjpindex, kindex)
CALL histwrite(hist_id, 'Contfrac', itau_sechiba, contfrac, kjpindex, kindex)
!
IF ( hist2_id > 0 ) THEN
CALL histwrite(hist2_id, 'LandPoints', itau_sechiba, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
ENDIF
!
IF ( .NOT. almaoutput ) THEN
!
! scattered during the writing
!
CALL histwrite (hist_id, 'evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
CALL histwrite (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
!
CALL histwrite (hist_id, 'temp_sol', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist_id, 'tsol_max', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist_id, 'tsol_min', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist_id, 'fluxsens', itau_sechiba, dfluxsens, iim*jjm, kindex)
CALL histwrite (hist_id, 'fluxlat', itau_sechiba, dfluxlat, iim*jjm, kindex)
CALL histwrite (hist_id, 'swnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist_id, 'swdown', itau_sechiba, dswdown, iim*jjm, kindex)
CALL histwrite (hist_id, 'alb_vis', itau_sechiba, dalbedo(:,1), iim*jjm, kindex)
CALL histwrite (hist_id, 'alb_nir', itau_sechiba, dalbedo(:,2), iim*jjm, kindex)
CALL histwrite (hist_id, 'tair', itau_sechiba, dtair, iim*jjm, kindex)
CALL histwrite (hist_id, 'qair', itau_sechiba, dqair, iim*jjm, kindex)
CALL histwrite (hist_id, 't2m', itau_sechiba, dtair, iim*jjm, kindex)
CALL histwrite (hist_id, 'q2m', itau_sechiba, dqair, iim*jjm, kindex)
!
IF ( hist2_id > 0 ) THEN
CALL histwrite (hist2_id, 'evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
CALL histwrite (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
!
CALL histwrite (hist2_id, 'temp_sol', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, dfluxsens, iim*jjm, kindex)
CALL histwrite (hist2_id, 'fluxlat', itau_sechiba, dfluxlat, iim*jjm, kindex)
CALL histwrite (hist2_id, 'swnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist2_id, 'swdown', itau_sechiba, dswdown, iim*jjm, kindex)
CALL histwrite (hist2_id, 'alb_vis', itau_sechiba, dalbedo(:,1), iim*jjm, kindex)
CALL histwrite (hist2_id, 'alb_nir', itau_sechiba, dalbedo(:,2), iim*jjm, kindex)
CALL histwrite (hist2_id, 'tair', itau_sechiba, dtair, iim*jjm, kindex)
CALL histwrite (hist2_id, 'qair', itau_sechiba, dqair, iim*jjm, kindex)
CALL histwrite (hist2_id, 't2m', itau_sechiba, dtair, iim*jjm, kindex)
CALL histwrite (hist2_id, 'q2m', itau_sechiba, dqair, iim*jjm, kindex)
ENDIF
ELSE
!
CALL histwrite (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist_id, 'SWnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist_id, 'Qh', itau_sechiba, dfluxsens, iim*jjm, kindex)
CALL histwrite (hist_id, 'Qle', itau_sechiba, dfluxlat, iim*jjm, kindex)
CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist_id, 'RadT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
!
IF ( hist2_id > 0 ) THEN
CALL histwrite (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist2_id, 'SWnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist2_id, 'Qh', itau_sechiba, dfluxsens, iim*jjm, kindex)
CALL histwrite (hist2_id, 'Qle', itau_sechiba, dfluxlat, iim*jjm, kindex)
CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist2_id, 'RadT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
ENDIF
ENDIF
!
ENDIF
!
! 5.0 Transform the water fluxes into Kg/m^2s and m^3/s
!
DO ik=1, kjpindex
vevapp(ik) = vevapp(ik)/xrdt
coastalflow(ik) = coastalflow(ik)/xrdt
riverflow(ik) = riverflow(ik)/xrdt
ENDDO
!
IF ( lrestart_write .AND. watchout ) THEN
IF (is_root_prc) CALL intersurf_clowatch()
ENDIF
!
l_first_intersurf = .FALSE.
!
IF (long_print) WRITE (numout,*) ' intersurf_main done '
END SUBROUTINE intersurf_gathered
!
!
#ifdef CPP_PARA
SUBROUTINE intersurf_gathered_2m (kjit, iim_glo, jjm_glo, offset, kjpindex, kindex, communicator, xrdt, &
& lrestart_read, lrestart_write, latlon, zcontfrac, zneighbours, zresolution, date0, &
! First level conditions
& zlev, u, v, qair, temp_air, epot_air, ccanopy, &
! Variables for the implicit coupling
& cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
! Surface temperatures and surface properties
! & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g)
& tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g, &
! Ajout Nathalie - passage q2m/t2m pour calcul Rveget
& q2m, t2m)
#else
SUBROUTINE intersurf_gathered_2m (kjit, iim_glo, jjm_glo, kjpindex, kindex, xrdt, &
& lrestart_read, lrestart_write, latlon, zcontfrac, zneighbours, zresolution, date0, &
! First level conditions
& zlev, u, v, qair, temp_air, epot_air, ccanopy, &
! Variables for the implicit coupling
& cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
! Surface temperatures and surface properties
! & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g)
& tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g, &
! Ajout Nathalie - passage q2m/t2m pour calcul Rveget
& q2m, t2m)
#endif
! routines called : sechiba_main
!
IMPLICIT NONE
!
! interface description for dummy arguments
! input scalar
INTEGER(i_std),INTENT (in) :: kjit !! Time step number
INTEGER(i_std),INTENT (in) :: iim_glo, jjm_glo !! Dimension of global fields
#ifdef CPP_PARA
INTEGER(i_std),INTENT (in) :: offset !! offset between the first global 2D point
!! and the first local 2D point.
INTEGER(i_std),INTENT(IN) :: communicator !! Orchidee communicator
#endif
INTEGER(i_std),INTENT (in) :: kjpindex !! Number of continental points
REAL(r_std),INTENT (in) :: xrdt !! Time step in seconds
LOGICAL, INTENT (in) :: lrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT (in) :: lrestart_write!! Logical for _restart_ file to write'
REAL(r_std), INTENT (in) :: date0 !! Date at which kjit = 0
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: kindex !! Index for continental points
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: qair !! Lowest level specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: lwdown !! Down-welling long-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: swnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: swdown !! Downwelling surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: temp_air !! Air temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: epot_air !! Air potential energy
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: ccanopy !! CO2 concentration in the canopy
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: petAcoef !! Coeficients A from the PBL resolution
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: peqAcoef !! One for T and another for q
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: petBcoef !! Coeficients B from the PBL resolution
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: peqBcoef !! One for T and another for q
REAL(r_std),DIMENSION (kjpindex), INTENT(inout) :: cdrag !! Cdrag
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (kjpindex,2), INTENT(in) :: latlon !! Geographical coordinates
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: zcontfrac !! Fraction of continent
INTEGER(i_std),DIMENSION (kjpindex,8), INTENT(in) :: zneighbours !! neighbours
REAL(r_std),DIMENSION (kjpindex,2), INTENT(in) :: zresolution !! size of the grid box
! Ajout Nathalie - Juin 2006 - q2m/t2m pour calcul Rveget
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: q2m !! Surface specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: t2m !! Surface air temperature
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: z0 !! Surface roughness
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: coastalflow !! Diffuse flow of water into the ocean (m^3/dt)
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: riverflow !! Largest rivers flowing into the ocean (m^3/dt)
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: tsol_rad !! Radiative surface temperature
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: vevapp !! Total of evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: qsurf !! Surface specific humidity
REAL(r_std),DIMENSION (kjpindex,2), INTENT(out) :: albedo !! Albedo
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: fluxsens !! Sensible chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: fluxlat !! Latent chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: emis !! Emissivity
! LOCAL declaration
! work arrays to scatter and/or gather information just before/after sechiba_main call's
! and to keep output value for next call
REAL(r_std),DIMENSION (kjpindex) :: zccanopy !! Work array to keep ccanopy
REAL(r_std),DIMENSION (kjpindex) :: zprecip_rain !! Work array to keep precip_rain
REAL(r_std),DIMENSION (kjpindex) :: zprecip_snow !! Work array to keep precip_snow
REAL(r_std),DIMENSION (kjpindex) :: zz0 !! Work array to keep z0
REAL(r_std),DIMENSION (kjpindex) :: zcdrag !! Work array for surface drag
REAL(r_std),DIMENSION (kjpindex) :: zcoastal !! Work array to keep coastal flow
REAL(r_std),DIMENSION (kjpindex) :: zriver !! Work array to keep river out flow
REAL(r_std),DIMENSION (kjpindex) :: dcoastal !! Work array to keep coastal flow
REAL(r_std),DIMENSION (kjpindex) :: driver !! Work array to keep river out flow
REAL(r_std),DIMENSION (kjpindex) :: ztsol_rad !! Work array to keep tsol_rad
REAL(r_std),DIMENSION (kjpindex) :: zvevapp !! Work array to keep vevapp
REAL(r_std),DIMENSION (kjpindex) :: ztemp_sol_new !! Work array to keep temp_sol_new
REAL(r_std),DIMENSION (kjpindex) :: zqsurf !! Work array to keep qsurf
REAL(r_std),DIMENSION (kjpindex,2) :: zalbedo !! Work array to keep albedo
REAL(r_std),DIMENSION (kjpindex) :: zfluxsens !! Work array to keep fluxsens
REAL(r_std),DIMENSION (kjpindex) :: zfluxlat !! Work array to keep fluxlat
REAL(r_std),DIMENSION (kjpindex) :: zemis !! Work array to keep emis
!
! Optional arguments
!
REAL(r_std),DIMENSION (iim_glo,jjm_glo), INTENT(IN), OPTIONAL :: lon_scat_g, lat_scat_g !! The scattered values for longitude
!
INTEGER(i_std) :: iim,jjm !! local sizes
REAL(r_std),DIMENSION (:,:),ALLOCATABLE :: lon_scat, lat_scat !! The scattered values for longitude
! !! and latitude.
!
! Scattered variables for diagnostics
!
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dvevapp !! Diagnostic array for evaporation
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dtemp_sol !! for surface temperature
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dfluxsens !! for sensible heat flux
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dfluxlat !! for latent heat flux
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dswnet !! net solar radiation
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dswdown !! Incident solar radiation
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:,:) :: dalbedo !! albedo
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dtair !! air temperature
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dqair !! specific air humidity
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dq2m !! Surface specific humidity
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:) :: dt2m !! Surface air temperature
!
!
INTEGER(i_std) :: i, j, ik
INTEGER(i_std) :: itau_sechiba
REAL(r_std) :: mx, zlev_mean
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: tmp_lon, tmp_lat, tmp_lev
LOGICAL :: do_watch !! if it's time, write watchout
LOGICAL :: check = .FALSE.
INTEGER(i_std),DIMENSION (kjpindex) :: kindex_p
!
LOGICAL, SAVE :: fatmco2 !! Flag to force the value of atmospheric CO2 for vegetation.
REAL(r_std), SAVE :: atmco2 !! atmospheric CO2
!
IF (l_first_intersurf) THEN
!
IF ( check ) WRITE(numout,*) 'Initialisation of intersurf'
!
CALL ioget_calendar (one_year, one_day)
!
#ifdef CPP_PARA
CALL init_para(.TRUE.,communicator)
kindex_p(:)=kindex(:) + offset
#else
CALL init_para(.FALSE.)
kindex_p(:)=kindex(:)
#endif
CALL init_data_para(iim_glo,jjm_glo,kjpindex,kindex_p)
iim=iim_glo
jjm=jj_nb
ALLOCATE(lon_scat(iim,jjm))
ALLOCATE(lat_scat(iim,jjm))
ALLOCATE(dvevapp(iim*jjm))
ALLOCATE(dtemp_sol(iim*jjm))
ALLOCATE(dfluxsens(iim*jjm))
ALLOCATE(dfluxlat(iim*jjm))
ALLOCATE(dswnet(iim*jjm))
ALLOCATE(dswdown(iim*jjm))
ALLOCATE(dalbedo(iim*jjm,2))
ALLOCATE(dtair(iim*jjm))
ALLOCATE(dqair(iim*jjm))
ALLOCATE(dq2m(iim*jjm))
ALLOCATE(dt2m(iim*jjm))
! CALL init_WriteField_p(kindex)
!
! Allocation of grid variables
!
CALL init_grid ( kjpindex )
!
! Create the internal coordinate table
!
lalo(:,:) = latlon(:,:)
CALL gather(lalo,lalo_g)
!
!-
!- Store variable to help describe the grid
!- once the points are gathered.
!-
neighbours(:,:) = zneighbours(:,:)
CALL gather(neighbours,neighbours_g)
!
resolution(:,:) = zresolution(:,:)
CALL gather(resolution,resolution_g)
!
!- Store the fraction of the continents only once so that the user
!- does not change them afterwards.
!
contfrac(:) = zcontfrac(:)
CALL gather(contfrac,contfrac_g)
!
!
! Create the internal coordinate table
!
IF ( (.NOT.ALLOCATED(tmp_lon))) THEN
ALLOCATE(tmp_lon(iim,jjm))
ENDIF
IF ( (.NOT.ALLOCATED(tmp_lat))) THEN
ALLOCATE(tmp_lat(iim,jjm))
ENDIF
IF ( (.NOT.ALLOCATED(tmp_lev))) THEN
ALLOCATE(tmp_lev(iim,jjm))
ENDIF
!
! Either we have the scattered coordinates as arguments or
! we have to do the work here.
!
IF ( PRESENT(lon_scat_g) .AND. PRESENT(lat_scat_g)) THEN
lon_scat(:,:)=zero
lat_scat(:,:)=zero
CALL scatter2D(lon_scat_g,lon_scat)
CALL scatter2D(lat_scat_g,lat_scat)
lon_scat(:,1)=lon_scat(:,2)
lon_scat(:,jj_nb)=lon_scat(:,2)
lat_scat(:,1)=lat_scat(iim,1)
lat_scat(:,jj_nb)=lat_scat(1,jj_nb)
tmp_lon(:,:) = lon_scat(:,:)
tmp_lat(:,:) = lat_scat(:,:)
IF (is_root_prc) THEN
lon_g(:,:) = lon_scat_g(:,:)
lat_g(:,:) = lat_scat_g(:,:)
ENDIF
ELSE IF ( PRESENT(lon_scat_g) .OR. PRESENT(lat_scat_g)) THEN
WRITE(numout,*) 'You need to provide the longitude AND latitude on the'
WRITE(numout,*) 'gathered grid in order to start ORCHIDEE.'
STOP 'intersurf_gathered'
ELSE
!
WRITE(numout,*) 'intersurf_gathered : We try to guess to full grid of the model.'
WRITE(numout,*) 'I might fail, please report if it does. '
!
tmp_lon(:,:) = val_exp
tmp_lat(:,:) = val_exp
!
DO ik=1, kjpindex
j = INT( (kindex(ik)-1) / iim ) + 1
i = kindex(ik) - (j-1) * iim
tmp_lon(i,j) = lalo(ik,2)
tmp_lat(i,j) = lalo(ik,1)
ENDDO
!
! Here we fill out the grid. To do this we do the strong hypothesis
! that the grid is regular. Will this work in all cases ????
!
DO i=1,iim
mx = MAXVAL(tmp_lon(i,:), MASK=tmp_lon(i,:) .LT. val_exp)
IF ( mx .LT. val_exp ) THEN
tmp_lon(i,:) = mx
ELSE
WRITE(numout,*) 'Could not find a continental point on this longitude. Thus the grid'
WRITE(numout,*) 'could not be completed.'
STOP 'intersurf_gathered'
ENDIF
ENDDO
!
DO j=1,jjm
mx = MAXVAL(tmp_lat(:,j), MASK=tmp_lat(:,j) .LT. val_exp)
IF ( mx .LT. val_exp ) THEN
tmp_lat(:,j) = mx
ELSE
WRITE(numout,*) 'Could not find a continental point on this latitude. Thus the grid'
WRITE(numout,*) 'could not be completed.'
STOP 'intersurf_gathered'
ENDIF
ENDDO
CALL gather2D(tmp_lon,lon_g)
CALL gather2D(tmp_lat,lat_g)
ENDIF
!
DO ik=1, kjpindex
j = INT( (kindex(ik)-1) / iim ) + 1
i = kindex(ik) - (j-1) * iim
tmp_lev(i,j) = zlev(ik)
ENDDO
CALL gather2D(tmp_lev,zlev_g)
!
!
! Configuration of SSL specific parameters
!
CALL intsurf_config(control_flags,xrdt)
!
!Config Key = FORCE_CO2_VEG
!Config Desc = Flag to force the value of atmospheric CO2 for vegetation.
!Config Def = FALSE
!Config Help = If this flag is set to true, the ATM_CO2 parameter is used
!Config to prescribe the atmospheric CO2.
!Config This Flag is only use in couple mode.
!
fatmco2=.FALSE.
CALL getin_p('FORCE_CO2_VEG',fatmco2)
!
! Next flag is only use in couple mode with a gcm in intersurf.
! In forced mode, it has already been read and set in driver.
IF ( fatmco2 ) THEN
!Config Key = ATM_CO2
!Config IF = FORCE_CO2_VEG (in not forced mode)
!Config Desc = Value for atm CO2
!Config Def = 350.
!Config Help = Value to prescribe the atm CO2.
!Config For pre-industrial simulations, the value is 286.2 .
!Config 348. for 1990 year.
!
atmco2=350.
CALL getin_p('ATM_CO2',atmco2)
WRITE(*,*) 'atmco2 ',atmco2
ENDIF
!
CALL intsurf_restart(kjit, iim, jjm, tmp_lon, tmp_lat, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
!
CALL intsurf_history(iim, jjm, tmp_lon, tmp_lat, kjit+itau_offset, &
& date0_shifted, xrdt, control_flags, hist_id, hist2_id, hist_id_stom)
!
IF ( watchout ) THEN
IF (is_root_prc) THEN
zlev_mean = 0.
DO ik=1, nbp_glo
j = ((index_g(ik)-1)/iim_g) + 1
i = (index_g(ik) - (j-1)*iim_g)
zlev_mean = zlev_mean + zlev_g(i,j)
ENDDO
zlev_mean = zlev_mean / REAL(nbp_glo,r_std)
ENDIF
last_action_watch = kjit + itau_offset
last_check_watch = last_action_watch
! Only root proc write watchout file
IF (is_root_prc) &
CALL intersurf_initwatch(iim_g, jjm_g, nbp_glo, &
& date0_shifted, kjit+itau_offset, dt_watch, index_g, lon_g, lat_g, zlev_mean)
ALLOCATE(sum_rain(kjpindex), sum_snow(kjpindex))
ALLOCATE(sum_swdown(kjpindex))
sum_rain(:) = 0.0
sum_snow(:) = 0.0
sum_swdown(:) = 0.0
ENDIF
!
IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
!
ENDIF
!
! Shift the time step to phase the two models
!
itau_sechiba = kjit + itau_offset
!
! 1. Just change the units of some input fields
!
DO ik=1, kjpindex
zprecip_rain(ik) = precip_rain(ik)*xrdt
zprecip_snow(ik) = precip_snow(ik)*xrdt
zcdrag(ik) = cdrag(ik)
ENDDO
!
!
IF (check_INPUTS) THEN
print *,"Intersurf_main_gathered :"
print *,"Time step number = ",kjit
print *,"Dimension of input fields = ",iim, jjm
print *,"Number of continental points = ",kjpindex
print *,"Time step in seconds = ",xrdt
print *,"Logical for _restart_ file to read, write = ",lrestart_read,lrestart_write
print *,"Date at which kjit = 0 = ",date0
print *,"Index for continental points = ",kindex
print *,"Lowest level wind speed North = ",u
print *,"Lowest level wind speed East = ",v
print *,"Height of first layer = ",zlev
print *,"Lowest level specific humidity = ",qair
print *,"Rain precipitation = ",zprecip_rain
print *,"Snow precipitation = ",zprecip_snow
print *,"Down-welling long-wave flux = ",lwdown
print *,"Net surface short-wave flux = ",swnet
print *,"Downwelling surface short-wave flux = ",swdown
print *,"Air temperature in Kelvin = ",temp_air
print *,"Air potential energy = ",epot_air
print *,"CO2 concentration in the canopy = ",ccanopy
print *,"Coeficients A from the PBL resolution = ",petAcoef
print *,"One for T and another for q = ",peqAcoef
print *,"Coeficients B from the PBL resolution = ",petBcoef
print *,"One for T and another for q = ",peqBcoef
print *,"Cdrag = ",zcdrag
print *,"Lowest level pressure = ",pb
print *,"Geographical coordinates lon = ", lon_scat
print *,"Geographical coordinates lat = ", lat_scat
print *,"Fraction of continent in the grid = ",zcontfrac
ENDIF
!
! 3. call sechiba for continental points only
!
IF ( check ) WRITE(numout,*) 'Calling sechiba'
!
IF ( watchout ) THEN
do_watch = .FALSE.
call isittime &
& (itau_sechiba,date0_shifted,xrdt,dt_watch,&
& last_action_watch,last_check_watch,do_watch)
last_check_watch = itau_sechiba
IF ( .NOT. l_first_intersurf .AND. do_watch) THEN
IF (long_print) THEN
print *,"intersurf : write watchout for date ",date0,date0_shifted,itau_sechiba,last_action_watch,last_check_watch
ENDIF
last_action_watch = itau_sechiba
sum_rain(:) = sum_rain(:) + zprecip_rain(:)
sum_snow(:) = sum_snow(:) + zprecip_snow(:)
sum_rain(:) = sum_rain(:) / dt_split_watch
sum_snow(:) = sum_snow(:) / dt_split_watch
sum_swdown(:) = sum_swdown(:) + swdown(:)
sum_swdown(:) = sum_swdown(:) / dt_split_watch
CALL intersurf_wrtwatch_p(kjpindex, itau_sechiba, xrdt, zlev, sum_swdown, sum_rain, &
& sum_snow, lwdown, pb, temp_air, epot_air, qair, u, v, &
& swnet, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag )
sum_rain(:) = 0.0
sum_snow(:) = 0.0
sum_swdown(:) = 0.0
ELSE
sum_rain(:) = sum_rain(:) + zprecip_rain(:)
sum_snow(:) = sum_snow(:) + zprecip_snow(:)
sum_swdown(:) = sum_swdown(:) + swdown(:)
ENDIF
ENDIF
!
IF ( fatmco2 ) THEN
zccanopy(:) = atmco2
WRITE (*,*) 'Modification of the ccanopy value. CO2 = ',atmco2
ELSE
zccanopy(:) = ccanopy(:)
ENDIF
!
CALL sechiba_main (itau_sechiba, iim*jjm, kjpindex, kindex, xrdt, date0_shifted, &
& lrestart_read, lrestart_write, control_flags, &
& lalo, contfrac, neighbours, resolution, &
! First level conditions
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul rveget
! & zlev, u, v, qair, temp_air, epot_air, ccanopy, &
& zlev, u, v, qair, q2m, t2m, temp_air, epot_air, zccanopy, &
! Variables for the implicit coupling
& zcdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& zprecip_rain ,zprecip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, &
! Surface temperatures and surface properties
& ztsol_rad, ztemp_sol_new, zqsurf, zalbedo, zemis, zz0, &
! File ids
& rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom )
!
IF ( check ) WRITE(numout,*) 'out of SECHIBA'
!
! 4. scatter output fields
!
z0(:) = undef_sechiba
coastalflow(:) = undef_sechiba
riverflow(:) = undef_sechiba
tsol_rad(:) = undef_sechiba
vevapp(:) = undef_sechiba
temp_sol_new(:) = undef_sechiba
qsurf(:) = undef_sechiba
albedo(:,1) = undef_sechiba
albedo(:,2) = undef_sechiba
fluxsens(:) = undef_sechiba
fluxlat(:) = undef_sechiba
emis(:) = undef_sechiba
cdrag(:) = undef_sechiba
!
dvevapp(:) = undef_sechiba
dtemp_sol(:) = undef_sechiba
dfluxsens(:) = undef_sechiba
dfluxlat(:) = undef_sechiba
dswnet (:) = undef_sechiba
dswdown (:) = undef_sechiba
dalbedo (:,1) = undef_sechiba
dalbedo (:,2) = undef_sechiba
dtair (:) = undef_sechiba
dqair (:) = undef_sechiba
dt2m (:) = undef_sechiba
dq2m (:) = undef_sechiba
!
DO ik=1, kjpindex
z0(ik) = zz0(ik)
coastalflow(ik) = zcoastal(ik)/1000.
riverflow(ik) = zriver(ik)/1000.
tsol_rad(ik) = ztsol_rad(ik)
vevapp(ik) = zvevapp(ik)
temp_sol_new(ik) = ztemp_sol_new(ik)
qsurf(ik) = zqsurf(ik)
albedo(ik,1) = zalbedo(ik,1)
albedo(ik,2) = zalbedo(ik,2)
fluxsens(ik) = zfluxsens(ik)
fluxlat(ik) = zfluxlat(ik)
emis(ik) = zemis(ik)
cdrag(ik) = zcdrag(ik)
! Fill up the diagnostic arrays
dvevapp(kindex(ik)) = zvevapp(ik)
dtemp_sol(kindex(ik)) = ztemp_sol_new(ik)
dfluxsens(kindex(ik)) = zfluxsens(ik)
dfluxlat(kindex(ik)) = zfluxlat(ik)
dswnet (kindex(ik)) = swnet(ik)
dswdown (kindex(ik)) = swdown(ik)
dalbedo (kindex(ik),1) = zalbedo(ik,1)
dalbedo (kindex(ik),2) = zalbedo(ik,2)
dtair (kindex(ik)) = temp_air(ik)
dqair (kindex(ik)) = qair(ik)
dt2m (kindex(ik)) = t2m(ik)
dq2m (kindex(ik)) = q2m(ik)
!
ENDDO
! Modified fields for variables scattered during the writing
!
dcoastal(:) = (zcoastal(:))/1000.
driver(:) = (zriver(:))/1000.
!
!
!
!
IF ( .NOT. l_first_intersurf) THEN
!
CALL histwrite(hist_id, 'LandPoints', itau_sechiba, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
CALL histwrite(hist_id, 'Areas', itau_sechiba, area, kjpindex, kindex)
CALL histwrite(hist_id, 'Contfrac', itau_sechiba, contfrac, kjpindex, kindex)
!
IF ( hist2_id > 0 ) THEN
CALL histwrite(hist2_id, 'LandPoints', itau_sechiba, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
ENDIF
!
IF ( .NOT. almaoutput ) THEN
!
! scattered during the writing
!
CALL histwrite (hist_id, 'evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
CALL histwrite (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
!
CALL histwrite (hist_id, 'temp_sol', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist_id, 'tsol_max', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist_id, 'tsol_min', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist_id, 'fluxsens', itau_sechiba, dfluxsens, iim*jjm, kindex)
CALL histwrite (hist_id, 'fluxlat', itau_sechiba, dfluxlat, iim*jjm, kindex)
CALL histwrite (hist_id, 'swnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist_id, 'swdown', itau_sechiba, dswdown, iim*jjm, kindex)
CALL histwrite (hist_id, 'alb_vis', itau_sechiba, dalbedo(:,1), iim*jjm, kindex)
CALL histwrite (hist_id, 'alb_nir', itau_sechiba, dalbedo(:,2), iim*jjm, kindex)
CALL histwrite (hist_id, 'tair', itau_sechiba, dtair, iim*jjm, kindex)
CALL histwrite (hist_id, 'qair', itau_sechiba, dqair, iim*jjm, kindex)
CALL histwrite (hist_id, 't2m', itau_sechiba, dq2m, iim*jjm, kindex)
CALL histwrite (hist_id, 'q2m', itau_sechiba, dt2m, iim*jjm, kindex)
!
IF ( hist2_id > 0 ) THEN
CALL histwrite (hist2_id, 'evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
CALL histwrite (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
!
CALL histwrite (hist2_id, 'temp_sol', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, dfluxsens, iim*jjm, kindex)
CALL histwrite (hist2_id, 'fluxlat', itau_sechiba, dfluxlat, iim*jjm, kindex)
CALL histwrite (hist2_id, 'swnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist2_id, 'swdown', itau_sechiba, dswdown, iim*jjm, kindex)
CALL histwrite (hist2_id, 'alb_vis', itau_sechiba, dalbedo(:,1), iim*jjm, kindex)
CALL histwrite (hist2_id, 'alb_nir', itau_sechiba, dalbedo(:,2), iim*jjm, kindex)
CALL histwrite (hist2_id, 'tair', itau_sechiba, dtair, iim*jjm, kindex)
CALL histwrite (hist2_id, 'qair', itau_sechiba, dqair, iim*jjm, kindex)
CALL histwrite (hist2_id, 't2m', itau_sechiba, dq2m, iim*jjm, kindex)
CALL histwrite (hist2_id, 'q2m', itau_sechiba, dt2m, iim*jjm, kindex)
ENDIF
ELSE
!
CALL histwrite (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist_id, 'SWnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist_id, 'Qh', itau_sechiba, dfluxsens, iim*jjm, kindex)
CALL histwrite (hist_id, 'Qle', itau_sechiba, dfluxlat, iim*jjm, kindex)
CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist_id, 'RadT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
!
IF ( hist2_id > 0 ) THEN
CALL histwrite (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
CALL histwrite (hist2_id, 'SWnet', itau_sechiba, dswnet, iim*jjm, kindex)
CALL histwrite (hist2_id, 'Qh', itau_sechiba, dfluxsens, iim*jjm, kindex)
CALL histwrite (hist2_id, 'Qle', itau_sechiba, dfluxlat, iim*jjm, kindex)
CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
CALL histwrite (hist2_id, 'RadT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
ENDIF
ENDIF
!
ENDIF
!
! 5.0 Transform the water fluxes into Kg/m^2s and m^3/s
!
DO ik=1, kjpindex
vevapp(ik) = vevapp(ik)/xrdt
coastalflow(ik) = coastalflow(ik)/xrdt
riverflow(ik) = riverflow(ik)/xrdt
ENDDO
!
IF ( lrestart_write .AND. watchout ) THEN
IF (is_root_prc) CALL intersurf_clowatch()
ENDIF
!
l_first_intersurf = .FALSE.
!
IF (long_print) WRITE (numout,*) ' intersurf_main done '
END SUBROUTINE intersurf_gathered_2m
!
!-------------------------------------------------------------------------------------
!
SUBROUTINE intsurf_config(control_flags,dt)
!
! This subroutine reads all the configuration flags which control the behaviour of the model
!
IMPLICIT NONE
!
REAL, INTENT(in) :: dt !! Time step in seconds
!
TYPE(control_type), INTENT(out) :: control_flags !! Flags that (de)activate parts of the model
CHARACTER(LEN=30) :: classif
!
!Config Key = LONGPRINT
!Config Desc = ORCHIDEE will print more messages
!Config Def = n
!Config Help = This flag permits to print more debug messages in the run.
!
long_print = .FALSE.
CALL getin_p('LONGPRINT',long_print)
!
!
!Config Key = SOILTYPE_CLASSIF
!Config Desc = Type of classification used for the map of soil types
!Config Def = zobler
!Config If = !IMPOSE_VEG
!Config Help = The classification used in the file that we use here
!Config = There are three classification supported:
!Config = FAO (3 soil types), Zobler (7 converted to 3) and USDA (12)
!
!-tdo- Suivant le type de classification utilisee pour le sol, on adapte nscm
classif = 'zobler'
CALL getin('SOILTYPE_CLASSIF',classif)
SELECTCASE (classif)
CASE ('zobler', 'fao','none')
nscm = nscm_fao
CASE ('fao2')
nscm = 2 * nscm_fao-1
CASE ('usda')
nscm = nscm_usda
CASE DEFAULT
PRINT *, "Unsupported soil type classification. Choose between zobler, fao and usda according to the map"
STOP 'intsurf_config'
ENDSELECT
!
!Config Key = ORCHIDEE_WATCHOUT
!Config Desc = ORCHIDEE will write out its forcing to a file
!Config Def = n
!Config Help = This flag allows to write to a file all the variables
!Config which are used to force the land-surface. The file
!Config has exactly the same format than a normal off-line forcing
!Config and thus this forcing can be used for forcing ORCHIDEE.
!
watchout = .FALSE.
CALL getin_p('ORCHIDEE_WATCHOUT',watchout)
!
IF (watchout) THEN
!Config Key = DT_WATCHOUT
!Config Desc = ORCHIDEE will write out with this frequency
!Config IF = ORCHIDEE_WATCHOUT
!Config Def = dt
!Config Help = This flag indicates the frequency of the write of the variables.
!
dt_watch = dt
CALL getin('DT_WATCHOUT',dt_watch)
dt_split_watch = dt_watch / dt
!
!Config Key = WATCHOUT_FILE
!Config Desc = Filenane for the ORCHIDEE forcing file
!Config IF = ORCHIDEE_WATCHOUT
!Config Def = orchidee_watchout.nc
!Config Help = This is the name of the file in which the
!Config forcing used here will be written for later use.
!
watchout_file = "orchidee_watchout.nc"
CALL getin_p('WATCHOUT_FILE',watchout_file)
WRITE(numout,*) 'WATCHOUT flag :', watchout
WRITE(numout,*) 'WATCHOUT file :', watchout_file
ENDIF
!
!Config Key = RIVER_ROUTING
!Config Desc = Decides if we route the water or not
!Config Def = n
!Config Help = This flag allows the user to decide if the runoff
!Config and drainage should be routed to the ocean
!Config and to downstream grid boxes.
!
control_flags%river_routing = .FALSE.
CALL getin_p('RIVER_ROUTING', control_flags%river_routing)
WRITE(numout,*) "RIVER routing is activated : ",control_flags%river_routing
!
!
!Config key = HYDROL_CWRR
!Config Desc = Allows to switch on the multilayer hydrology of CWRR
!Config Def = n
!Config Help = This flag allows the user to decide if the vertical
!Config hydrology should be treated using the multi-layer
!Config diffusion scheme adapted from CWRR by Patricia de Rosnay.
!Config by default the Choisnel hydrology is used.
!
control_flags%hydrol_cwrr = .FALSE.
CALL getin_p('HYDROL_CWRR', control_flags%hydrol_cwrr)
IF ( control_flags%hydrol_cwrr ) then
CALL ipslerr (2,'intsurf_config', &
& 'You will use in this run the second version of CWRR hydrology in ORCHIDEE.',&
& 'This model hasn''t been tested for global run yet.', &
& '(check your parameters)')
ENDIF
!Config Key = CHECK_WATERBAL
!Config Desc = Should we check the global water balance
!Config Def = TRUE
!Config Help = This parameters allows the user to check
!Config the integrated water balance at the end
!Config of each time step
!
check_waterbal = .FALSE.
CALL getin_p('CHECK_WATERBAL', check_waterbal)
!
!Config Key = STOMATE_OK_CO2
!Config Desc = Activate CO2?
!Config Def = n
!Config Help = set to TRUE if photosynthesis is to be activated
!
control_flags%ok_co2 = .FALSE.
CALL getin_p('STOMATE_OK_CO2', control_flags%ok_co2)
WRITE(numout,*) 'photosynthesis: ', control_flags%ok_co2
!
!Config Key = STOMATE_OK_STOMATE
!Config Desc = Activate STOMATE?
!Config Def = n
!Config Help = set to TRUE if STOMATE is to be activated
!
control_flags%ok_stomate = .FALSE.
CALL getin_p('STOMATE_OK_STOMATE',control_flags%ok_stomate)
WRITE(numout,*) 'STOMATE is activated: ',control_flags%ok_stomate
!
!Config Key = STOMATE_OK_DGVM
!Config Desc = Activate DGVM?
!Config Def = n
!Config Help = set to TRUE if DGVM is to be activated
!
control_flags%ok_dgvm = .FALSE.
CALL getin_p('STOMATE_OK_DGVM',control_flags%ok_dgvm)
WRITE(numout,*) 'LPJ is activated: ',control_flags%ok_dgvm
!
! control initialisation with sechiba
!
control_flags%ok_sechiba = .TRUE.
!
!
! Ensure consistency
!
IF ( control_flags%ok_dgvm ) control_flags%ok_stomate = .TRUE.
IF ( control_flags%ok_stomate ) control_flags%ok_co2 = .TRUE.
!
!Config Key = STOMATE_WATCHOUT
!Config Desc = STOMATE does minimum service
!Config Def = n
!Config Help = set to TRUE if you want STOMATE to read
!Config and write its start files and keep track
!Config of longer-term biometeorological variables.
!Config This is useful if OK_STOMATE is not set,
!Config but if you intend to activate STOMATE later.
!Config In that case, this run can serve as a
!Config spinup for longer-term biometeorological
!Config variables.
!
control_flags%stomate_watchout = .FALSE.
CALL getin_p('STOMATE_WATCHOUT',control_flags%stomate_watchout)
WRITE(numout,*) 'STOMATE keeps an eye open: ',control_flags%stomate_watchout
!
! Here we need the same initialisation as above
!
control_flags%ok_pheno = .TRUE.
!
!
RETURN
!
END SUBROUTINE intsurf_config
!
!
!
SUBROUTINE intsurf_restart(istp, iim, jjm, lon, lat, date0, dt, control_flags, rest_id, rest_id_stom, itau_offset)
!
! This subroutine initialized the restart file for the land-surface scheme
!
IMPLICIT NONE
!
INTEGER(i_std), INTENT(in) :: istp !! Time step of the restart file
INTEGER(i_std), INTENT(in) :: iim, jjm !! Size in x and y of the data to be handeled
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: lon, lat !! Logitude and latitude of the data points
REAL(r_std) :: date0 !! The date at which itau = 0
REAL(r_std) :: dt !! Time step
INTEGER(i_std), INTENT(out) :: rest_id, rest_id_stom !! ID of the restart file
INTEGER(i_std), INTENT(out) :: itau_offset
!
TYPE(control_type), INTENT(in) :: control_flags !! Flags that (de)activate parts of the model
!
! LOCAL
!
CHARACTER(LEN=80) :: restname_in, restname_out, stom_restname_in, stom_restname_out
REAL(r_std) :: dt_rest, date0_rest
INTEGER(i_std) :: itau_dep
INTEGER(i_std),PARAMETER :: llm=1
REAL(r_std), DIMENSION(llm) :: lev
LOGICAL :: overwrite_time
REAL(r_std) :: in_julian, rest_julian
INTEGER(i_std) :: yy, mm, dd
REAL(r_std) :: ss
!
!Config Key = SECHIBA_restart_in
!Config Desc = Name of restart to READ for initial conditions
!Config Def = NONE
!Config Help = This is the name of the file which will be opened
!Config to extract the initial values of all prognostic
!Config values of the model. This has to be a netCDF file.
!Config Not truly COADS compliant. NONE will mean that
!Config no restart file is to be expected.
!-
restname_in = 'NONE'
CALL getin_p('SECHIBA_restart_in',restname_in)
WRITE(numout,*) 'INPUT RESTART_FILE', restname_in
!-
!Config Key = SECHIBA_rest_out
!Config Desc = Name of restart files to be created by SECHIBA
!Config Def = sechiba_rest_out.nc
!Config Help = This variable give the name for
!Config the restart files. The restart software within
!Config IOIPSL will add .nc if needed.
!
restname_out = 'restart_out.nc'
CALL getin_p('SECHIBA_rest_out', restname_out)
!
!Config Key = SECHIBA_reset_time
!Config Desc = Option to overrides the time of the restart
!Config Def = n
!Config Help = This option allows the model to override the time
!Config found in the restart file of SECHIBA with the time
!Config of the first call. That is the restart time of the GCM.
!
overwrite_time = .FALSE.
CALL getin_p('SECHIBA_reset_time', overwrite_time)
!
lev(:) = 0.
itau_dep = istp
in_julian = itau2date(istp, date0, dt)
date0_rest = date0
dt_rest = dt
!
IF (is_root_prc) &
CALL restini( restname_in, iim_g, jjm_g, lon_g, lat_g, llm, lev, &
& restname_out, itau_dep, date0_rest, dt_rest, rest_id, overwrite_time)
CALL bcast (itau_dep)
CALL bcast (date0_rest)
CALL bcast (dt_rest)
!
! itau_dep of SECHIBA is phased with the GCM if needed
!
rest_julian = itau2date(itau_dep, date0_rest, dt_rest)
!
IF ( ABS( in_julian - rest_julian) .GT. dt/one_day .AND. .NOT. OFF_LINE_MODE ) THEN
IF ( overwrite_time ) THEN
WRITE(numout,*) 'The SECHIBA restart is not for the same timestep as the GCM,'
WRITE(numout,*) 'the two are synchronized. The land-surface conditions can not impose'
WRITE(numout,*) 'the chronology of the simulation.'
WRITE(numout,*) 'Time step of the GCM :', istp, 'Julian day : ', in_julian
CALL ju2ymds(in_julian, yy, mm, dd, ss)
WRITE(numout,*) 'In other word (yy,mm,dd,ss) : ', yy, mm, dd, ss
WRITE(numout,*) 'Time step of SECHIBA :', itau_dep, 'Julian day : ', rest_julian
CALL ju2ymds(rest_julian, yy, mm, dd, ss)
WRITE(numout,*) 'In other word (yy,mm,dd,ss) : ', yy, mm, dd, ss
itau_offset = itau_dep - istp
date0_shifted = date0 - itau_offset*dt/one_day
!MM_ A VOIR : dans le TAG 1.4 :
! date0_shifted = in_julian - itau_dep*dt/one_day
!MM_ Bon calcul ?
WRITE(numout,*) 'The new starting date is :', date0_shifted
CALL ju2ymds(date0_shifted, yy, mm, dd, ss)
WRITE(numout,*) 'In other word (yy,mm,dd,ss) : ', yy, mm, dd, ss
ELSE
WRITE(numout,*) 'IN -> OUT :', istp, '->', itau_dep
WRITE(numout,*) 'IN -> OUT :', in_julian, '->', rest_julian
WRITE(numout,*) 'SECHIBA''s restart file is not consistent with the one of the GCM'
WRITE(numout,*) 'Correct the time axis of the restart file or force the code to change it.'
STOP
ENDIF
ELSE
itau_offset = 0
date0_shifted = date0
ENDIF
!
!!! CALL ioconf_startdate(date0_shifted)
!
!=====================================================================
!- 1.5 Restart file for STOMATE
!=====================================================================
IF ( control_flags%ok_stomate .OR. control_flags%stomate_watchout ) THEN
!-
! STOMATE IS ACTIVATED
!-
!Config Key = STOMATE_RESTART_FILEIN
!Config Desc = Name of restart to READ for initial conditions
!Config of STOMATE
!Config If = STOMATE_OK_STOMATE || STOMATE_WATCHOUT
!Config Def = NONE
!Config Help = This is the name of the file which will be opened
!Config to extract the initial values of all prognostic
!Config values of STOMATE.
!-
stom_restname_in = 'NONE'
CALL getin_p('STOMATE_RESTART_FILEIN',stom_restname_in)
WRITE(numout,*) 'STOMATE INPUT RESTART_FILE', stom_restname_in
!-
!Config Key = STOMATE_RESTART_FILEOUT
!Config Desc = Name of restart files to be created by STOMATE
!Config If = STOMATE_OK_STOMATE || STOMATE_WATCHOUT
!Config Def = stomate_restart.nc
!Config Help = This is the name of the file which will be opened
!Config to write the final values of all prognostic values
!Config of STOMATE.
!-
stom_restname_out = 'stomate_restart.nc'
CALL getin_p('STOMATE_RESTART_FILEOUT', stom_restname_out)
WRITE(numout,*) 'STOMATE OUTPUT RESTART_FILE', stom_restname_out
!-
IF (is_root_prc) &
CALL restini (stom_restname_in, iim_g, jjm_g, lon_g, lat_g, llm, lev, &
& stom_restname_out, itau_dep, date0_rest, dt_rest, rest_id_stom, overwrite_time)
CALL bcast (itau_dep)
CALL bcast (date0_rest)
CALL bcast (dt_rest)
!-
ENDIF
!
END SUBROUTINE intsurf_restart
SUBROUTINE intsurf_history(iim, jjm, lon, lat, istp_old, date0, dt, control_flags, hist_id, hist2_id, hist_id_stom)
!
!
! This subroutine initialized the history files for the land-surface scheme
!
IMPLICIT NONE
!
INTEGER(i_std), INTENT(in) :: iim, jjm !! Size in x and y of the data to be handeled
REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: lon, lat !! Longitude and latitude of the data points
INTEGER(i_std), INTENT(in) :: istp_old !! Time step counter
REAL(r_std), INTENT(in) :: date0 !! Julian day at which istp=0
REAL(r_std), INTENT(in) :: dt !! Time step of the counter in seconds
!
TYPE(control_type), INTENT(in) :: control_flags !! Flags that (de)activate parts of the model
!
INTEGER(i_std), INTENT(out) :: hist_id, hist_id_stom !! History file identification for SECHIBA and STOMATE
INTEGER(i_std), INTENT(out) :: hist2_id !! History file 2 identification for SECHIBA (Hi-frequency ?)
!
! LOCAL
!
CHARACTER(LEN=80) :: histname,stom_histname !! Name of history file
CHARACTER(LEN=80) :: histname2 !! Name of history file 2
LOGICAL :: ok_histfile2 !! Flag to switch on histfile 2 for SECHIBA
REAL(r_std) :: dw, dw2 !! frequency of history write (sec.)
CHARACTER(LEN=30) :: flux_op !! Operations to be performed on fluxes
CHARACTER(LEN=30) :: flux_sc !! Operations which do not include a scatter
CHARACTER(LEN=30) :: flux_insec, flux_scinsec !! Operation in seconds
INTEGER(i_std) :: hist_level, hist2_level !! history output level (default is 10 => maximum output)
CHARACTER(LEN=40),DIMENSION(max_hist_level) :: &
& ave, avecels, avescatter, tmax, fluxop, fluxop_sc, fluxop_insec, &
& fluxop_scinsec, tmincels, tmaxcels, once, sumscatter !! The various operation to be performed
CHARACTER(LEN=40),DIMENSION(max_hist_level) :: &
& ave2, avecels2, avescatter2, tmax2, fluxop2, fluxop_sc2, fluxop_insec2, &
& fluxop_scinsec2, tmincels2, tmaxcels2, once2, sumscatter2 !! The various operation to be performed
INTEGER(i_std) :: i, jst, jv
! SECHIBA AXIS
INTEGER(i_std) :: hori_id !! ID of the default horizontal longitude and latitude map.
INTEGER(i_std) :: vegax_id, solax_id, soltax_id, nobioax_id !! ID's for two vertical coordinates
INTEGER(i_std) :: solayax_id !! ID for the vertical axis of the CWRR hydrology
INTEGER(i_std) :: hori_id2 !! ID of the default horizontal longitude and latitude map.
INTEGER(i_std) :: vegax_id2, solax_id2, soltax_id2, nobioax_id2, albax_id2 !! ID's for two vertical coordinates
INTEGER(i_std) :: solayax_id2 !! ID for the vertical axis of the CWRR hydrology
! STOMATE AXIS
INTEGER(i_std) :: hist_PFTaxis_id
! deforestation
INTEGER(i_std) :: hist_pool_10axis_id
INTEGER(i_std) :: hist_pool_100axis_id
INTEGER(i_std) :: hist_pool_11axis_id
INTEGER(i_std) :: hist_pool_101axis_id
!
LOGICAL :: rectilinear
INTEGER(i_std) :: ier
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lon_rect, lat_rect
!
REAL(r_std),DIMENSION(nvm) :: veg
REAL(r_std),DIMENSION(ngrnd) :: sol
REAL(r_std),DIMENSION(nstm) :: soltyp
REAL(r_std),DIMENSION(nnobio):: nobiotyp
REAL(r_std),DIMENSION(2) :: albtyp
REAL(r_std),DIMENSION(nslm) :: solay
!
CHARACTER(LEN=80) :: var_name !! To store variables names
!
REAL(r_std) :: hist_days_stom !!- GK time step in days for this history file
REAL(r_std) :: hist_dt_stom !!- GK time step in seconds for this history file
REAL(r_std) :: dt_slow_ !! for test : time step of slow processes and STOMATE
INTEGER(i_std),PARAMETER :: npft = nvm-1 !!- GK Number of PFTs
REAL(r_std),DIMENSION(npft) :: hist_PFTaxis !!- GK An axis we need for the history files
!
REAL(r_std),DIMENSION(10) :: hist_pool_10axis !! Deforestation axis
REAL(r_std),DIMENSION(100) :: hist_pool_100axis !! Deforestation axis
REAL(r_std),DIMENSION(11) :: hist_pool_11axis !! Deforestation axis
REAL(r_std),DIMENSION(101) :: hist_pool_101axis !! Deforestation axis
!
!
!=====================================================================
!- 3.0 Setting up the history files
!=====================================================================
!- 3.1 SECHIBA
!=====================================================================
!Config Key = ALMA_OUTPUT
!Config Desc = Should the output follow the ALMA convention
!Config Def = n
!Config Help = If this logical flag is set to true the model
!Config will output all its data according to the ALMA
!Config convention. It is the recommended way to write
!Config data out of ORCHIDEE.
!-
almaoutput = .FALSE.
CALL getin_p('ALMA_OUTPUT', almaoutput)
WRITE(numout,*) 'ALMA_OUTPUT', almaoutput
!-
!Config Key = OUTPUT_FILE
!Config Desc = Name of file in which the output is going
!Config to be written
!Config Def = cabauw_out.nc
!Config Help = This file is going to be created by the model
!Config and will contain the output from the model.
!Config This file is a truly COADS compliant netCDF file.
!Config It will be generated by the hist software from
!Config the IOIPSL package.
!-
histname='cabauw_out.nc'
CALL getin_p('OUTPUT_FILE', histname)
WRITE(numout,*) 'OUTPUT_FILE', histname
!-
!Config Key = WRITE_STEP
!Config Desc = Frequency in seconds at which to WRITE output
!Config Def = 86400.0
!Config Help = This variables gives the frequency the output of
!Config the model should be written into the netCDF file.
!Config It does not affect the frequency at which the
!Config operations such as averaging are done.
!Config That is IF the coding of the calls to histdef
!Config are correct !
!-
dw = one_day
CALL getin_p('WRITE_STEP', dw)
!
veg(1:nvm) = (/ (REAL(i,r_std),i=1,nvm) /)
sol(1:ngrnd) = (/ (REAL(i,r_std),i=1,ngrnd) /)
soltyp(1:nstm) = (/ (REAL(i,r_std),i=1,nstm) /)
nobiotyp(1:nnobio) = (/ (REAL(i,r_std),i=1,nnobio) /)
albtyp(1:2) = (/ (REAL(i,r_std),i=1,2) /)
solay(1:nslm) = (/ (REAL(i,r_std),i=1,nslm) /)
DO jv = 1, nslm-1
diaglev(jv) = dpu_max/(2**(nslm-1) -1) * ( ( 2**(jv-1) -1) + ( 2**(jv) -1) ) / deux
ENDDO
diaglev(nslm) = dpu_max
!
!- We need to flux averaging operation as when the data is written
!- from within SECHIBA a scatter is needed. In the driver on the other
!- hand the data is 2D and can be written is it is.
!-
WRITE(flux_op,'("ave(scatter(X*",F8.1,"))")') one_day/dt
! WRITE(flux_op,'("(ave(scatter(X))*",F8.1,")")') one_day/dt
WRITE(flux_sc,'("ave(X*",F8.1,")")') one_day/dt
!WRITE(flux_sc,'("(ave(X)*",F8.1,")")') one_day/dt
WRITE(flux_insec,'("ave(X*",F8.6,")")') 1.0/dt
WRITE(flux_scinsec,'("ave(scatter(X*",F8.6,"))")') 1.0/dt
WRITE(numout,*) flux_op, one_day/dt, dt, dw
!-
!Config Key = SECHIBA_HISTLEVEL
!Config Desc = SECHIBA history output level (0..10)
!Config Def = 5
!Config Help = Chooses the list of variables in the history file.
!Config Values between 0: nothing is written; 10: everything is
!Config written are available More details can be found on the web under documentation.
!Config web under documentation.
!-
hist_level = 5
CALL getin_p('SECHIBA_HISTLEVEL', hist_level)
!-
WRITE(numout,*) 'SECHIBA history level: ',hist_level
IF ( (hist_level > max_hist_level).OR.(hist_level < 0) ) THEN
STOP 'This history level is not allowed'
ENDIF
!-
!- define operations as a function of history level.
!- Above hist_level, operation='never'
!-
ave(1:10) = 'ave(X)'
IF (hist_level < 10) THEN
ave(hist_level+1:10) = 'never'
ENDIF
sumscatter(1:10) = 't_sum(scatter(X))'
IF (hist_level < 10) THEN
sumscatter(hist_level+1:10) = 'never'
ENDIF
avecels(1:10) = 'ave(cels(X))'
IF (hist_level < 10) THEN
avecels(hist_level+1:10) = 'never'
ENDIF
avescatter(1:10) = 'ave(scatter(X))'
IF (hist_level < 10) THEN
avescatter(hist_level+1:10) = 'never'
ENDIF
tmincels(1:10) = 't_min(cels(X))'
IF (hist_level < 10) THEN
tmincels(hist_level+1:10) = 'never'
ENDIF
tmaxcels(1:10) = 't_max(cels(X))'
IF (hist_level < 10) THEN
tmaxcels(hist_level+1:10) = 'never'
ENDIF
tmax(1:10) = 't_max(X)'
IF (hist_level < 10) THEN
tmax(hist_level+1:10) = 'never'
ENDIF
fluxop(1:10) = flux_op
IF (hist_level < 10) THEN
fluxop(hist_level+1:10) = 'never'
ENDIF
fluxop_sc(1:10) = flux_sc
IF (hist_level < 10) THEN
fluxop_sc(hist_level+1:10) = 'never'
ENDIF
fluxop_insec(1:10) = flux_insec
IF (hist_level < 10) THEN
fluxop_insec(hist_level+1:10) = 'never'
ENDIF
fluxop_scinsec(1:10) = flux_scinsec
IF (hist_level < 10) THEN
fluxop_scinsec(hist_level+1:10) = 'never'
ENDIF
once(1:10) = 'once(scatter(X))'
IF (hist_level < 10) THEN
once(hist_level+1:10) = 'never'
ENDIF
!
!-
!- Check if we have by any change a rectilinear grid. This would allow us to
!- simplify the output files.
!
rectilinear = .FALSE.
IF ( ALL(lon(:,:) == SPREAD(lon(:,1), 2, SIZE(lon,2))) .AND. &
& ALL(lat(:,:) == SPREAD(lat(1,:), 1, SIZE(lat,1))) ) THEN
rectilinear = .TRUE.
ALLOCATE(lon_rect(iim),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in lon_rect allocation. We stop. We need iim words = ',iim
STOP 'intersurf_history'
ENDIF
ALLOCATE(lat_rect(jjm),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in lat_rect allocation. We stop. We need jjm words = ',jjm
STOP 'intersurf_history'
ENDIF
lon_rect(:) = lon(:,1)
lat_rect(:) = lat(1,:)
ENDIF
!-
!-
hist_id = -1
!-
IF ( .NOT. almaoutput ) THEN
!-
IF ( rectilinear ) THEN
#ifdef CPP_PARA
CALL histbeg(histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id,orch_domain_id)
#else
CALL histbeg(histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id)
#endif
WRITE(numout,*) 'HISTBEG --->',istp_old,date0,dt,dw,hist_id
ELSE
#ifdef CPP_PARA
CALL histbeg(histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id,domain_id=orch_domain_id)
#else
CALL histbeg(histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id)
#endif
ENDIF
!-
CALL histvert(hist_id, 'veget', 'Vegetation types', '-', &
& nvm, veg, vegax_id)
CALL histvert(hist_id, 'solth', 'Soil levels', 'm', &
& ngrnd, sol, solax_id)
CALL histvert(hist_id, 'soiltyp', 'Soil types', '-', &
& nstm, soltyp, soltax_id)
CALL histvert(hist_id, 'nobio', 'Other surface types', '-', &
& nnobio, nobiotyp, nobioax_id)
IF ( control_flags%hydrol_cwrr ) THEN
CALL histvert(hist_id, 'solay', 'Hydrol soil levels', 'm', &
& nslm, diaglev(1:nslm), solayax_id)
ENDIF
!-
!- SECHIBA_HISTLEVEL = 1
!-
CALL histdef(hist_id, 'evap', 'Evaporation', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(1), dt,dw)
CALL histdef(hist_id, 'coastalflow', 'Diffuse coastal flow', 'm^3/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'riverflow', 'River flow to the oceans', 'm^3/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'temp_sol', 'Surface Temperature', 'C', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avecels(1), dt,dw)
CALL histdef(hist_id, 'rain', 'Rainfall', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(1), dt,dw)
CALL histdef(hist_id, 'snowf', 'Snowfall', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(1), dt,dw)
CALL histdef(hist_id, 'netrad', 'Net radiation', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'lai', 'Leaf Area Index', '-', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'reinf_slope', 'Slope index for each grid box', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)
CALL histdef(hist_id, 'soiltile', 'Fraction of soil tiles', '%', &
& iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, once(1), dt,dw)
CALL histdef(hist_id, 'soilindex', 'Soil index', '-', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, once(1), dt,dw)
CALL histdef(hist_id, 'soildepth', 'Soil Depth', 'm', &
& iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, once(1), dt,dw)
IF ( control_flags%river_routing ) THEN
CALL histdef(hist_id, 'basinmap', 'Aproximate map of the river basins', ' ', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)
CALL histdef(hist_id, 'nbrivers', 'Number or rivers in the outflow grid box', ' ', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)
ENDIF
!-
!- SECHIBA_HISTLEVEL = 2
!-
CALL histdef(hist_id, 'subli', 'Sublimation', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
CALL histdef(hist_id, 'evapnu', 'Bare soil evaporation', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
CALL histdef(hist_id, 'floodout', 'Flow out of floodplains', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(9), dt,dw)
CALL histdef(hist_id, 'evapflo', 'Floodplains evaporation', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(9), dt,dw)
CALL histdef(hist_id, 'runoff', 'Surface runoff', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
CALL histdef(hist_id, 'drainage', 'Deep drainage', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
IF ( control_flags%river_routing ) THEN
CALL histdef(hist_id, 'riversret', 'Return from endorheic rivers', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
CALL histdef(hist_id, 'hydrographs', 'Hydrographs of gridbox outflow', 'm^3/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(2), dt,dw)
ENDIF
!
CALL histdef(hist_id, 'tair', 'Air Temperature', 'K', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
CALL histdef(hist_id, 'qair', 'Air humidity', 'g/g', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
! Ajouts Nathalie - Juillet 2006
CALL histdef(hist_id, 'q2m', '2m Air humidity', 'g/g', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(9), dt,dw)
CALL histdef(hist_id, 't2m', '2m Air Temperature', 'K', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(9), dt,dw)
! Fin ajouts Nathalie
CALL histdef(hist_id, 'alb_vis', 'Albedo visible', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(9), dt,dw)
CALL histdef(hist_id, 'alb_nir', 'Albedo near infrared', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(9), dt,dw)
CALL histdef(hist_id, 'z0', 'Surface roughness', 'm', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'roughheight', 'Effective roughness height', 'm', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'transpir', 'Transpiration', 'mm/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(2), dt,dw)
CALL histdef(hist_id, 'inter', 'Interception loss', 'mm/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(2), dt,dw)
!-
!- SECHIBA_HISTLEVEL = 3
!-
CALL histdef(hist_id, 'tsol_max', 'Maximum Surface Temperature',&
& 'C', iim,jjm, hori_id, 1,1,1, -99, 32, tmaxcels(9), dt,dw)
CALL histdef(hist_id, 'tsol_min', 'Minimum Surface Temperature',&
& 'C', iim,jjm, hori_id, 1,1,1, -99, 32, tmincels(9), dt,dw)
CALL histdef(hist_id, 'fluxsens', 'Sensible Heat Flux', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(3), dt,dw)
CALL histdef(hist_id, 'fluxlat', 'Latent Heat Flux', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(3), dt,dw)
CALL histdef(hist_id, 'flood_frac', 'Flooded fraction', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(3), dt,dw)
CALL histdef(hist_id, 'snow', 'Snow mass', 'kg/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(3), dt,dw)
CALL histdef(hist_id, 'snowage', 'Snow age', '?', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'snownobio', 'Snow on other surfaces', 'kg/m^2', &
& iim,jjm, hori_id, nnobio,1, nnobio, nobioax_id, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'snownobioage', 'Snow age on other surfaces', 'd', &
& iim,jjm, hori_id, nnobio,1, nnobio, nobioax_id, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'vegetfrac', 'Fraction of vegetation', '-', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(3), dt,dw)
CALL histdef(hist_id, 'nobiofrac', 'Fraction of other surface types', '-', &
& iim,jjm, hori_id, nnobio, 1, nnobio, nobioax_id, 32, avescatter(3), dt,dw)
IF ( control_flags%hydrol_cwrr ) THEN
DO jst=1,nstm
! var_name= "mc_1" ... "mc_3"
WRITE (var_name,"('moistc_',i1)") jst
CALL histdef(hist_id, var_name, 'Soil Moisture profile for soil type', '%', &
& iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(3), dt,dw)
! var_name= "kfact_root_1" ... "kfact_root_3"
WRITE (var_name,"('kfactroot_',i1)") jst
CALL histdef(hist_id, var_name, 'Root fraction profile for soil type', '%', &
& iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(3), dt,dw)
! var_name= "vegetsoil_1" ... "vegetsoil_3"
WRITE (var_name,"('vegetsoil_',i1)") jst
CALL histdef(hist_id, var_name, 'Fraction of vegetation on soil types', '%', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(3), dt,dw)
ENDDO
ENDIF
!MG
CALL histdef(hist_id, 'frac_bare', 'Bare soil fraction for each tile', '-', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(3), dt,dw)
!-
!- SECHIBA_HISTLEVEL = 4
!-
IF ( .NOT. control_flags%hydrol_cwrr ) THEN
CALL histdef(hist_id, 'gqsb', 'Upper Soil Moisture', '-', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
CALL histdef(hist_id, 'bqsb', 'Lower Soil Moisture', '-', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
ELSE
CALL histdef(hist_id, 'humtot', 'Total Soil Moisture', 'Kg/m2', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
CALL histdef(hist_id, 'humtot_soil', 'Soil Moisture for soil type', 'Kg/m2', &
& iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, avescatter(4), dt,dw)
CALL histdef(hist_id, 'SWI', 'Soil wetness index','-', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
CALL histdef(hist_id, 'njsc', 'Soil class used for hydrology', '-', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, once(4), dt,dw)
ENDIF
CALL histdef(hist_id, 'qsintveg', 'Water on canopy', 'Kg/m^2', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(4), dt,dw)
CALL histdef(hist_id, 'rstruct', 'Structural resistance', 's/m', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(9), dt,dw)
IF ( control_flags%ok_co2 ) THEN
CALL histdef(hist_id, 'gpp', 'CO2 Assimilation', 'gC/m2/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4), dt,dw)
ENDIF
IF ( control_flags%ok_stomate ) THEN
CALL histdef(hist_id, 'nee', 'Net CO2 Ecossytem Exchange', 'gC/m2/d', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop(4), dt,dw)
CALL histdef(hist_id, 'maint_resp', 'Maintenance respiration', 'gC/m2/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4), dt,dw)
CALL histdef(hist_id, 'hetero_resp', 'Heterotrophic respiration', 'gC/m2/d', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop(4), dt,dw)
CALL histdef(hist_id, 'growth_resp', 'Growth respiration', 'gC/m2/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4), dt,dw)
CALL histdef (hist_id,'CO2FLUX','Total output CO2 flux', 'gC/day/(m^2 tot)', &
& iim,jjm, hori_id, 1,1,1, -99,32, fluxop(4), dt, dw)
ENDIF
CALL histdef(hist_id, 'precisol', 'Throughfall', 'mm/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4), dt,dw)
CALL histdef(hist_id, 'drysoil_frac', 'Fraction of visibly dry soil', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'evapot', 'Potential evaporation', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), dt,dw)
CALL histdef(hist_id, 'evapot_corr', 'Potential evaporation (for bare soil)', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), dt,dw)
!MG
CALL histdef(hist_id, 'etm', 'Maximum evapotranspiration', 'mm/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4), dt,dw)
CALL histdef(hist_id, 'rveget', 'Canopy resistance', 's/m', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(9), dt,dw)
!-
!- SECHIBA_HISTLEVEL = 5
!-
CALL histdef(hist_id, 'swnet', 'Net solar radiation', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(5), dt,dw)
CALL histdef(hist_id, 'swdown', 'Incident solar radiation', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(5), dt,dw)
CALL histdef(hist_id, 'lwdown', 'Absorbed downward longwave radiation', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(5), dt,dw)
CALL histdef(hist_id, 'lwnet', 'Net surface longwave radiation', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(5), dt,dw)
CALL histdef(hist_id, 'temp_pheno', 'Temperature for Pheno', 'K', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'rsol', 'Soil resistance', 's/m', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
!-
!- SECHIBA_HISTLEVEL = 6
!-
CALL histdef(hist_id, 'ptn', 'Deep ground temperature', 'K', &
& iim,jjm, hori_id, ngrnd, 1, ngrnd, solax_id, 32, avescatter(9), dt,dw)
!-
!- SECHIBA_HISTLEVEL = 7
!-
IF ( control_flags%river_routing ) THEN
CALL histdef(hist_id, 'fastr', 'Fast flow reservoir', 'kg/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(6), dt,dw)
CALL histdef(hist_id, 'slowr', 'Slow flow reservoir', 'kg/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(6), dt,dw)
CALL histdef(hist_id, 'streamr', 'Stream flow reservoir', 'kg/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(6), dt,dw)
CALL histdef(hist_id, 'pondr', 'Ponds reservoir', 'kg/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'lakevol', 'Volume in lake reservoir', 'kg/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'returnflow', 'Returnflow to bottom layer', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(9), dt,dw)
CALL histdef(hist_id, 'irrigation', 'Net irrigation', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(6), dt,dw)
CALL histdef(hist_id, 'netirrig', 'Net irrigation requirement', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(6), dt,dw)
CALL histdef(hist_id, 'irrigmap', 'Map of irrigated fractions', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(6), dt,dw)
CALL histdef(hist_id, 'floodmap', 'Map of floodplain fractions', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(9), dt,dw)
CALL histdef(hist_id, 'floodh', 'Floodplains height', 'mm', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'floodr', 'Floodplains reservoir', 'kg/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(9), dt,dw)
CALL histdef(hist_id, 'swampmap', 'Map of swamp fractions', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(9), dt,dw)
ENDIF
!-
!- SECHIBA_HISTLEVEL = 8
!-
CALL histdef(hist_id, 'k_litt', 'Litter cond', 'mm/d', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
CALL histdef(hist_id, 'beta', 'Beta Function', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
CALL histdef(hist_id, 'raero', 'Aerodynamic resistance', 's/m', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
! Ajouts Nathalie - Novembre 2006
CALL histdef(hist_id, 'cdrag', 'Drag coefficient for LE and SH', '?', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
CALL histdef(hist_id, 'Wind', 'Wind speed', 'm/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(6), dt,dw)
! Fin ajouts Nathalie
CALL histdef(hist_id, 'vbeta1', 'Beta for sublimation', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
CALL histdef(hist_id, 'vbeta4', 'Beta for bare soil', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
CALL histdef(hist_id, 'vbeta5', 'Beta for floodplains', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
CALL histdef(hist_id, 'vbetaco2', 'beta for CO2', 'mm/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(8), dt,dw)
CALL histdef(hist_id, 'humrel', 'Soil moisture stress', '-', &
& iim,jjm, hori_id, nvm,1,nvm, vegax_id, 32, avescatter(8), dt,dw)
IF ( control_flags%hydrol_cwrr ) THEN
CALL histdef(hist_id, 'evapnu_soil', 'Bare soil evap for soil type', 'mm/d', &
& iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(8), dt,dw)
CALL histdef(hist_id, 'drainage_soil', 'Drainage for soil type', 'mm/d', &
& iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(8), dt,dw)
CALL histdef(hist_id, 'transpir_soil', 'Transpir for soil type', 'mm/d', &
& iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(8), dt,dw)
CALL histdef(hist_id, 'runoff_soil', 'Runoff for soil type', 'mm/d', &
& iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(8), dt,dw)
ENDIF
!-
!- SECHIBA_HISTLEVEL = 9
!-
!-
!- SECHIBA_HISTLEVEL = 10
!-
CALL histdef(hist_id, 'cimean', 'Stomatal CO2 concentation', 'mmole/m2/s', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
CALL histdef(hist_id, 'vbeta3', 'Beta for Transpiration', 'mm/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
! CALL histdef(hist_id, 'rveget', 'Canopy resistance', 's/m', &
! & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
! CALL histdef(hist_id, 'rsol', 'Soil resistance', 's/m', &
! & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(10), dt,dw)
CALL histdef(hist_id,'vbeta2','Beta for Interception loss','mm/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
CALL histdef(hist_id, 'qsintmax', 'Maximum Interception capacity', 'Kg/m^2', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
ELSE
!-
!- This is the ALMA convention output now
!-
!-
IF ( rectilinear ) THEN
#ifdef CPP_PARA
CALL histbeg(histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id,orch_domain_id)
#else
CALL histbeg(histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id)
#endif
ELSE
#ifdef CPP_PARA
CALL histbeg(histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id,domain_id=orch_domain_id)
#else
CALL histbeg(histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id)
#endif
ENDIF
!-
CALL histvert(hist_id, 'veget', 'Vegetation types', '-', &
& nvm, veg, vegax_id)
CALL histvert(hist_id, 'solth', 'Soil levels', 'm', &
& ngrnd, sol, solax_id)
CALL histvert(hist_id, 'soiltyp', 'Soil types', '-', &
& nstm, soltyp, soltax_id)
CALL histvert(hist_id, 'nobio', 'Other surface types', '-', &
& nnobio, nobiotyp, nobioax_id)
IF ( control_flags%hydrol_cwrr ) THEN
CALL histvert(hist_id, 'solay', 'Hydrol soil levels', 'm', &
& nslm, diaglev(1:nslm), solayax_id)
ENDIF
!-
!- Vegetation
!-
CALL histdef(hist_id, 'vegetfrac', 'Fraction of vegetation', '-', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(3), dt,dw)
CALL histdef(hist_id, 'nobiofrac', 'Fraction of other surface types', '-', &
& iim,jjm, hori_id, nnobio, 1, nnobio, nobioax_id, 32, avescatter(3), dt,dw)
!-
!- General energy balance
!-
CALL histdef(hist_id, 'SWnet', 'Net shortwave radiation', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
CALL histdef(hist_id, 'LWnet', 'Net longwave radiation', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'Qh', 'Sensible heat flux', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
CALL histdef(hist_id, 'Qle', 'Latent heat flux', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
CALL histdef(hist_id, 'Qg', 'Ground heat flux', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'Qf', 'Energy of fusion', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'Qv', 'Energy of sublimation', 'W/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'DelSurfHeat', 'Change in surface layer heat', 'J/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, sumscatter(1), dt,dw)
CALL histdef(hist_id, 'DelColdCont', 'Change in snow surface layer cold content', 'J/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, sumscatter(1), dt,dw)
!-
!- General water balance
!-
CALL histdef(hist_id, 'Snowf', 'Snowfall rate', 'kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'Rainf', 'Rainfall rate', 'kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'Evap', 'Total Evapotranspiration', 'kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'Qs', 'Surface runoff', 'kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'Qrec', 'Recharge', 'kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'Qsb', 'Sub-surface runoff', 'kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'Qsm', 'Snowmelt', 'kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'DelSoilMoist', 'Change in soil moisture', 'kg/m^2', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(1), dt,dw)
CALL histdef(hist_id, 'DelSurfStor', 'Change in Surface Water Storage','kg/m^2',&
& iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(1), dt,dw)
CALL histdef(hist_id, 'DelIntercept', 'Change in interception storage', 'kg/m^2', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(1), dt,dw)
!-
!- Surface state
!-
CALL histdef(hist_id, 'AvgSurfT', 'Average surface temperature', 'K', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
CALL histdef(hist_id, 'RadT', 'Surface radiative temperature', 'K', &
& iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
CALL histdef(hist_id, 'Albedo', 'Albedo', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'SWI', 'Soil wetness index','-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'SurfStor', 'Surface Water Storage','kg/m^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
!!-
!- Sub-surface state
!-
IF ( .NOT. control_flags%hydrol_cwrr ) THEN
CALL histdef(hist_id, 'SoilMoist', '3D average layer soil moisture', 'kg/m^2', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(1), dt,dw)
ELSE
CALL histdef(hist_id, 'SoilMoist', '3D average layer soil moisture', 'kg/m^2', &
& iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(1), dt,dw)
ENDIF
CALL histdef(hist_id, 'SoilWet', 'Total soil wetness', 'kg/m^2', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'SoilTemp', '3D layer average soil temperature', 'K', &
& iim,jjm, hori_id, ngrnd, 1, ngrnd, solax_id, 32, avescatter(1), dt,dw)
!-
!- Evaporation components
!-
CALL histdef(hist_id, 'PotEvap', 'Potential evapotranspiration', 'kg/m^2/s', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'ECanop', 'Interception evaporation', 'kg/m^2/s', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'TVeg', 'Transpiration', 'kg/m^2/s', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'ESoil', 'Bare soil evaporation', 'kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'EWater', 'Open water evaporation', 'kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'RootMoist','Root zone soil water', 'kg/m^2', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'SubSnow','Snow sublimation','kg/m^2/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
CALL histdef(hist_id, 'ACond', 'Aerodynamic conductance', 'm/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
!-
!-
!- Cold Season Processes
!-
CALL histdef(hist_id, 'SnowFrac', 'Snow cover fraction', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'SAlbedo', 'Snow albedo', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
CALL histdef(hist_id, 'SnowDepth', '3D snow depth', 'm', &
& iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
!-
!- Hydrologic variables
!-
CALL histdef(hist_id, 'IrrigationMap', 'Map of irrigated areas', 'm^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)
CALL histdef(hist_id, 'FloodplainsMap', 'Map of flooded areas', 'm^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)
CALL histdef(hist_id, 'SwampMap', 'Map of swamp areas', 'm^2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)
CALL histdef(hist_id, 'Dis', 'Simulated River Discharge', 'm^3/s', &
& iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
!-
!- The carbon budget
!-
IF ( control_flags%ok_co2 ) THEN
CALL histdef(hist_id, 'GPP', 'Net assimilation of carbon by the vegetation', 'gC/m^2/s', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt,dw)
ENDIF
IF ( control_flags%ok_stomate ) THEN
CALL histdef(hist_id, 'NEE', 'Net Ecosystem Exchange', 'gC/m^2/s', &
& iim,jjm, hori_id, 1, 1, 1, vegax_id, 32, fluxop_scinsec(1), dt,dw)
!MM
CALL histdef(hist_id, 'maint_resp', 'Maintenance respiration', 'gC/m2/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4), dt,dw)
CALL histdef(hist_id, 'hetero_resp', 'Heterotrophic respiration', 'gC/m2/d', &
& iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop(4), dt,dw)
CALL histdef(hist_id, 'growth_resp', 'Growth respiration', 'gC/m2/d', &
& iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4), dt,dw)
! Total output CO2 flux
CALL histdef (hist_id,'CO2FLUX','Total output CO2 flux', 'gC/day/(m^2 tot)', &
& iim,jjm, hori_id, 1,1,1, -99,32, ave(1), dt, dw)
ENDIF
!
ENDIF
!-
CALL histdef(hist_id, 'LandPoints', 'Land Points', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)
CALL histdef(hist_id, 'Areas', 'Mesh areas', 'm2', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt, dw)
CALL histdef(hist_id, 'Contfrac', 'Continental fraction', '-', &
& iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt, dw)
!-
CALL histend(hist_id)
!
!
! Second SECHIBA hist file
!
!-
!Config Key = SECHIBA_HISTFILE2
!Config Desc = Flag to switch on histfile 2 for SECHIBA (hi-frequency ?)
!Config Def = FALSE
!Config Help = This Flag switch on the second SECHIBA writing for hi (or low)
!Config frequency writing. This second output is optional and not written
!Config by default.
!Config MM is it right ? Second output file is produced with the same level
!Config as the first one.
!-
ok_histfile2=.FALSE.
CALL getin_p('SECHIBA_HISTFILE2', ok_histfile2)
WRITE(numout,*) 'SECHIBA_HISTFILE2 ', ok_histfile2
!
hist2_id = -1
!
IF (ok_histfile2) THEN
!-
!Config Key = SECHIBA_OUTPUT_FILE2
!Config Desc = Name of file in which the output number 2 is going
!Config to be written
!Config If = SECHIBA_HISTFILE2
!Config Def = sechiba_out_2.nc
!Config Help = This file is going to be created by the model
!Config and will contain the output 2 from the model.
!-
histname2='sechiba_out_2.nc'
CALL getin_p('SECHIBA_OUTPUT_FILE2', histname2)
WRITE(numout,*) 'SECHIBA_OUTPUT_FILE2 ', histname2
!-
!Config Key = WRITE_STEP2
!Config Desc = Frequency in seconds at which to WRITE output
!Config If = SECHIBA_HISTFILE2
!Config Def = 1800.0
!Config Help = This variables gives the frequency the output 2 of
!Config the model should be written into the netCDF file.
!Config It does not affect the frequency at which the
!Config operations such as averaging are done.
!Config That is IF the coding of the calls to histdef
!Config are correct !
!-
dw2 = 1800.0
CALL getin_p('WRITE_STEP2', dw2)
!-
!Config Key = SECHIBA_HISTLEVEL2
!Config Desc = SECHIBA history 2 output level (0..10)
!Config If = SECHIBA_HISTFILE2
!Config Def = 1
!Config Help = Chooses the list of variables in the history file.
!Config Values between 0: nothing is written; 10: everything is
!Config written are available More details can be found on the web under documentation.
!Config web under documentation.
!Config First level contains all ORCHIDEE outputs.
!-
hist2_level = 1
CALL getin_p('SECHIBA_HISTLEVEL2', hist2_level)
!-
WRITE(numout,*) 'SECHIBA history level 2 : ',hist2_level
IF ( (hist2_level > max_hist_level).OR.(hist2_level < 0) ) THEN
STOP 'This history level 2 is not allowed'
ENDIF
!
!-
!- define operations as a function of history level.
!- Above hist_level, operation='never'
!-
ave2(1:10) = 'ave(X)'
IF (hist2_level < 10) THEN
ave2(hist2_level+1:10) = 'never'
ENDIF
sumscatter2(1:10) = 't_sum(scatter(X))'
IF (hist2_level < 10) THEN
sumscatter2(hist2_level+1:10) = 'never'
ENDIF
avecels2(1:10) = 'ave(cels(X))'
IF (hist2_level < 10) THEN
avecels2(hist2_level+1:10) = 'never'
ENDIF
avescatter2(1:10) = 'ave(scatter(X))'
IF (hist2_level < 10) THEN
avescatter2(hist2_level+1:10) = 'never'
ENDIF
tmincels2(1:10) = 't_min(cels(X))'
IF (hist2_level < 10) THEN
tmincels2(hist2_level+1:10) = 'never'
ENDIF
tmaxcels2(1:10) = 't_max(cels(X))'
IF (hist2_level < 10) THEN
tmaxcels2(hist2_level+1:10) = 'never'
ENDIF
tmax2(1:10) = 't_max(X)'
IF (hist2_level < 10) THEN
tmax2(hist2_level+1:10) = 'never'
ENDIF
fluxop2(1:10) = flux_op
IF (hist2_level < 10) THEN
fluxop2(hist2_level+1:10) = 'never'
ENDIF
fluxop_sc2(1:10) = flux_sc
IF (hist2_level < 10) THEN
fluxop_sc2(hist2_level+1:10) = 'never'
ENDIF
fluxop_insec2(1:10) = flux_insec
IF (hist2_level < 10) THEN
fluxop_insec2(hist_level+1:10) = 'never'
ENDIF
fluxop_scinsec2(1:10) = flux_scinsec
IF (hist2_level < 10) THEN
fluxop_scinsec2(hist_level+1:10) = 'never'
ENDIF
once2(1:10) = 'once(scatter(X))'
IF (hist2_level < 10) THEN
once2(hist2_level+1:10) = 'never'
ENDIF
!
IF ( .NOT. almaoutput ) THEN
!-
IF ( rectilinear ) THEN
#ifdef CPP_PARA
CALL histbeg(histname2, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id2, hist2_id,orch_domain_id)
#else
CALL histbeg(histname2, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id2, hist2_id)
#endif
WRITE(numout,*) 'HISTBEG2 --->',istp_old,date0,dt,dw2,hist2_id
ELSE
#ifdef CPP_PARA
CALL histbeg(histname2, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id2, hist2_id,domain_id=orch_domain_id)
#else
CALL histbeg(histname2, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id2, hist2_id)
#endif
ENDIF
!-
CALL histvert(hist2_id, 'veget', 'Vegetation types', '-', &
& nvm, veg, vegax_id2)
CALL histvert(hist2_id, 'solth', 'Soil levels', 'm', &
& ngrnd, sol, solax_id2)
CALL histvert(hist2_id, 'soiltyp', 'Soil types', '-', &
& nstm, soltyp, soltax_id2)
CALL histvert(hist2_id, 'nobio', 'Other surface types', '-', &
& nnobio, nobiotyp, nobioax_id2)
CALL histvert(hist2_id, 'albtyp', 'Albedo Types', '-', &
& 2, albtyp, albax_id2)
IF ( control_flags%hydrol_cwrr ) THEN
CALL histvert(hist2_id, 'solay', 'Hydrol soil levels', 'm', &
& nslm, diaglev(1:nslm), solayax_id2)
ENDIF
!-
!- SECHIBA_HISTLEVEL = 1
!-
CALL histdef(hist2_id, 'cdrag', 'Drag coefficient for LE and SH', '?', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'z0', 'Surface roughness', 'm', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'coastalflow', 'Diffuse coastal flow', 'm^3/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(2), dt, dw2)
CALL histdef(hist2_id, 'riverflow', 'River flow to the oceans', 'm^3/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(2), dt, dw2)
CALL histdef(hist2_id, 'tsol_rad', 'Radiative surface temperature', 'C', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avecels2(4), dt, dw2)
CALL histdef(hist2_id, 'vevapnu', 'Bare soil evaporation', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(2), dt, dw2)
CALL histdef(hist2_id, 'temp_sol_new', 'New Surface Temperature', 'C', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avecels2(4), dt, dw2)
CALL histdef(hist2_id, 'qsurf', 'Near surface specific humidity', 'g/g', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
CALL histdef(hist2_id, 'albedo', 'Albedo', '-', &
& iim,jjm, hori_id2, 2,1,2, albax_id2, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'fluxsens', 'Sensible Heat Flux', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(2), dt, dw2)
CALL histdef(hist2_id, 'fluxlat', 'Latent Heat Flux', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(2), dt, dw2)
CALL histdef(hist2_id, 'emis', 'Surface emissivity', '?', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
!-
!- SECHIBA_HISTLEVEL = 2
!-
CALL histdef(hist2_id, 'evap', 'Evaporation', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(1), dt, dw2)
CALL histdef(hist2_id, 'vevapflo', 'Floodplains evaporation', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
CALL histdef(hist2_id, 'rain', 'Rainfall', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(1), dt, dw2)
CALL histdef(hist2_id, 'floodout', 'Flow out of floodplains', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt,dw2)
CALL histdef(hist2_id, 'flood_frac', 'Flooded fraction', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt,dw2)
CALL histdef(hist2_id, 'evapflo', 'Floodplains evaporation', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt,dw2)
CALL histdef(hist2_id, 'snowf', 'Snowfall', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(1), dt, dw2)
CALL histdef(hist2_id, 'netrad', 'Net radiation', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'lai', 'Leaf Area Index', '-', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(2), dt, dw2)
IF ( control_flags%river_routing ) THEN
CALL histdef(hist2_id, 'basinmap', 'Aproximate map of the river basins', ' ', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(1), dt, dw2)
CALL histdef(hist2_id, 'nbrivers', 'Number or rivers in the outflow grid box', ' ', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(2), dt, dw2)
ENDIF
!-
!- SECHIBA_HISTLEVEL = 3
!-
CALL histdef(hist2_id, 'subli', 'Sublimation', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(1), dt, dw2)
CALL histdef(hist2_id, 'runoff', 'Surface runoff', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(1), dt, dw2)
CALL histdef(hist2_id, 'drainage', 'Deep drainage', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(1), dt, dw2)
IF ( control_flags%river_routing ) THEN
CALL histdef(hist2_id, 'riversret', 'Return from endorheic rivers', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(3), dt, dw2)
CALL histdef(hist2_id, 'hydrographs', 'Hydrographs of gridbox outflow', 'm^3/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
ENDIF
IF ( control_flags%hydrol_cwrr ) THEN
CALL histdef(hist2_id, 'evapnu_soil', 'Bare soil evap for soil type', 'mm/d', &
& iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, fluxop2(3), dt, dw2)
CALL histdef(hist2_id, 'drainage_soil', 'Drainage for soil type', 'mm/d', &
& iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, fluxop2(3), dt, dw2)
CALL histdef(hist2_id, 'transpir_soil', 'Transpir for soil type', 'mm/d', &
& iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, fluxop2(3), dt, dw2)
CALL histdef(hist2_id, 'runoff_soil', 'Runoff for soil type', 'mm/d', &
& iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, fluxop2(3), dt, dw2)
ENDIF
!
CALL histdef(hist2_id, 'tair', 'Air Temperature', 'K', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(5), dt, dw2)
CALL histdef(hist2_id, 'qair', 'Air humidity', 'g/g', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
! Ajouts Nathalie - Juillet 2006
CALL histdef(hist2_id, 'q2m', '2m Air humidity', 'g/g', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(3), dt, dw2)
CALL histdef(hist2_id, 't2m', '2m Air Temperature', 'K', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(3), dt, dw2)
! Fin ajouts Nathalie
CALL histdef(hist2_id, 'alb_vis', 'Albedo visible', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(5), dt, dw2)
CALL histdef(hist2_id, 'alb_nir', 'Albedo near infrared', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(5), dt, dw2)
CALL histdef(hist2_id, 'roughheight', 'Effective roughness height', 'm', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'transpir', 'Transpiration', 'mm/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(3), dt, dw2)
CALL histdef(hist2_id, 'inter', 'Interception loss', 'mm/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(3), dt, dw2)
IF (check_waterbal) THEN
CALL histdef(hist2_id, 'TotWater', 'Total amount of water at end of time step', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(3), dt, dw2)
CALL histdef(hist2_id, 'TotWaterFlux', 'Total water flux', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(3), dt, dw2)
ENDIF
!-
!- SECHIBA_HISTLEVEL = 4
!-
CALL histdef(hist2_id, 'tsol_max', 'Maximum Surface Temperature',&
& 'C', iim,jjm, hori_id2, 1,1,1, -99, 32, tmaxcels2(4), dt, dw2)
CALL histdef(hist2_id, 'tsol_min', 'Minimum Surface Temperature',&
& 'C', iim,jjm, hori_id2, 1,1,1, -99, 32, tmincels2(4), dt, dw2)
CALL histdef(hist2_id, 'snow', 'Snow mass', 'kg/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'snowage', 'Snow age', '?', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'snownobio', 'Snow on other surfaces', 'kg/m^2', &
& iim,jjm, hori_id2, nnobio,1, nnobio, nobioax_id2, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'snownobioage', 'Snow age on other surfaces', 'd', &
& iim,jjm, hori_id2, nnobio,1, nnobio, nobioax_id2, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'vegetfrac', 'Fraction of vegetation', '-', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(4), dt, dw2)
CALL histdef(hist2_id, 'nobiofrac', 'Fraction of other surface types', '-', &
& iim,jjm, hori_id2, nnobio, 1, nnobio, nobioax_id2, 32, avescatter2(4), dt, dw2)
!MG
CALL histdef(hist2_id, 'frac_bare', 'Bare soil fraction for each tile', '-', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(3), dt,dw2)
IF ( control_flags%hydrol_cwrr ) THEN
DO jst=1,nstm
! var_name= "mc_1" ... "mc_3"
WRITE (var_name,"('moistc_',i1)") jst
CALL histdef(hist2_id, var_name, 'Soil Moisture profile for soil type', '%', &
& iim,jjm, hori_id2, nslm, 1, nslm, solayax_id2, 32, avescatter2(3), dt, dw2)
! var_name= "kfact_root_1" ... "kfact_root_3"
WRITE (var_name,"('kfactroot_',i1)") jst
CALL histdef(hist2_id, var_name, 'Root fraction profile for soil type', '%', &
& iim,jjm, hori_id2, nslm, 1, nslm, solayax_id2, 32, avescatter2(3), dt,dw2)
! var_name= "vegetsoil_1" ... "vegetsoil_3"
WRITE (var_name,"('vegetsoil_',i1)") jst
CALL histdef(hist2_id, var_name, 'Fraction of vegetation on soil types', '%', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(3), dt, dw2)
ENDDO
ENDIF
!-
!- SECHIBA_HISTLEVEL = 5
!-
IF ( .NOT. control_flags%hydrol_cwrr ) THEN
CALL histdef(hist2_id, 'gqsb', 'Upper Soil Moisture', '-', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'bqsb', 'Lower Soil Moisture', '-', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt, dw2)
ELSE
CALL histdef(hist2_id, 'humtot', 'Total Soil Moisture', 'Kg/m2', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'humtot_soil', 'Soil Moisture for soil type', 'Kg/m2', &
& iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'njsc', 'Soil class used for hydrology', '-', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, once2(1), dt,dw2)
CALL histdef(hist2_id, 'SWI', 'Soil wetness index','-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt,dw2)
ENDIF
CALL histdef(hist2_id, 'qsintveg', 'Water on canopy', 'Kg/m^2', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(3), dt, dw2)
CALL histdef(hist2_id, 'rstruct', 'Structural resistance', 's/m', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(5), dt, dw2)
IF ( control_flags%ok_co2 ) THEN
CALL histdef(hist2_id, 'gpp', 'CO2 Assimilation', 'gC/m2/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(5), dt, dw2)
ENDIF
IF ( control_flags%ok_stomate ) THEN
CALL histdef(hist2_id, 'nee', 'Net CO2 Ecossytem Exchange', 'gC/m2/d', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, fluxop2(5), dt, dw2)
CALL histdef(hist2_id, 'maint_resp', 'Maintenance respiration', 'gC/m2/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(5), dt, dw2)
CALL histdef(hist2_id, 'hetero_resp', 'Heterotrophic respiration', 'gC/m2/d', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, fluxop2(5), dt, dw2)
CALL histdef(hist2_id, 'growth_resp', 'Growth respiration', 'gC/m2/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(5), dt, dw2)
CALL histdef (hist2_id,'CO2FLUX','Total output CO2 flux', 'gC/day/(m^2 tot)', &
& iim,jjm, hori_id2, 1,1,1, -99,32, fluxop2(5), dt, dw2)
ENDIF
CALL histdef(hist2_id, 'precisol', 'Throughfall', 'mm/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(5), dt, dw2)
CALL histdef(hist2_id, 'drysoil_frac', 'Fraction of visibly dry soil', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(5), dt, dw2)
CALL histdef(hist2_id, 'evapot', 'Potential evaporation', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(5), dt, dw2)
CALL histdef(hist2_id, 'evapot_corr', 'Potential evaporation', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(3), dt, dw2)
!-
!- SECHIBA_HISTLEVEL = 6
!-
CALL histdef(hist2_id, 'swnet', 'Net solar radiation', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(6), dt, dw2)
CALL histdef(hist2_id, 'swdown', 'Incident solar radiation', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(3), dt, dw2)
CALL histdef(hist2_id, 'lwdown', 'Absorbed downward longwave radiation', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(3), dt, dw2)
CALL histdef(hist2_id, 'lwnet', 'Net surface longwave radiation', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(6), dt, dw2)
CALL histdef(hist2_id, 'temp_pheno', 'Temperature for Pheno', 'K', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(5), dt, dw2)
!-
!- SECHIBA_HISTLEVEL = 7
!-
CALL histdef(hist2_id, 'ptn', 'Deep ground temperature', 'K', &
& iim,jjm, hori_id2, ngrnd, 1, ngrnd, solax_id2, 32, avescatter2(7), dt, dw2)
!-
!- SECHIBA_HISTLEVEL = 8
!-
IF ( control_flags%river_routing ) THEN
CALL histdef(hist2_id, 'fastr', 'Fast flow reservoir', 'kg/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'slowr', 'Slow flow reservoir', 'kg/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'streamr', 'Stream flow reservoir', 'kg/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'floodr', 'Floodplains reservoir', 'kg/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt,dw2)
CALL histdef(hist2_id, 'floodh', 'Floodplains height', 'mm', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt,dw2)
CALL histdef(hist2_id, 'pondr', 'Ponds reservoir', 'kg/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt,dw2)
CALL histdef(hist2_id, 'lakevol', 'Volume in lake reservoir', 'kg/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt, dw2)
CALL histdef(hist2_id, 'irrigation', 'Net irrigation', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(8), dt, dw2)
CALL histdef(hist2_id, 'returnflow', 'Returnflow to bottom layer', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(8), dt,dw2)
CALL histdef(hist2_id, 'netirrig', 'Net irrigation requirement', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(8), dt, dw2)
CALL histdef(hist2_id, 'irrigmap', 'Map of irrigated areas', 'm^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(8), dt, dw2)
CALL histdef(hist2_id, 'floodmap', 'Map of floodplain fractions', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(8), dt,dw2)
CALL histdef(hist2_id, 'swampmap', 'Map of swamp fractions', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(8), dt,dw2)
ENDIF
!-
!- SECHIBA_HISTLEVEL = 9
!-
CALL histdef(hist2_id, 'k_litt', 'Litter cond', 'mm/d', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt,dw2)
CALL histdef(hist2_id, 'beta', 'Beta Function', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
CALL histdef(hist2_id, 'raero', 'Aerodynamic resistance', 's/m', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
! Ajouts Nathalie - Novembre 2006
CALL histdef(hist2_id, 'Wind', 'Wind speed', 'm/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
! Fin ajouts Nathalie
CALL histdef(hist2_id, 'vbeta1', 'Beta for sublimation', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
CALL histdef(hist2_id, 'vbeta4', 'Beta for bare soil', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
CALL histdef(hist2_id, 'vbeta5', 'Beta for bare soil', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
CALL histdef(hist2_id, 'vbetaco2', 'beta for CO2', 'mm/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(9), dt, dw2)
CALL histdef(hist2_id, 'soiltile', 'Fraction of soil tile', '%', &
& iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, once2(9), dt, dw2)
CALL histdef(hist2_id, 'reinf_slope', 'Slope index for each grid box', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(9), dt,dw2)
CALL histdef(hist2_id, 'soilindex', 'Soil index', '-', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, once2(9), dt,dw2)
CALL histdef(hist2_id, 'soildepth', 'Soil Depth', 'm', &
& iim,jjm, hori_id2, nstm, 1, nstm, soltax_id, 32, once2(1), dt,dw2)
CALL histdef(hist2_id, 'humrel', 'Soil moisture stress', '-', &
& iim,jjm, hori_id2, nvm,1,nvm, vegax_id2, 32, avescatter2(9), dt, dw2)
!-
!- SECHIBA_HISTLEVEL = 10
!-
CALL histdef(hist2_id, 'cimean', 'Stomatal CO2 concentation', 'mmole/m2/s', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
CALL histdef(hist2_id, 'vbeta3', 'Beta for Transpiration', 'mm/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
!MG
CALL histdef(hist2_id, 'etm', 'Maximum evapotranspiration', 'mm/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(10), dt,dw2)
CALL histdef(hist2_id, 'rveget', 'Canopy resistance', 's/m', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
CALL histdef(hist2_id, 'rsol', 'Soil resistance', 's/m', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt, dw2)
CALL histdef(hist2_id,'vbeta2','Beta for Interception loss','mm/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
CALL histdef(hist2_id, 'qsintmax', 'Maximum Interception capacity', 'Kg/m^2', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
!
ELSE
!-
!- This is the ALMA convention output now
!-
!-
IF ( rectilinear ) THEN
#ifdef CPP_PARA
CALL histbeg(histname2, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id2, hist2_id,orch_domain_id)
#else
CALL histbeg(histname2, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id2, hist2_id)
#endif
WRITE(numout,*) 'HISTBEG2 --->',istp_old,date0,dt,dw2,hist2_id
ELSE
#ifdef CPP_PARA
CALL histbeg(histname2, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id2, hist2_id,domain_id=orch_domain_id)
#else
CALL histbeg(histname2, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id2, hist2_id)
#endif
ENDIF
!-
CALL histvert(hist2_id, 'veget', 'Vegetation types', '-', &
& nvm, veg, vegax_id2)
CALL histvert(hist2_id, 'solth', 'Soil levels', 'm', &
& ngrnd, sol, solax_id2)
CALL histvert(hist2_id, 'soiltyp', 'Soil types', '-', &
& nstm, soltyp, soltax_id2)
CALL histvert(hist2_id, 'nobio', 'Other surface types', '-', &
& nnobio, nobiotyp, nobioax_id2)
IF ( control_flags%hydrol_cwrr ) THEN
CALL histvert(hist2_id, 'solay', 'Hydrol soil levels', 'm', &
& nslm, diaglev(1:nslm), solayax_id2)
ENDIF
!-
!- Vegetation
!-
CALL histdef(hist2_id, 'vegetfrac', 'Fraction of vegetation', '-', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(3), dt, dw2)
CALL histdef(hist2_id, 'nobiofrac', 'Fraction of other surface types', '-', &
& iim,jjm, hori_id2, nnobio, 1, nnobio, nobioax_id2, 32, avescatter2(3), dt, dw2)
!-
!- General energy balance
!-
CALL histdef(hist2_id, 'SWnet', 'Net shortwave radiation', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
CALL histdef(hist2_id, 'LWnet', 'Net longwave radiation', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'Qh', 'Sensible heat flux', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
CALL histdef(hist2_id, 'Qle', 'Latent heat flux', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
CALL histdef(hist2_id, 'Qg', 'Ground heat flux', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'Qf', 'Energy of fusion', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
! & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(2), dt, dw2)
CALL histdef(hist2_id, 'Qv', 'Energy of sublimation', 'W/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'DelSurfHeat', 'Change in surface layer heat', 'J/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, sumscatter2(1), dt, dw2)
CALL histdef(hist2_id, 'DelColdCont', 'Change in snow surface layer cold content', 'J/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, sumscatter2(1), dt, dw2)
!-
!- General water balance
!-
CALL histdef(hist2_id, 'Snowf', 'Snowfall rate', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'Rainf', 'Rainfall rate', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'Evap', 'Total Evapotranspiration', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'Qs', 'Surface runoff', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'Qrec', 'Recharge', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt,dw2)
CALL histdef(hist2_id, 'Qsb', 'Sub-surface runoff', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'Qsm', 'Snowmelt', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'DelSoilMoist', 'Change in soil moisture', 'kg/m^2', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(1), dt, dw2)
CALL histdef(hist2_id, 'DelSurfStor', 'Change in Surface Water Storage','kg/m^2',&
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(1), dt,dw2)
CALL histdef(hist2_id, 'DelIntercept', 'Change in interception storage', 'kg/m^2', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(1), dt, dw2)
!-
!- Surface state
!-
CALL histdef(hist2_id, 'AvgSurfT', 'Average surface temperature', 'K', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
CALL histdef(hist2_id, 'RadT', 'Surface radiative temperature', 'K', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
CALL histdef(hist2_id, 'Albedo', 'Albedo', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
! CALL histdef(hist2_id, 'SWI', 'Soil wetness index','-', &
! & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt,dw2)
CALL histdef(hist2_id, 'SurfStor', 'Surface Water Storage','kg/m^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt,dw2)
!!-
!- Sub-surface state
!-
IF ( .NOT. control_flags%hydrol_cwrr ) THEN
CALL histdef(hist2_id, 'SoilMoist', '3D average layer soil moisture', 'kg/m^2', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt, dw2)
ELSE
CALL histdef(hist2_id, 'SoilMoist', '3D average layer soil moisture', 'kg/m^2', &
& iim,jjm, hori_id2, nslm, 1, nslm, solayax_id2, 32, avescatter2(1), dt, dw2)
ENDIF
CALL histdef(hist2_id, 'SoilWet', 'Total soil wetness', 'kg/m^2', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'SoilTemp', '3D layer average soil temperature', 'K', &
& iim,jjm, hori_id2, ngrnd, 1, ngrnd, solax_id2, 32, avescatter2(1), dt, dw2)
!-
!- Evaporation components
!-
CALL histdef(hist2_id, 'PotEvap', 'Potential evapotranspiration', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'ECanop', 'Interception evaporation', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'TVeg', 'Transpiration', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'ESoil', 'Bare soil evaporation', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'EWater', 'Open water evaporation', 'kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'RootMoist','Root zone soil water', 'kg/m^2', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'SubSnow','Snow sublimation','kg/m^2/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
CALL histdef(hist2_id, 'ACond', 'Aerodynamic conductance', 'm/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
!-
!-
!- Cold Season Processes
!-
CALL histdef(hist2_id, 'SnowFrac', 'Snow cover fraction', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'SAlbedo', 'Snow albedo', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
CALL histdef(hist2_id, 'SnowDepth', '3D snow depth', 'm', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
!-
!- Hydrologic variables
!-
CALL histdef(hist2_id, 'IrrigationMap', 'Map of irrigated areas', 'm^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(1), dt, dw2)
CALL histdef(hist2_id, 'FloodplainsMap', 'Map of flooded areas', 'm^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(1), dt,dw2)
CALL histdef(hist2_id, 'SwampMap', 'Map of swamp areas', 'm^2', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(1), dt,dw2)
CALL histdef(hist2_id, 'Dis', 'Simulated River Discharge', 'm^3/s', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt,dw2)
!-
!- The carbon budget
!-
IF ( control_flags%ok_co2 ) THEN
CALL histdef(hist2_id, 'GPP', 'Net assimilation of carbon by the vegetation', 'gC/m^2/s', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(1), dt, dw2)
ENDIF
IF ( control_flags%ok_stomate ) THEN
CALL histdef(hist2_id, 'NEE', 'Net Ecosystem Exchange', 'gC/m^2/s', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, fluxop_scinsec2(1), dt, dw2)
!MM
CALL histdef(hist2_id, 'maint_resp', 'Maintenance respiration', 'gC/m2/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(4), dt, dw2)
CALL histdef(hist2_id, 'hetero_resp', 'Heterotrophic respiration', 'gC/m2/d', &
& iim,jjm, hori_id2, 1, 1, 1, -99, 32, fluxop2(4), dt, dw2)
CALL histdef(hist2_id, 'growth_resp', 'Growth respiration', 'gC/m2/d', &
& iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(4), dt, dw2)
! Total output CO2 flux
CALL histdef (hist2_id,'CO2FLUX','Total output CO2 flux', 'gC/day/(m^2 tot)', &
& iim,jjm, hori_id2, 1,1,1, -99,32, ave2(1), dt, dw2)
ENDIF
!
ENDIF
!-
CALL histdef(hist2_id, 'LandPoints', 'Land Points', '-', &
& iim,jjm, hori_id2, 1,1,1, -99, 32, once2(1), dt, dw2)
!-
CALL histend(hist2_id)
ENDIF
!-
!=====================================================================
!- 3.2 STOMATE's history file
!=====================================================================
IF ( control_flags%ok_stomate ) THEN
!-
! STOMATE IS ACTIVATED
!-
!Config Key = STOMATE_OUTPUT_FILE
!Config Desc = Name of file in which STOMATE's output is going
!Config to be written
!Config Def = stomate_history.nc
!Config Help = This file is going to be created by the model
!Config and will contain the output from the model.
!Config This file is a truly COADS compliant netCDF file.
!Config It will be generated by the hist software from
!Config the IOIPSL package.
!-
stom_histname='stomate_history.nc'
CALL getin_p('STOMATE_OUTPUT_FILE', stom_histname)
WRITE(numout,*) 'STOMATE_OUTPUT_FILE', TRIM(stom_histname)
!-
!Config Key = STOMATE_HIST_DT
!Config Desc = STOMATE history time step (d)
!Config Def = 10.
!Config Help = Time step of the STOMATE history file
!-
hist_days_stom = 10.
CALL getin_p('STOMATE_HIST_DT', hist_days_stom)
hist_dt_stom = NINT( hist_days_stom ) * one_day
WRITE(numout,*) 'output frequency for STOMATE history file (d): ', &
hist_dt_stom/one_day
! test consistency between STOMATE_HIST_DT and DT_SLOW parameters
dt_slow_ = one_day
CALL getin_p('DT_SLOW', dt_slow_)
IF (dt_slow_ > hist_dt_stom) THEN
WRITE(numout,*) "DT_SLOW = ",dt_slow_," , STOMATE_HIST_DT = ",hist_dt_stom
CALL ipslerr (3,'intsurf_history', &
& 'Problem with DT_SLOW > STOMATE_HIST_DT','', &
& '(must be less or equal)')
ENDIF
!-
!- initialize
IF ( rectilinear ) THEN
#ifdef CPP_PARA
CALL histbeg(stom_histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id_stom,domain_id=orch_domain_id)
#else
CALL histbeg(stom_histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id_stom)
#endif
ELSE
#ifdef CPP_PARA
CALL histbeg(stom_histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id_stom,domain_id=orch_domain_id)
#else
CALL histbeg(stom_histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
& istp_old, date0, dt, hori_id, hist_id_stom)
#endif
ENDIF
!- define PFT axis
hist_PFTaxis = (/ ( REAL(i,r_std), i=1,npft ) /)
!- declare this axis
CALL histvert (hist_id_stom, 'PFT', 'Plant functional type', &
& '-', npft, hist_PFTaxis, hist_PFTaxis_id)
! deforestation
!- define Pool_10 axis
hist_pool_10axis = (/ ( REAL(i,r_std), i=1,10 ) /)
!- declare this axis
CALL histvert (hist_id_stom, 'P10', 'Pool 10 years', &
& '-', 10, hist_pool_10axis, hist_pool_10axis_id)
!- define Pool_100 axis
hist_pool_100axis = (/ ( REAL(i,r_std), i=1,100 ) /)
!- declare this axis
CALL histvert (hist_id_stom, 'P100', 'Pool 100 years', &
& '-', 100, hist_pool_100axis, hist_pool_100axis_id)
!- define Pool_11 axis
hist_pool_11axis = (/ ( REAL(i,r_std), i=1,11 ) /)
!- declare this axis
CALL histvert (hist_id_stom, 'P11', 'Pool 10 years + 1', &
& '-', 11, hist_pool_11axis, hist_pool_11axis_id)
!- define Pool_101 axis
hist_pool_101axis = (/ ( REAL(i,r_std), i=1,101 ) /)
!- declare this axis
CALL histvert (hist_id_stom, 'P101', 'Pool 100 years + 1', &
& '-', 101, hist_pool_101axis, hist_pool_101axis_id)
!- define STOMATE history file
CALL stom_define_history (hist_id_stom, npft, iim, jjm, &
& dt, hist_dt_stom, hori_id, hist_PFTaxis_id, &
& hist_pool_10axis_id, hist_pool_100axis_id, &
& hist_pool_11axis_id, hist_pool_101axis_id)
! deforestation axis added as arguments
!- end definition
CALL histend(hist_id_stom)
!-
ENDIF
RETURN
END SUBROUTINE intsurf_history
!
SUBROUTINE stom_define_history &
& (hist_id_stom, npft, iim, jjm, dt, &
& hist_dt, hist_hori_id, hist_PFTaxis_id, &
& hist_pool_10axis_id, hist_pool_100axis_id, &
& hist_pool_11axis_id, hist_pool_101axis_id)
! deforestation axis added as arguments
!---------------------------------------------------------------------
!- Tell ioipsl which variables are to be written
!- and on which grid they are defined
!---------------------------------------------------------------------
IMPLICIT NONE
!-
!- Input
!-
!- File id
INTEGER(i_std),INTENT(in) :: hist_id_stom
!- number of PFTs
INTEGER(i_std),INTENT(in) :: npft
!- Domain size
INTEGER(i_std),INTENT(in) :: iim, jjm
!- Time step of STOMATE (seconds)
REAL(r_std),INTENT(in) :: dt
!- Time step of history file (s)
REAL(r_std),INTENT(in) :: hist_dt
!- id horizontal grid
INTEGER(i_std),INTENT(in) :: hist_hori_id
!- id of PFT axis
INTEGER(i_std),INTENT(in) :: hist_PFTaxis_id
!- id of Deforestation axis
INTEGER(i_std),INTENT(in) :: hist_pool_10axis_id,hist_pool_100axis_id
INTEGER(i_std),INTENT(in) :: hist_pool_11axis_id,hist_pool_101axis_id
!-
!- 1 local
!-
!- maximum history level
INTEGER(i_std), PARAMETER :: max_hist_level = 10
!- output level (between 0 and 10)
!- ( 0:nothing is written, 10:everything is written)
INTEGER(i_std) :: hist_level
!- Character strings to define operations for histdef
CHARACTER(LEN=40),DIMENSION(max_hist_level) :: ave
!---------------------------------------------------------------------
!=====================================================================
!- 1 history level
!=====================================================================
!- 1.1 define history levelx
!=====================================================================
!Config Key = STOMATE_HISTLEVEL
!Config Desc = STOMATE history output level (0..10)
!Config Def = 10
!Config Help = 0: nothing is written; 10: everything is written
!-
hist_level = 10
CALL getin_p('STOMATE_HISTLEVEL', hist_level)
!-
WRITE(numout,*) 'STOMATE history level: ',hist_level
IF ( (hist_level > max_hist_level).OR.(hist_level < 0) ) THEN
STOP 'This history level is not allowed'
ENDIF
!=====================================================================
!- 1.2 define operations according to output level
!=====================================================================
ave(1:hist_level) = 'ave(scatter(X))'
ave(hist_level+1:max_hist_level) = 'never '
!=====================================================================
!- 2 surface fields (2d)
!- 3 PFT: 3rd dimension
!=====================================================================
! fraction of total space that is natural
CALL histdef (hist_id_stom, &
& TRIM("SPACE_NAT "), &
& TRIM("fraction of total space that is natural "), &
& TRIM("- "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(1), dt, hist_dt)
! structural litter above nat. ground
CALL histdef (hist_id_stom, &
& TRIM("LITTER_STR_AB_NAT "), &
& TRIM("structural litter above nat. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! structural litter above agric. ground
CALL histdef (hist_id_stom, &
& TRIM("LITTER_STR_AB_AGRI "), &
& TRIM("structural litter above agric. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! metabolic litter above nat. ground
CALL histdef (hist_id_stom, &
& TRIM("LITTER_MET_AB_NAT "), &
& TRIM("metabolic litter above nat. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! metabolic litter above agric. ground
CALL histdef (hist_id_stom, &
& TRIM("LITTER_MET_AB_AGRI "), &
& TRIM("metabolic litter above agric. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! structural litter below nat. ground
CALL histdef (hist_id_stom, &
& TRIM("LITTER_STR_BE_NAT "), &
& TRIM("structural litter below nat. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! structural litter below agric. ground
CALL histdef (hist_id_stom, &
& TRIM("LITTER_STR_BE_AGRI "), &
& TRIM("structural litter below agric. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! metabolic litter below nat. ground
CALL histdef (hist_id_stom, &
& TRIM("LITTER_MET_BE_NAT "), &
& TRIM("metabolic litter below nat. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! metabolic litter below agric. ground
CALL histdef (hist_id_stom, &
& TRIM("LITTER_MET_BE_AGRI "), &
& TRIM("metabolic litter below agric. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! fraction of soil covered by dead leaves
CALL histdef (hist_id_stom, &
& TRIM("DEADLEAF_COVER "), &
& TRIM("fraction of soil covered by dead leaves "), &
& TRIM("- "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! active soil carbon in nat. ground
CALL histdef (hist_id_stom, &
& TRIM("CARBON_ACTIVE_NAT "), &
& TRIM("active soil carbon in nat. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! active soil carbon in agric. ground
CALL histdef (hist_id_stom, &
& TRIM("CARBON_ACTIVE_AGRI "), &
& TRIM("active soil carbon in agric. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! slow soil carbon in nat. ground
CALL histdef (hist_id_stom, &
& TRIM("CARBON_SLOW_NAT "), &
& TRIM("slow soil carbon in nat. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! slow soil carbon in agric. ground
CALL histdef (hist_id_stom, &
& TRIM("CARBON_SLOW_AGRI "), &
& TRIM("slow soil carbon in agric. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! passive soil carbon in nat. ground
CALL histdef (hist_id_stom, &
& TRIM("CARBON_PASSIVE_NAT "), &
& TRIM("passive soil carbon in nat. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! passive soil carbon in agric. ground
CALL histdef (hist_id_stom, &
& TRIM("CARBON_PASSIVE_AGRI "), &
& TRIM("passive soil carbon in agric. ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! Monthly 2 m temperature
CALL histdef (hist_id_stom, &
& TRIM("T2M_MONTH "), &
& TRIM("Monthly 2 m temperature "), &
& TRIM("K "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(1), dt, hist_dt)
! Weekly 2 m temperature
CALL histdef (hist_id_stom, &
& TRIM("T2M_WEEK "), &
& TRIM("Weekly 2 m temperature "), &
& TRIM("K "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(1), dt, hist_dt)
! heterotr. resp. from nat. ground
CALL histdef (hist_id_stom, &
& TRIM("HET_RESP_NAT "), &
& TRIM("heterotr. resp. from nat. ground "), &
& TRIM("gC/m^2 tot/day "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(3), dt, hist_dt)
! heterotr. resp. from agric. ground
CALL histdef (hist_id_stom, &
& TRIM("HET_RESP_AGRI "), &
& TRIM("heterotr. resp. from agric. ground "), &
& TRIM("gC/m^2 tot/day "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(3), dt, hist_dt)
! black carbon on average total ground
CALL histdef (hist_id_stom, &
& TRIM("BLACK_CARBON "), &
& TRIM("black carbon on average total ground "), &
& TRIM("gC/m^2 tot "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(10), dt, hist_dt)
! Fire fraction on natural ground
CALL histdef (hist_id_stom, &
& TRIM("FIREFRAC_NAT "), &
& TRIM("Fire fraction on natural ground "), &
& TRIM("1/day "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(1), dt, hist_dt)
! Fire fraction on agricultural ground
CALL histdef (hist_id_stom, &
& TRIM("FIREFRAC_AGRI "), &
& TRIM("Fire fraction on agricultural ground "), &
& TRIM("1/day "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(1), dt, hist_dt)
! Fire index on natural ground
CALL histdef (hist_id_stom, &
& TRIM("FIREINDEX_NAT "), &
& TRIM("Fire index on natural ground "), &
& TRIM("- "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(10), dt, hist_dt)
! Litter humidity
CALL histdef (hist_id_stom, &
& TRIM("LITTERHUM "), &
& TRIM("Litter humidity "), &
& TRIM("- "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! Monthly CO2 flux
CALL histdef (hist_id_stom, &
& TRIM("CO2FLUX_MONTHLY "), &
& TRIM("Monthly CO2 flux "), &
& TRIM("gC/m^2/mth "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(1), dt, hist_dt)
! Output CO2 flux from fire
CALL histdef (hist_id_stom, &
& TRIM("CO2_FIRE "), &
& TRIM("Output CO2 flux from fire "), &
& TRIM("gC/day/(m^2 (n/a)) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(1), dt, hist_dt)
! CO2 taken from atmosphere for initiate growth
CALL histdef (hist_id_stom, &
& TRIM("CO2_TAKEN "), &
& TRIM("CO2 taken from atmosphere for initiate growth "), &
& TRIM("gC/day/(m^2 (n/a)) "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(1), dt, hist_dt)
! Leaf Area Index
CALL histdef (hist_id_stom, &
& TRIM("LAI "), &
& TRIM("Leaf Area Index "), &
& TRIM("- "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
! Vegetation fraction
CALL histdef (hist_id_stom, &
& TRIM("VEGET "), &
& TRIM("Vegetation fraction "), &
& TRIM("- "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
! Maximum vegetation fraction (LAI -> infinity)
CALL histdef (hist_id_stom, &
& TRIM("VEGET_MAX "), &
& TRIM("Maximum vegetation fraction (LAI -> infinity) "), &
& TRIM("- "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
! Net primary productivity
CALL histdef (hist_id_stom, &
& TRIM("NPP "), &
& TRIM("Net primary productivity "), &
& TRIM("gC/day/(m^2 tot) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
! Gross primary productivity
CALL histdef (hist_id_stom, &
& TRIM("GPP "), &
& TRIM("Gross primary productivity "), &
& TRIM("gC/day/(m^2 (n/a)) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
! Density of individuals
CALL histdef (hist_id_stom, &
& TRIM("IND "), &
& TRIM("Density of individuals "), &
& TRIM("1/(m^2 (n/a)) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
! Leaf mass
CALL histdef (hist_id_stom, &
& TRIM("LEAF_M "), &
& TRIM("Leaf mass "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! Sap mass above ground
CALL histdef (hist_id_stom, &
& TRIM("SAP_M_AB "), &
& TRIM("Sap mass above ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! Sap mass below ground
CALL histdef (hist_id_stom, &
& TRIM("SAP_M_BE "), &
& TRIM("Sap mass below ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! Heartwood mass above ground
CALL histdef (hist_id_stom, &
& TRIM("HEART_M_AB "), &
& TRIM("Heartwood mass above ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! Heartwood mass below ground
CALL histdef (hist_id_stom, &
& TRIM("HEART_M_BE "), &
& TRIM("Heartwood mass below ground "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! Root mass
CALL histdef (hist_id_stom, &
& TRIM("ROOT_M "), &
& TRIM("Root mass "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! Fruit mass
CALL histdef (hist_id_stom, &
& TRIM("FRUIT_M "), &
& TRIM("Fruit mass "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! Carbohydrate reserve mass
CALL histdef (hist_id_stom, &
& TRIM("RESERVE_M "), &
& TRIM("Carbohydrate reserve mass "), &
& TRIM("gC/m^2 (n/a) "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! Leaf turnover
CALL histdef (hist_id_stom, &
& TRIM("LEAF_TURN "), &
& TRIM("Leaf turnover "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Sap turnover above
CALL histdef (hist_id_stom, &
& TRIM("SAP_AB_TURN "), &
& TRIM("Sap turnover above "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Root turnover
CALL histdef (hist_id_stom, &
& TRIM("ROOT_TURN "), &
& TRIM("Root turnover "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Fruit turnover
CALL histdef (hist_id_stom, &
& TRIM("FRUIT_TURN "), &
& TRIM("Fruit turnover "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Leaf death
CALL histdef (hist_id_stom, &
& TRIM("LEAF_BM_LITTER "), &
& TRIM("Leaf death "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Sap death above ground
CALL histdef (hist_id_stom, &
& TRIM("SAP_AB_BM_LITTER "), &
& TRIM("Sap death above ground "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Sap death below ground
CALL histdef (hist_id_stom, &
& TRIM("SAP_BE_BM_LITTER "), &
& TRIM("Sap death below ground "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Heartwood death above ground
CALL histdef (hist_id_stom, &
& TRIM("HEART_AB_BM_LITTER "), &
& TRIM("Heartwood death above ground "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Heartwood death below ground
CALL histdef (hist_id_stom, &
& TRIM("HEART_BE_BM_LITTER "), &
& TRIM("Heartwood death below ground "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Root death
CALL histdef (hist_id_stom, &
& TRIM("ROOT_BM_LITTER "), &
& TRIM("Root death "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Fruit death
CALL histdef (hist_id_stom, &
& TRIM("FRUIT_BM_LITTER "), &
& TRIM("Fruit death "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Carbohydrate reserve death
CALL histdef (hist_id_stom, &
& TRIM("RESERVE_BM_LITTER "), &
& TRIM("Carbohydrate reserve death "), &
& TRIM("gC/m^2 (n/a)/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
! Maintenance respiration
CALL histdef (hist_id_stom, &
& TRIM("MAINT_RESP "), &
& TRIM("Maintenance respiration "), &
& TRIM("gC/m^2 tot/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! Growth respiration
CALL histdef (hist_id_stom, &
& TRIM("GROWTH_RESP "), &
& TRIM("Growth respiration "), &
& TRIM("gC/m^2 tot/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
! age
CALL histdef (hist_id_stom, &
& TRIM("AGE "), &
& TRIM("age "), &
& TRIM("years "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(7), dt, hist_dt)
! height
CALL histdef (hist_id_stom, &
& TRIM("HEIGHT "), &
& TRIM("height "), &
& TRIM("m "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(7), dt, hist_dt)
! weekly moisture stress
CALL histdef (hist_id_stom, &
& TRIM("MOISTRESS "), &
& TRIM("weekly moisture stress "), &
& TRIM("- "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
! Maximum rate of carboxylation
CALL histdef (hist_id_stom, &
& TRIM("VCMAX "), &
& TRIM("Maximum rate of carboxylation "), &
& TRIM("- "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
! leaf age
CALL histdef (hist_id_stom, &
& TRIM("LEAF_AGE "), &
& TRIM("leaf age "), &
& TRIM("days "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
! Fraction of trees that dies (gap)
CALL histdef (hist_id_stom, &
& TRIM("MORTALITY "), &
& TRIM("Fraction of trees that dies (gap) "), &
& TRIM("1/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
! Fraction of plants killed by fire
CALL histdef (hist_id_stom, &
& TRIM("FIREDEATH "), &
& TRIM("Fraction of plants killed by fire "), &
& TRIM("1/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
! Density of newly established saplings
CALL histdef (hist_id_stom, &
& TRIM("IND_ESTAB "), &
& TRIM("Density of newly established saplings "), &
& TRIM("1/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
! Fraction of plants that dies (light competition)
CALL histdef (hist_id_stom, &
& TRIM("LIGHT_DEATH "), &
& TRIM("Fraction of plants that dies (light competition) "), &
& TRIM("1/day "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
! biomass allocated to leaves
CALL histdef (hist_id_stom, &
& TRIM("BM_ALLOC_LEAF "), &
& TRIM("biomass allocated to leaves "), &
& TRIM("gC/m**2 nat/agri/dt "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
! biomass allocated to sapwood above ground
CALL histdef (hist_id_stom, &
& TRIM("BM_ALLOC_SAP_AB "), &
& TRIM("biomass allocated to sapwood above ground "), &
& TRIM("gC/m**2 nat/agri/dt "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
! biomass allocated to sapwood below ground
CALL histdef (hist_id_stom, &
& TRIM("BM_ALLOC_SAP_BE "), &
& TRIM("biomass allocated to sapwood below ground "), &
& TRIM("gC/m**2 nat/agri/dt "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
! biomass allocated to roots
CALL histdef (hist_id_stom, &
& TRIM("BM_ALLOC_ROOT "), &
& TRIM("biomass allocated to roots "), &
& TRIM("gC/m**2 nat/agri/dt "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
! biomass allocated to fruits
CALL histdef (hist_id_stom, &
& TRIM("BM_ALLOC_FRUIT "), &
& TRIM("biomass allocated to fruits "), &
& TRIM("gC/m**2 nat/agri/dt "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
! biomass allocated to carbohydrate reserve
CALL histdef (hist_id_stom, &
& TRIM("BM_ALLOC_RES "), &
& TRIM("biomass allocated to carbohydrate reserve "), &
& TRIM("gC/m**2 nat/agri/dt "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
! time constant of herbivore activity
CALL histdef (hist_id_stom, &
& TRIM("HERBIVORES "), &
& TRIM("time constant of herbivore activity "), &
& TRIM("days "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
! turnover time for grass leaves
CALL histdef (hist_id_stom, &
& TRIM("TURNOVER_TIME "), &
& TRIM("turnover time for grass leaves "), &
& TRIM("days "), iim,jjm, hist_hori_id, &
& npft,1,npft, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
! 10 year wood product pool
CALL histdef (hist_id_stom, &
& TRIM("PROD10 "), &
& TRIM("10 year wood product pool "), &
& TRIM("gC/m**2 nat/agri "), iim,jjm, hist_hori_id, &
& 11,1,11, hist_pool_11axis_id,32, ave(5), dt, hist_dt)
! annual flux for each 10 year wood product pool
CALL histdef (hist_id_stom, &
& TRIM("FLUX10 "), &
& TRIM("annual flux for each 10 year wood product pool "), &
& TRIM("gC/m**2 nat/agri/yr "), iim,jjm, hist_hori_id, &
& 10,1,10, hist_pool_10axis_id,32, ave(5), dt, hist_dt)
! 100 year wood product pool
CALL histdef (hist_id_stom, &
& TRIM("PROD100 "), &
& TRIM("100 year wood product pool "), &
& TRIM("gC/m**2 nat/agri "), iim,jjm, hist_hori_id, &
& 101,1,101, hist_pool_101axis_id,32, ave(5), dt, hist_dt)
! annual flux for each 100 year wood product pool
CALL histdef (hist_id_stom, &
& TRIM("FLUX100 "), &
& TRIM("annual flux for each 100 year wood product pool "), &
& TRIM("gC/m**2 nat/agri/yr "), iim,jjm, hist_hori_id, &
& 100,1,100, hist_pool_100axis_id,32, ave(5), dt, hist_dt)
! annual release right after deforestation
CALL histdef (hist_id_stom, &
& TRIM("CONVFLUX "), &
& TRIM("annual release right after deforestation "), &
& TRIM("gC/m**2 nat/agri/yr "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! annual release from all 10 year wood product pools
CALL histdef (hist_id_stom, &
& TRIM("CFLUX_PROD10 "), &
& TRIM("annual release from all 10 year wood product pools"), &
& TRIM("gC/m**2 nat/agri/yr "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
! annual release from all 100year wood product pools
CALL histdef (hist_id_stom, &
& TRIM("CFLUX_PROD100 "), &
& TRIM("annual release from all 100year wood product pools"), &
& TRIM("gC/m**2 nat/agri/yr "), iim,jjm, hist_hori_id, &
& 1,1,1, -99,32, ave(5), dt, hist_dt)
CALL histdef(hist_id_stom, 'RESOLUTION_X', 'E-W resolution', 'm', &
& iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
CALL histdef(hist_id_stom, 'RESOLUTION_Y', 'N-S resolution', 'm', &
& iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
CALL histdef(hist_id_stom, 'CONTFRAC', 'Continental fraction', '-', &
& iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
!---------------------------------
END SUBROUTINE stom_define_history
!
!
SUBROUTINE intersurf_initwatch(iim, jjm, igmax, date0, itau, dt, kindex, lon, lat, lev0)
!
IMPLICIT NONE
!
! This routine will allow to set up forcing files for ORCHIDEE. The idea is that
! during a coupled simulation one write's out all the forcing so that ORCHIDEE can
! can be re-run (to equilibrium or for sensitivity) afterwards.
!
! INPUT
INTEGER(i_std), INTENT(in) :: iim, jjm, igmax
REAL(r_std), INTENT(in) :: date0, dt
INTEGER(i_std), INTENT(in) :: itau, kindex(igmax)
REAL(r_std), INTENT(in) :: lon(iim,jjm), lat(iim,jjm), lev0
!
! OUTPUT
!
!
! LOCAL
!
INTEGER(i_std) :: iret, nlonid1, nlatid1, nlevid1, fid, nlandid1, tdimid1
INTEGER(i_std) :: dims(3)
INTEGER(i_std) :: nlonid, nlatid, nlevid, nlandid, varid, contid, resolxid, resolyid
INTEGER(i_std), DIMENSION(8) :: neighid
REAL(r_std) :: lon_min, lon_max, lat_min, lat_max, lev_min, lev_max
INTEGER(i_std) :: yy, mm, dd, hh, mn, i, j, ig, direction
REAL(r_std) :: ss
REAL(r_std),ALLOCATABLE :: tmpdata(:,:)
CHARACTER(LEN=3) :: cal(12)
CHARACTER(LEN=10) :: today, att, axx
CHARACTER(LEN=30) :: str30
CHARACTER(LEN=70) :: str70, var, unit, titre, assoc
CHARACTER(LEN=80) :: stamp, lon_name, lat_name, land_name,time_name
!
INTEGER,PARAMETER :: kind_r_watch=nf90_real8
!
cal(1) = 'JAN'
cal(2) = 'FEB'
cal(3) = 'MAR'
cal(4) = 'APR'
cal(5) = 'MAY'
cal(6) = 'JUN'
cal(7) = 'JUL'
cal(8) = 'AUG'
cal(9) = 'SEP'
cal(10) = 'OCT'
cal(11) = 'NOV'
cal(12) = 'DEC'
!
iret = NF90_CREATE (TRIM(watchout_file), NF90_CLOBBER, fid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not create file :',TRIM(watchout_file), &
& '(Problem with disk place or filename ?)')
ENDIF
!
! Dimensions
!
iret = NF90_DEF_DIM(fid, 'x', iim, nlonid1)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Dimension "x" can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_DEF_DIM(fid, 'y', jjm, nlatid1)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Dimension "y" can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_DEF_DIM(fid, 'z', 1, nlevid1)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Dimension "z" can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_DEF_DIM(fid, 'land', igmax, nlandid1)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Dimension "land" can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_DEF_DIM(fid, 'tstep', NF90_UNLIMITED, tdimid1)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Dimension "tstep" can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
! Coordinate VARIABLES
!
dims(1) = nlonid1
dims(2) = nlatid1
!
lon_name = 'nav_lon'
iret = NF90_DEF_VAR(fid, lon_name, kind_r_watch, dims(1:2), nlonid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//lon_name//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, nlonid, 'units', "degrees_east")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lon_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
lon_min = -180.
lon_max = 180.
!
iret = NF90_PUT_ATT(fid, nlonid, 'valid_min', lon_min)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lon_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, nlonid, 'valid_max', lon_max)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lon_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_ATT(fid, nlonid, 'long_name', "Longitude")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lon_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
lat_name = 'nav_lat'
iret = NF90_DEF_VAR(fid, lat_name, kind_r_watch, dims(1:2), nlatid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//lat_name//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, nlatid, 'units', "degrees_north")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lat_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
lat_max = 90.
lat_min = -90.
!
iret = NF90_PUT_ATT(fid, nlatid, 'valid_min', lat_min)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lat_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, nlatid, 'valid_max', lat_max)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lat_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, nlatid, 'long_name', "Latitude")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lat_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
lat_name = 'level'
iret = NF90_DEF_VAR(fid, lat_name, kind_r_watch,(/ nlevid1 /), nlevid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//lat_name//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, nlevid, 'units', "m")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lat_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
lev_max = lev0
lev_min = lev0
!
iret = NF90_PUT_ATT(fid, nlevid, 'valid_min', lev_min)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lat_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, nlevid, 'valid_max', lev_max)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lat_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, nlevid, 'long_name', "Vertical levels")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//lat_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
!
land_name = 'land'
iret = NF90_DEF_VAR(fid, land_name, NF90_INT, (/ nlandid1 /), nlandid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//land_name//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, nlandid, 'compress', "y x")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//land_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
! Time in real days !
!
time_name = 'time'
iret = NF90_DEF_VAR(fid, time_name, kind_r_watch, (/ tdimid1 /), time_id)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//time_name//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
! Compute an itau offset so that we can relate the itau of the model
! to the position in the file
!
watchoffset = itau
!
CALL ju2ymds(date0, yy, mm, dd, ss)
hh = INT(ss/3600.)
ss = ss - hh*3600.
mn = INT(ss/60.)
ss = ss - mn*60.
WRITE(str70,7000) yy, mm, dd, hh, mn, INT(ss)
!
iret = NF90_PUT_ATT(fid, time_id, 'units', TRIM(str70))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
CALL ioget_calendar(str30)
iret = NF90_PUT_ATT(fid, time_id, 'calendar', TRIM(str30))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_ATT(fid, time_id, 'title', 'Time')
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_ATT(fid, time_id, 'long_name', 'Time axis')
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
WRITE(str70,7001) yy, cal(mm), dd, hh, mn, INT(ss)
iret = NF90_PUT_ATT(fid, time_id, 'time_origin', TRIM(str70))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
! Time steps
!
time_name = 'timestp'
iret = NF90_DEF_VAR(fid, time_name, NF90_INT, (/ tdimid1 /), timestp_id)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//time_name//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
WRITE(str70,7002) yy, mm, dd, hh, mn, INT(ss)
iret = NF90_PUT_ATT(fid, timestp_id, 'units', TRIM(str70))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_ATT(fid, timestp_id, 'title', 'Time steps')
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_ATT(fid, timestp_id, 'tstep_sec', dt)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_ATT(fid, timestp_id, 'long_name', 'Time step axis')
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
WRITE(str70,7001) yy, cal(mm), dd, hh, mn, INT(ss)
iret = NF90_PUT_ATT(fid, timestp_id, 'time_origin', TRIM(str70))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//time_name//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
7000 FORMAT('seconds since ', I4.4,'-',I2.2,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2)
7001 FORMAT(' ', I4.4,'-',A3,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2)
7002 FORMAT('timesteps since ', I4.4,'-',I2.2,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2)
!
dims(1) = nlandid1
dims(2) = tdimid1
assoc = 'time (nav_lat nav_lon)'
axx='TYX'
!
var = 'SWdown'
unit = 'W/m^2'
titre = 'Surface incident shortwave radiation'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
soldownid = varid
!
var = 'SWnet'
unit = 'W/m^2'
titre = 'Net surface short-wave flux'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
solnetid = varid
!
var = 'Rainf'
unit = 'Kg/m^2s'
titre = 'Rainfall rate'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
rainfid = varid
!
var = 'Snowf'
unit = 'Kg/m^2s'
titre = 'Snowfall rate'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
snowfid = varid
!
var = 'LWdown'
unit = 'W/m^2'
titre = 'Surface incident longwave radiation'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
lwradid = varid
!
var = 'PSurf'
unit = 'Pa'
titre = 'Surface pressure'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
psolid = varid
!
!
! 3D Variables to be written
!
dims(1) = nlandid1
dims(2) = nlevid1
dims(3) = tdimid1
!
assoc = 'time level (nav_lat nav_lon)'
axx='TZYX'
!
lat_name = 'levels'
iret = NF90_DEF_VAR(fid, lat_name, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', "m")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', "Vertical levels")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
lev_min = 2.
lev_max = 100.
iret = NF90_PUT_ATT(fid, varid, 'valid_min', lev_min)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'valid_max', lev_max)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
zlevid = varid
!
!
var = 'Tair'
unit = 'K'
titre = 'Near surface air temperature'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
tairid = varid
!
var = 'Eair'
unit = 'J/m^2'
titre = 'Air potential energy'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
eairid = varid
!
var = 'Qair'
unit = 'Kg/Kg'
titre = 'Near surface specific humidity'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
qairid = varid
!
var = 'Wind_N'
unit = 'm/s'
titre = 'Near surface northward wind component'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
uid = varid
!
var = 'Wind_E'
unit = 'm/s'
titre = 'Near surface eastward wind component'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
vid = varid
!
var = 'petAcoef'
unit = '-'
titre = 'Coeficients A from the PBL resolution for T'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
petAcoefid = varid
!
var = 'peqAcoef'
unit = '-'
titre = 'Coeficients A from the PBL resolution for q'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
peqAcoefid = varid
!
var = 'petBcoef'
unit = '-'
titre = 'Coeficients B from the PBL resolution for T'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
petBcoefid = varid
!
var = 'peqBcoef'
unit = '-'
titre = 'Coeficients B from the PBL resolution for q'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
peqBcoefid = varid
!
var = 'cdrag'
unit = '-'
titre = 'Surface drag'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
cdragid = varid
!
!
! Time fixed variable
!
dims(1) = nlonid1
dims(2) = nlatid1
!
var = 'contfrac'
unit = '-'
titre = 'Fraction of continent'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
contid=varid
!
!
var = 'neighboursNN'
unit = '-'
titre = 'indices of North neighbours of each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
neighid(1)=varid
!
var = 'neighboursNE'
unit = '-'
titre = 'indices of North-East neighbours of each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
neighid(2)=varid
!
var = 'neighboursEE'
unit = '-'
titre = 'indices of East neighbours of each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
neighid(3)=varid
!
var = 'neighboursSE'
unit = '-'
titre = 'indices of South-East neighbours of each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
neighid(4)=varid
!
var = 'neighboursSS'
unit = '-'
titre = 'indices of South neighbours of each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
neighid(5)=varid
!
var = 'neighboursSW'
unit = '-'
titre = 'indices of South-West neighbours of each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
neighid(6)=varid
!
var = 'neighboursWW'
unit = '-'
titre = 'indices of West neighbours of each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
neighid(7)=varid
!
var = 'neighboursNW'
unit = '-'
titre = 'indices of North-West neighbours of each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
neighid(8)=varid
!
!
var = 'resolutionX'
unit = 'm'
titre = 'resolution in x at each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
resolxid=varid
!
var = 'resolutionY'
unit = 'm'
titre = 'resolution in y at each grid point'
assoc = 'nav_lat nav_lon'
axx='YX'
iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Variable '//var//' can not be defined for the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'axis', TRIM(axx) )
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add attribut to variable '//var//' for the file :', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
resolyid=varid
!
!
! Global attributes
!
CALL DATE_AND_TIME(today, att)
stamp = "Forcing generated by intersurf in a previous run "//today(1:LEN_TRIM(today))//" at "//att(1:LEN_TRIM(att))
iret = NF90_PUT_ATT(fid, NF90_GLOBAL, 'Conventions', "GDT 1.2")
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add global attribut to the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, NF90_GLOBAL, 'file_name', TRIM(watchout_file))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add global attribut to the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_ATT(fid, NF90_GLOBAL, 'production', TRIM(stamp))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not add global attribut to the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_ENDDEF(fid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not end definitions in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
! Write coordinates
!
iret = NF90_PUT_VAR(fid, nlonid, lon)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not put variable nav_lon in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_VAR(fid, nlatid, lat)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not put variable nav_lat in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_VAR(fid, nlevid, lev0)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not put variable level in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_VAR(fid, nlandid, kindex)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not put variable land in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
IF ( .NOT. ALLOCATED(tmpdata)) THEN
ALLOCATE(tmpdata(iim,jjm))
ENDIF
!
tmpdata(:,:) = undef_sechiba
DO ig=1,igmax
j = ((kindex(ig)-1)/iim) + 1
i = (kindex(ig) - (j-1)*iim)
tmpdata(i,j) = contfrac_g(ig)
ENDDO
iret = NF90_PUT_VAR(fid, contid, tmpdata)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not put variable contfrac in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
DO direction=1,8
tmpdata(:,:) = undef_sechiba
DO ig=1,igmax
j = ((kindex(ig)-1)/iim) + 1
i = (kindex(ig) - (j-1)*iim)
tmpdata(i,j) = REAL( neighbours_g(ig,direction) )
ENDDO
iret = NF90_PUT_VAR(fid, neighid(direction), tmpdata)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not put variable neighbours in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
ENDDO
!
tmpdata(:,:) = undef_sechiba
DO ig=1,igmax
j = ((kindex(ig)-1)/iim) + 1
i = (kindex(ig) - (j-1)*iim)
tmpdata(i,j) = resolution_g(ig,1)
ENDDO
iret = NF90_PUT_VAR(fid, resolxid, tmpdata)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not put variable resolutionx in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
tmpdata(:,:) = undef_sechiba
DO ig=1,igmax
j = ((kindex(ig)-1)/iim) + 1
i = (kindex(ig) - (j-1)*iim)
tmpdata(i,j) = resolution_g(ig,2)
ENDDO
iret = NF90_PUT_VAR(fid, resolyid, tmpdata)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_initwatch', &
& 'Could not put variable resolutiony in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
DEALLOCATE(tmpdata)
!
watchfid = fid
!
END SUBROUTINE intersurf_initwatch
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
SUBROUTINE intersurf_wrtwatch_p(igmax, itau, dt, levels, &
& soldown, rain, snow, lwdown, psurf, temp, eair, qair, u, v, &
& solnet, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag )
!
!
IMPLICIT NONE
!
! INPUT
!
INTEGER(i_std) :: igmax, itau
REAL(r_std) :: levels(igmax)
REAL(r_std), DIMENSION(igmax), INTENT(in) :: soldown, rain, snow, lwdown, psurf, &
& solnet, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag
REAL(r_std) :: temp(igmax), eair(igmax), qair(igmax), u(igmax), v(igmax)
REAL(r_std) :: dt
!
! LOCAL
!
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: levels_g
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: soldown_g, rain_g, snow_g, lwdown_g, psurf_g, &
& solnet_g, petAcoef_g, peqAcoef_g, petBcoef_g, peqBcoef_g, cdrag_g, &
& temp_g, eair_g, qair_g, u_g, v_g
!
LOGICAL, SAVE :: is_first_time=.TRUE.
INTEGER(i_std) :: ier
IF (is_first_time .AND. is_root_prc) THEN
ALLOCATE(levels_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in levels_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(soldown_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in soldown_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(rain_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in rain_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(snow_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in snow_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(lwdown_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in lwdown_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(psurf_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in psurf_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(solnet_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in solnet_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(petAcoef_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in petAcoef_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(peqAcoef_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in peqAcoef_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(petBcoef_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in petBcoef_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(peqBcoef_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in peqBcoef_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(cdrag_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in cdrag_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(temp_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in temp_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(eair_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in eair_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(qair_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in qair_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(u_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in u_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ALLOCATE(v_g(nbp_glo),stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) ' error in v_g allocation. We stop. We need iim words = ',nbp_glo
STOP 'intersurf_wrtwatch_p'
ENDIF
ENDIF
is_first_time=.FALSE.
CALL gather(levels,levels_g)
CALL gather(soldown,soldown_g)
CALL gather(rain,rain_g)
CALL gather(snow,snow_g)
CALL gather(lwdown,lwdown_g)
CALL gather(psurf,psurf_g)
CALL gather(solnet,solnet_g)
CALL gather(petAcoef,petAcoef_g)
CALL gather(peqAcoef,peqAcoef_g)
CALL gather(petBcoef,petBcoef_g)
CALL gather(peqBcoef,peqBcoef_g)
CALL gather(cdrag,cdrag_g)
CALL gather(temp,temp_g)
CALL gather(eair,eair_g)
CALL gather(qair,qair_g)
CALL gather(u,u_g)
CALL gather(v,v_g)
IF (is_root_prc) THEN
CALL intersurf_wrtwatch(nbp_glo, itau, dt, levels_g, &
& soldown_g, rain_g, snow_g, lwdown_g, psurf_g, temp_g, eair_g, qair_g, u_g, v_g, &
& solnet_g, petAcoef_g, peqAcoef_g, petBcoef_g, peqBcoef_g, cdrag_g )
ENDIF
END SUBROUTINE intersurf_wrtwatch_p
SUBROUTINE intersurf_wrtwatch(igmax, itau, dt, levels, &
& soldown, rain, snow, lwdown, psurf, temp, eair, qair, u, v, &
& solnet, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag )
!
!
IMPLICIT NONE
!
! This subroutine will write to the file the current fields which force the
! land-surface scheme. It will be in exactly the same format as the other forcing
! files, i.e. ALMA convention !
!
!
! INPUT
!
INTEGER(i_std) :: igmax, itau
REAL(r_std) :: levels(igmax)
REAL(r_std), DIMENSION(igmax), INTENT(in) :: soldown, rain, snow, lwdown, psurf, &
& solnet, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag
REAL(r_std) :: temp(igmax), eair(igmax), qair(igmax), u(igmax), v(igmax)
REAL(r_std) :: dt
!
! LOCAL
!
INTEGER(i_std) :: iret
INTEGER(i_std) :: corner(3), edges(3)
REAL(r_std) :: timestp
LOGICAL :: check=.FALSE.
REAL(r_std),ALLOCATABLE :: tmpdata(:)
INTEGER(i_std) :: corner_tstp
!
! For dt_watch non equal to dt :
!
corner_tstp = NINT((itau - watchoffset)/dt_split_watch)
!
corner(1) = corner_tstp
edges(1) = 1
IF ( check ) THEN
WRITE(numout,*) 'intersurf_wrtwatch corners, edges : ', corner(1), edges(1)
ENDIF
!
timestp = itau/dt_split_watch
iret = NF90_PUT_VAR(watchfid, timestp_id, (/ timestp /), &
& start=(/ corner(1) /), count=(/ edges(1) /))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable timestp in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
timestp=timestp*dt_watch
iret = NF90_PUT_VAR(watchfid, time_id, (/ timestp /), &
& start=(/ corner(1) /), count=(/ edges(1) /))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable time in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
corner(1) = 1
edges(1) = igmax
corner(2) = corner_tstp
edges(2) = 1
!
IF ( .NOT. ALLOCATED(tmpdata)) THEN
ALLOCATE(tmpdata(igmax))
ENDIF
!
! 2D
IF ( check ) THEN
WRITE(numout,*) '--',itau, ' SOLDOWN : ', MINVAL(soldown), MAXVAL(soldown)
ENDIF
iret = NF90_PUT_VAR(watchfid, soldownid, soldown, start=corner(1:2), count=edges(1:2))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable SWdown in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_VAR(watchfid, solnetid, solnet, start=corner(1:2), count=edges(1:2))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable SWnet in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
! Bring back to kg/m^2/s
!
tmpdata = rain/dt
IF ( check ) THEN
WRITE(numout,*) '--',itau, ' RAIN : ', MINVAL(tmpdata), MAXVAL(tmpdata)
ENDIF
iret = NF90_PUT_VAR(watchfid, rainfid, tmpdata, start=corner(1:2), count=edges(1:2))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable Rainf in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
tmpdata = snow/dt
iret = NF90_PUT_VAR(watchfid, snowfid, tmpdata, start=corner(1:2), count=edges(1:2))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable Snowf in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_VAR(watchfid, lwradid, lwdown, start=corner(1:2), count=edges(1:2))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable LWdown in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
! Bring back to Pa
!
tmpdata = psurf*100.
iret = NF90_PUT_VAR(watchfid, psolid, tmpdata, start=corner(1:2), count=edges(1:2))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable PSurf in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
! 3D
corner(2) = 1
edges(2) = 1
corner(3) = corner_tstp
edges(3) = 1
!
iret = NF90_PUT_VAR(watchfid, zlevid, levels, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable levels in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_VAR(watchfid, tairid, temp, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable Tair in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_VAR(watchfid, eairid, eair, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable Eair in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_VAR(watchfid, qairid, qair, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable Qair in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_VAR(watchfid, uid, u, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable Wind_N in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_VAR(watchfid, vid, v, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable Wind_E in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
iret = NF90_PUT_VAR(watchfid, petAcoefid, petAcoef, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable petAcoef in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_VAR(watchfid, peqAcoefid, peqAcoef, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable peqAcoef in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_VAR(watchfid, petBcoefid, petBcoef, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable petBcoef in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_VAR(watchfid, peqBcoefid, peqBcoef, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable peqBcoef in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
iret = NF90_PUT_VAR(watchfid, cdragid, cdrag, start=corner(1:3), count=edges(1:3))
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_wrtwatch', &
& 'Could not put variable cdrag in the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
DEALLOCATE(tmpdata)
!
END SUBROUTINE intersurf_wrtwatch
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
SUBROUTINE intersurf_clowatch()
!
! Close the watch files
!
IMPLICIT NONE
!
! LOCAL
!
INTEGER(i_std) :: iret
LOGICAL :: check = .FALSE.
!
!
IF ( check ) THEN
WRITE(numout,*) 'intersurf_clowatch : closing file : ', watchfid
ENDIF
iret = NF90_CLOSE(watchfid)
IF (iret /= NF90_NOERR) THEN
CALL ipslerr (3,'intersurf_clowatch','Could not close the file : ', &
& TRIM(watchout_file),'(Solution ?)')
ENDIF
!
END SUBROUTINE intersurf_clowatch
!
END MODULE intersurf
ORCHIDEE/src_sechiba/routing.f90 0000754 0103600 0005670 00000727715 11164403473 016224 0 ustar acamlmd lmdjus !!
!!
!! This module routes the water over the continents into the oceans.
!!
!! Histoire Salee
!!---------------
!! La douce riviere
!! Sortant de son lit
!! S'est jetee ma chere
!! dans les bras mais oui
!! du beau fleuve
!!
!! L'eau coule sous les ponts
!! Et puis les flots s'emeuvent
!! - N'etes vous pas au courant ?
!! Il parait que la riviere
!! Va devenir mer
!! Roland Bacri
!!
!! @author Jan Polcher
!! @Version : $Revision: 1.39 $, $Date: 2007/06/12 20:23:23 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/routing.f90,v 1.39 2007/06/12 20:23:23 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE routing
!
!
! routines called : restput, restget
!
USE ioipsl
!
USE constantes
USE constantes_veg
USE sechiba_io
USE grid
USE parallel
!
IMPLICIT NONE
!
! public routines :
!
PRIVATE
PUBLIC :: routing_main, routing_clear
!
! variables used inside hydrol module : declaration and initialisation
!
LOGICAL, SAVE :: l_first_routing=.TRUE. !! Initialisation has to be done one time
! LOGICAL, SAVE :: check_waterbal=.FALSE. !! The check the water balance
!
! The maximum number of basins we wish to have per grid-box (truncation of the model)
INTEGER(i_std), PARAMETER :: nbasmax=2
! The maximum number of basins we can handle at any time during the generation of the maps.
INTEGER(i_std) :: nbvmax
!
! The time constants are in days.
!
REAL(r_std), PARAMETER :: slow_tcst_cwrr = 3.0
REAL(r_std), PARAMETER :: fast_tcst_cwrr = 3.0
REAL(r_std), PARAMETER :: stream_tcst_cwrr = 0.24
REAL(r_std), PARAMETER :: flood_tcst_cwrr = 4.0
REAL(r_std), PARAMETER :: swamp_cst_cwrr = 0.2
!
REAL(r_std), PARAMETER :: slow_tcst_chois = 25.0
REAL(r_std), PARAMETER :: fast_tcst_chois = 3.0
REAL(r_std), PARAMETER :: stream_tcst_chois = 0.24
REAL(r_std), PARAMETER :: flood_tcst_chois = 4.0
REAL(r_std), PARAMETER :: swamp_cst_chois = 0.2
!
REAL(r_std), SAVE :: fast_tcst, slow_tcst, stream_tcst, flood_tcst, swamp_cst
!
! Relation between volume and fraction of floodplains
!
REAL(r_std), PARAMETER :: beta = 2.0
REAL(r_std), PARAMETER :: betap = 0.5
REAL(r_std), PARAMETER :: floodcri = 2000.0
!
! Relation between maximum surface of ponds and basin surface, and drainage (mm/j) to the slow_res
!
REAL(r_std), PARAMETER :: pond_bas = 50.0
REAL(r_std), PARAMETER :: pondcri = 2000.0
! REAL(r_std), PARAMETER :: pond_drain = 0.0
!
! Maximum evaporation rate from lakes 7.5 kg/m^2/d transformed into kg/m^2/sec
!
REAL(r_std), PARAMETER :: maxevap_lake = 7.5/86400.
!
! Parameter for the Kassel irrigation parametrization linked to the crops
!
REAL(r_std), PARAMETER :: crop_coef = 0.7
!
REAL(r_std),SAVE :: dt_routing
!
! Logicals to control model configuration
!
LOGICAL, SAVE :: doirrigation = .FALSE.
LOGICAL, SAVE :: dofloodplains = .FALSE.
LOGICAL, SAVE :: dofloodinfilt = .FALSE.
LOGICAL, SAVE :: doswamps = .FALSE.
LOGICAL, SAVE :: doponds = .FALSE.
!
!
! The variables describing the basins and their routing, need to be in the restart file.
!
INTEGER(i_std), SAVE :: num_largest
REAL(r_std), SAVE :: time_counter
REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_loc
REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_loc
INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_loc
INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_loc
INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_loc
INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_loc !! Variable to diagnose the hydrographs
!
! parallelism
REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: routing_area_glo
REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: topo_resid_glo
INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_togrid_glo
INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: route_tobasin_glo
INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: global_basinid_glo
INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:) :: hydrodiag_glo !! Variable to diagnose the hydrographs
REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: routing_area
REAL(r_std), SAVE, POINTER, DIMENSION(:,:) :: topo_resid
INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_togrid
INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: route_tobasin
INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: global_basinid
INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:) :: hydrodiag
! Map of irrigated areas and floodplains
!
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrigated, floodplains, swamp
!
! The reservoirs, also to be put into the restart file.
!
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: fast_reservoir, slow_reservoir, stream_reservoir, flood_reservoir
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lake_reservoir, pond_reservoir
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: flood_frac_bas
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: pond_frac, flood_height
!
! The accumulated fluxes.
!
! REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodout_mean, runoff_mean, drainage_mean, evapot_mean
!MG
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodout_mean, runoff_mean, drainage_mean, evapot_mean, etm_mean
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: precip_mean, humrel_mean, totnobio_mean, vegtot_mean, k_litt_mean
!
! The averaged outflow fluxes.
!
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: lakeinflow_mean
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: returnflow_mean, reinfiltration_mean, irrigation_mean
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: riverflow_mean, coastalflow_mean
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: floodtemp
INTEGER(i_std), SAVE :: floodtemp_lev
!
! Diagnostic variables ... well sort of !
!
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: irrig_netereq
!
! Hydrographs at the outflow of the grid box for major basins
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: hydrographs
! Diagnostics for the various reservoirs we use (Kg/m^2)
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: fast_diag, slow_diag, stream_diag
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: flood_diag, pond_diag, lake_diag, delsurfstor
!
CONTAINS
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_main(kjit, nbpt, dtradia, ldrestart_read, ldrestart_write, index, &
& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget, floodout, runoff, &
! & drainage, evapot, precip_rain, humrel, k_litt, flood_frac, flood_res, &
!MG
& drainage, evapot, etm, precip_rain, humrel, k_litt, flood_frac, flood_res, &
& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
!
IMPLICIT NONE
!
! This module will route the runoff and drainage produced by the hydrol module. These two
! fluxes are provided in kg/m^2dt. The result of the routing are 3 fluxes :
! - riverflow : The water which flows out from the major rivers. The flux will be located
! on the continental grid but this should be a coastal point.
! - coastalflow : This is the water which flows in a disperse way into the ocean. Essentially these
! are the outflows from all the small rivers.
! - returnflow : This is the water which flows back into the bottom of the soil. Typically wetlands
! or swamp created aside a large river, or river ending in a continent
! - reinfiltration : This is the water which flows into a land-point. Typically ponds or floodplains
! reinfiltrating
! - irrigation : This is water taken from the river reservoir and beeing put into the upper
! layers of the soil.
! The two first fluxes are in kg/dt and the last one is on kg/m^2dt.
!
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: nbpt !! Domain size
INTEGER(i_std),INTENT(in) :: rest_id,hist_id !! _Restart_ file and _history_ file identifier
INTEGER(i_std),INTENT(in) :: hist2_id !! _history_ file 2 identifier
REAL(r_std), INTENT(in) :: dtradia !! Time step in seconds
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for _restart_ file to write
INTEGER(i_std), INTENT(in) :: index(nbpt) ! Indeces of the points on the map
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box
REAL(r_std), INTENT(in) :: totfrac_nobio(nbpt) ! Total fraction of continental ice+lakes+...
REAL(r_std), INTENT(in) :: veget(nbpt,nvm) ! Vegetation fraction. We want to have the
! part of the grid which can have some vegetation.
REAL(r_std), INTENT(in) :: floodout(nbpt) ! grid-point flow out of floodplains
REAL(r_std), INTENT(in) :: runoff(nbpt) ! grid-point runoff
REAL(r_std), INTENT(in) :: drainage(nbpt) ! grid-point drainage
REAL(r_std), INTENT(in) :: evapot(nbpt) ! Potential evaporation
!MG
REAL(r_std), INTENT(in) :: etm(nbpt,nvm) ! Maximum evapotranspiration
REAL(r_std), INTENT(in) :: precip_rain(nbpt) ! Rainfall needed for the irrigation formula
REAL(r_std), INTENT(in) :: k_litt(nbpt) ! litter cond.
REAL(r_std), INTENT(in) :: humrel(nbpt,nvm) ! Soil moisture stress
REAL(r_std), INTENT(in) :: stempdiag(nbpt,nbdl)! Temperature profile in soil
REAL(r_std), INTENT(in) :: reinf_slope(nbpt) ! Slope coef for reinfiltration
!
REAL(r_std), INTENT(out) :: returnflow(nbpt) ! The water flow which returns to the grid box (kg/m^2 per dt)
REAL(r_std), INTENT(out) :: reinfiltration(nbpt)! The water flow which returns to the grid box (kg/m^2 per dt)
REAL(r_std), INTENT(out) :: irrigation(nbpt) ! Irrigation flux (kg/m^2 per dt)
REAL(r_std), INTENT(out) :: riverflow(nbpt) ! Outflow of the major rivers
REAL(r_std), INTENT(out) :: coastalflow(nbpt) ! Outflow on coastal points by small basins
REAL(r_std), INTENT(out) :: flood_frac(nbpt) ! Flooded fraction of grid box
REAL(r_std), INTENT(out) :: flood_res(nbpt) ! Flooded quantity (estimation)
!
! LOCAL
!
CHARACTER(LEN=30) :: var_name
REAL(r_std), DIMENSION(1) :: tmp_day
REAL(r_std) :: totarea
REAL(r_std), DIMENSION(nbpt) :: return_lakes
INTEGER(i_std) :: ig, jv, ib
LOGICAL, SAVE :: init_irrig=.FALSE., init_flood=.FALSE., init_swamp=.FALSE.
!
! do initialisation
!
IF (l_first_routing) THEN
!
nbvmax = 220
! Here we will allocate the memory and get the fixed fields from the restart file.
! If the info is not found then we will compute the routing map.
!
CALL routing_init (kjit, nbpt, index, dtradia, returnflow, reinfiltration, irrigation, &
& riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
routing_area => routing_area_loc
topo_resid => topo_resid_loc
route_togrid => route_togrid_loc
route_tobasin => route_tobasin_loc
global_basinid => global_basinid_loc
hydrodiag => hydrodiag_loc
!
! This routine computes the routing map if needed.
!
IF ( COUNT(route_togrid_glo .GE. undef_int) .GT. 0 ) THEN
CALL routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
ENDIF
!
! Do we have what we need if we want to do irrigation
!
IF ( doirrigation .OR. dofloodplains .OR. doswamps) THEN
IF ( doirrigation ) THEN
IF (COUNT(irrigated .GE. undef_sechiba-1) > 0) THEN
init_irrig = .TRUE.
ENDIF
ENDIF
IF ( dofloodplains ) THEN
IF (COUNT(floodplains .GE. undef_sechiba-1) > 0) THEN
init_flood = .TRUE.
ENDIF
ENDIF
IF ( doswamps ) THEN
IF (COUNT(swamp .GE. undef_sechiba-1) > 0) THEN
init_swamp = .TRUE.
ENDIF
ENDIF
IF ( init_irrig .OR. init_flood .OR. init_swamp ) THEN
CALL routing_irrigmap(nbpt, index, lalo, neighbours, resolution, &
contfrac, init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
ENDIF
ENDIF
!
! This routine gives a diagnostic of the basins used.
!
CALL routing_diagnostic_p(nbpt, index, resolution, contfrac, hist_id, hist2_id)
!
l_first_routing = .FALSE.
!
RETURN
!
ENDIF
!
! Accumulate the incoming water fluxes
!
floodout_mean(:) = floodout_mean(:) + floodout(:)
runoff_mean(:) = runoff_mean(:) + runoff(:)
drainage_mean(:) = drainage_mean(:) + drainage(:)
evapot_mean(:) = evapot_mean(:) + evapot(:)
floodtemp(:) = stempdiag(:,floodtemp_lev)
precip_mean(:) = precip_mean(:) + precip_rain(:)
!MG
DO ig = 1, nbpt
IF (MAXVAL(veget(ig,(nvm-3):nvm)) .GT. min_sechiba) THEN
DO jv = nvm-3, nvm
etm_mean(ig) = etm_mean(ig) + etm(ig,jv) * veget(ig,jv)/ SUM(veget(ig,(nvm-3):nvm))
ENDDO
ELSE
IF (MAXVAL(veget(ig,2:nvm)) .GT. min_sechiba) THEN
DO jv = 2, nvm
etm_mean(ig) = etm_mean(ig) + etm(ig,jv) * veget(ig,jv)/ SUM(veget(ig,2:nvm))
ENDDO
ENDIF
ENDIF
ENDDO
!
! Averaged variables (i.e. *dtradia/dt_routing)
!
totnobio_mean(:) = totnobio_mean(:) + totfrac_nobio(:)*dtradia/dt_routing
k_litt_mean(:) = k_litt_mean(:) + k_litt(:)*dtradia/dt_routing
!
! Only potentially vegetated surfaces are taken into account. At the start of
! the growing seasons we will more weight to these areas.
!
DO jv=2,nvm
DO ig=1,nbpt
humrel_mean(ig) = humrel_mean(ig) + humrel(ig,jv)*veget(ig,jv)*dtradia/dt_routing
vegtot_mean(ig) = vegtot_mean(ig) + veget(ig,jv)*dtradia/dt_routing
ENDDO
ENDDO
!
time_counter = time_counter + dtradia
!
! If the time has come we do the routing.
!
IF ( NINT(time_counter) .GE. NINT(dt_routing) ) THEN
!
! Check the water balance if needed
!
IF ( check_waterbal ) THEN
CALL routing_waterbal(nbpt, .TRUE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
& reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
ENDIF
!
! Make sure we do not flood north of 49N
!
DO ig=1,nbpt
IF ( lalo(ig,1) > 49.0 ) THEN
floodtemp(ig) = tp_00 -1.
ENDIF
ENDDO
!
CALL routing_flow(nbpt, dt_routing, floodout_mean, runoff_mean, drainage_mean, &
! & vegtot_mean, totnobio_mean, evapot_mean, precip_mean, humrel_mean, k_litt_mean, floodtemp, reinf_slope, &
!MG
& vegtot_mean, totnobio_mean, evapot_mean, etm_mean, precip_mean, humrel_mean, k_litt_mean, floodtemp, reinf_slope, &
& lakeinflow_mean, returnflow_mean, reinfiltration_mean, irrigation_mean, riverflow_mean, &
& coastalflow_mean, hydrographs, flood_frac, flood_res)
!
CALL routing_lake(nbpt, dt_routing, lakeinflow_mean, humrel_mean, return_lakes)
!
returnflow_mean(:) = returnflow_mean(:) + return_lakes(:)
!
! Close the water balance if asked for
!
IF ( check_waterbal ) THEN
CALL routing_waterbal(nbpt, .FALSE., floodout_mean, runoff_mean, drainage_mean, returnflow_mean, &
& reinfiltration_mean, irrigation_mean, riverflow_mean, coastalflow_mean)
ENDIF
!
time_counter = zero
!
floodout_mean(:) = zero
runoff_mean(:) = zero
drainage_mean(:) = zero
evapot_mean(:) = zero
!MG
etm_mean(:) = zero
precip_mean(:) = zero
!
humrel_mean(:) = zero
totnobio_mean(:) = zero
k_litt_mean(:) = zero
vegtot_mean(:) = zero
!
! Change the units of the routing fluxes from kg/dt_routing into kg/dtradia
! and from m^3/dt_routing into m^3/dtradia
!
returnflow_mean(:) = returnflow_mean(:)/dt_routing*dtradia
reinfiltration_mean(:) = reinfiltration_mean(:)/dt_routing*dtradia
irrigation_mean(:) = irrigation_mean(:)/dt_routing*dtradia
irrig_netereq(:) = irrig_netereq(:)/dt_routing*dtradia
!
!
riverflow_mean(:) = riverflow_mean(:)/dt_routing*dtradia
coastalflow_mean(:) = coastalflow_mean(:)/dt_routing*dtradia
hydrographs(:) = hydrographs(:)/dt_routing*dtradia
!
! Convert from kg/dtradia to m^3/dtradia
!
hydrographs(:) = hydrographs(:)/1000.
!
ENDIF
!
! Return the fraction of routed water for this time step.
!
returnflow(:) = returnflow_mean(:)
reinfiltration(:) = reinfiltration_mean(:)
irrigation(:) = irrigation_mean(:)
riverflow(:) = riverflow_mean(:)
coastalflow(:) = coastalflow_mean(:)
!
! Write restart
!
IF (ldrestart_write) THEN
!
var_name ="routingcounter"
tmp_day(1) = time_counter
IF (is_root_prc) CALL restput (rest_id, var_name, 1, 1, 1, kjit, tmp_day)
!
var_name = 'routingarea'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, routing_area, 'scatter', nbp_glo, index_g)
var_name = 'routetogrid'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, REAL(route_togrid,r_std), 'scatter', &
& nbp_glo, index_g)
var_name = 'routetobasin'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, REAL(route_tobasin,r_std), 'scatter', &
& nbp_glo, index_g)
var_name = 'basinid'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, REAL(global_basinid,r_std), 'scatter', &
& nbp_glo, index_g)
var_name = 'topoindex'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, topo_resid, 'scatter', nbp_glo, index_g)
var_name = 'fastres'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, fast_reservoir, 'scatter', nbp_glo, index_g)
var_name = 'slowres'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, slow_reservoir, 'scatter', nbp_glo, index_g)
var_name = 'streamres'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, stream_reservoir, 'scatter',nbp_glo,index_g)
var_name = 'floodres'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, flood_reservoir, 'scatter', nbp_glo, index_g)
var_name = 'flood_frac_bas'
CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, flood_frac_bas, 'scatter', nbp_glo, index_g)
var_name = 'pond_frac'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, pond_frac, 'scatter', nbp_glo, index_g)
var_name = 'flood_frac'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, flood_frac, 'scatter', nbp_glo, index_g)
var_name = 'flood_res'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, flood_res, 'scatter', nbp_glo, index_g)
!
var_name = 'lakeres'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, lake_reservoir, 'scatter', nbp_glo, index_g)
var_name = 'pondres'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, pond_reservoir, 'scatter', nbp_glo, index_g)
!
var_name = 'lakeinflow'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, lakeinflow_mean, 'scatter', nbp_glo, index_g)
var_name = 'returnflow'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, returnflow_mean, 'scatter', nbp_glo, index_g)
var_name = 'reinfiltration'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, reinfiltration_mean, 'scatter', nbp_glo, index_g)
var_name = 'riverflow'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, riverflow_mean, 'scatter', nbp_glo, index_g)
var_name = 'coastalflow'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, coastalflow_mean, 'scatter', nbp_glo, index_g)
var_name = 'hydrographs'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, hydrographs, 'scatter', nbp_glo, index_g)
!
! Keep track of the accumulated variables
!
var_name = 'floodout_route'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, floodout_mean, 'scatter', nbp_glo, index_g)
var_name = 'runoff_route'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, runoff_mean, 'scatter', nbp_glo, index_g)
var_name = 'drainage_route'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, drainage_mean, 'scatter', nbp_glo, index_g)
var_name = 'evapot_route'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, evapot_mean, 'scatter', nbp_glo, index_g)
!MG
var_name = 'etm_route'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, etm_mean, 'scatter', nbp_glo, index_g)
var_name = 'precip_route'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, precip_mean, 'scatter', nbp_glo, index_g)
var_name = 'humrel_route'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, humrel_mean, 'scatter', nbp_glo, index_g)
var_name = 'totnobio_route'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, totnobio_mean, 'scatter', nbp_glo, index_g)
var_name = 'vegtot_route'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, vegtot_mean, 'scatter', nbp_glo, index_g)
!
IF ( doirrigation ) THEN
var_name = 'irrigated'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, irrigated, 'scatter', nbp_glo, index_g)
var_name = 'irrigation'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, irrigation_mean, 'scatter', nbp_glo, index_g)
ENDIF
!
IF ( dofloodplains ) THEN
var_name = 'floodplains'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, floodplains, 'scatter', nbp_glo, index_g)
ENDIF
IF ( doswamps ) THEN
var_name = 'swamp'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, swamp, 'scatter', nbp_glo, index_g)
ENDIF
!
RETURN
!
ENDIF
!
! Write diagnostics
!
IF ( .NOT. almaoutput ) THEN
!
CALL histwrite(hist_id, 'riversret', kjit, reinfiltration, nbpt, index)
CALL histwrite(hist_id, 'hydrographs', kjit, hydrographs, nbpt, index)
!
CALL histwrite(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
CALL histwrite(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
CALL histwrite(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
CALL histwrite(hist_id, 'floodr', kjit, flood_diag, nbpt, index)
CALL histwrite(hist_id, 'floodh', kjit, flood_height, nbpt, index)
CALL histwrite(hist_id, 'pondr', kjit, pond_diag, nbpt, index)
CALL histwrite(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
!
CALL histwrite(hist_id, 'irrigation', kjit, irrigation, nbpt, index)
CALL histwrite(hist_id, 'returnflow', kjit, returnflow, nbpt, index)
!
CALL histwrite(hist_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
!
ELSE
!
delsurfstor=delsurfstor + flood_diag + pond_diag + lake_diag
CALL histwrite(hist_id, 'DelSurfStor', kjit, delsurfstor, nbpt, index)
CALL histwrite(hist_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
CALL histwrite(hist_id, 'Dis', kjit, hydrographs, nbpt, index)
CALL histwrite(hist_id, 'Qrec', kjit, returnflow+reinfiltration, nbpt, index)
!
ENDIF
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput ) THEN
!
CALL histwrite(hist2_id, 'riversret', kjit, returnflow, nbpt, index)
CALL histwrite(hist2_id, 'hydrographs', kjit, hydrographs, nbpt, index)
!
CALL histwrite(hist2_id, 'fastr', kjit, fast_diag, nbpt, index)
CALL histwrite(hist2_id, 'slowr', kjit, slow_diag, nbpt, index)
CALL histwrite(hist2_id, 'floodr', kjit, flood_diag, nbpt, index)
CALL histwrite(hist2_id, 'floodh', kjit, flood_height, nbpt, index)
CALL histwrite(hist2_id, 'pondr', kjit, pond_diag, nbpt, index)
CALL histwrite(hist2_id, 'streamr', kjit, stream_diag, nbpt, index)
CALL histwrite(hist2_id, 'lakevol', kjit, lake_diag, nbpt, index)
!
CALL histwrite(hist2_id, 'irrigation', kjit, irrigation, nbpt, index)
CALL histwrite(hist2_id, 'returnflow', kjit, returnflow, nbpt, index)
!
CALL histwrite(hist2_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
!
ELSE
!
delsurfstor=delsurfstor + flood_diag + pond_diag + lake_diag
CALL histwrite(hist2_id, 'DelSurfStor', kjit, delsurfstor, nbpt, index)
CALL histwrite(hist2_id, 'SurfStor', kjit, flood_diag+pond_diag+lake_diag, nbpt, index)
CALL histwrite(hist2_id, 'Dis', kjit, hydrographs, nbpt, index)
CALL histwrite(hist2_id, 'Qrec', kjit, returnflow+reinfiltration, nbpt, index)
!
ENDIF
ENDIF
!
!
END SUBROUTINE routing_main
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_init(kjit, nbpt, index, dtradia, returnflow, reinfiltration, irrigation, &
& riverflow, coastalflow, flood_frac, flood_res, stempdiag, rest_id)
!
IMPLICIT NONE
!
! interface description
! input
!
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: nbpt !! Domain size
INTEGER(i_std), DIMENSION (nbpt), INTENT(in) :: index !! Indeces of the points on the map
REAL(r_std), INTENT(in) :: dtradia !! timestep
REAL(r_std), DIMENSION (nbpt),INTENT(out) :: returnflow !! The water flow which returns to the grid box (kg/m^2 per dt)
REAL(r_std), DIMENSION (nbpt),INTENT(out) :: reinfiltration !! The water flow which returns to the grid box (kg/m^2 per dt)
REAL(r_std), DIMENSION (nbpt),INTENT(out) :: irrigation !! Irrigation flow (kg/m^2 per dt)
REAL(r_std), DIMENSION (nbpt),INTENT(out) :: riverflow !! Outflow of the major rivers
REAL(r_std), DIMENSION (nbpt),INTENT(out) :: coastalflow !! Outflow on coastal points by small basins
REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_frac !! Flooded fraction of the grid box
REAL(r_std), DIMENSION (nbpt),INTENT(out) :: flood_res !! Flooded quantity (estimation)
REAL(r_std), DIMENSION(nbpt,nbdl),INTENT(in) :: stempdiag !! Temperature profile in soil
INTEGER(i_std), INTENT(in) :: rest_id !! Restart file identifier
!
! local declaration
!
CHARACTER(LEN=80) :: var_name !! To store variables names for I/O
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: tmp_real_g !! A temporary real array for the integers
REAL(r_std), DIMENSION(1) :: tmp_day
REAL(r_std) :: ratio, totarea
INTEGER(i_std) :: ier, ig, ib, ipn(1)
LOGICAL :: hydrol_cwrr
!
! These variables will require the configuration infrastructure
!
!Config Key = ROUTING_TIMESTEP
!Config If = RIVER_ROUTING
!Config Desc = Time step of the routing scheme
!Config Def = 86400
!Config Help = This values gives the time step in seconds of the routing scheme.
!Config It should be multiple of the main time step of ORCHIDEE. One day
!Config is a good value.
!
dt_routing = one_day
CALL getin_p('ROUTING_TIMESTEP', dt_routing)
!
!Config Key = ROUTING_RIVERS
!Config If = RIVER_ROUTING
!Config Desc = Number of rivers
!Config Def = 50
!Config Help = This parameter chooses the number of largest river basins
!Config which should be treated as independently as rivers and not
!Config flow into the oceans as diffusion coastal flow.
num_largest = 50
CALL getin_p('ROUTING_RIVERS', num_largest)
!
!Config Key = HYDROL_CWRR
!Config Desc = Do we use the new CWRR hydrology
!Config Def = FALSE
!
hydrol_cwrr = .FALSE.
CALL getin_p('HYDROL_CWRR', hydrol_cwrr)
!
!Config Key = DO_IRRIGATION
!Config Desc = Should we compute an irrigation flux
!Config Def = FALSE
!Config Help = This parameters allows the user to ask the model
!Config to compute an irigation flux. This performed for the
!Config on very simple hypothesis. The idea is to have a good
!Config map of irrigated areas and a simple function which estimates
!Config the need to irrigate.
!
doirrigation = .FALSE.
CALL getin_p('DO_IRRIGATION', doirrigation)
!
!Config Key = DO_FLOODPLAINS
!Config Desc = Should we include floodplains
!Config Def = FALSE
!Config Help = This parameters allows the user to ask the model
!Config to take into account the flood plains and return
!Config the water into the soil moisture. It then can go
!Config back to the atmopshere. This tried to simulate
!Config internal deltas of rivers.
!
dofloodplains = .FALSE.
CALL getin_p('DO_FLOODPLAINS', dofloodplains)
!
!Config Key = DO_FLOODINFILT
!Config Desc = Should floodplains reinfiltrate into the soil
!Config Def = FALSE
!Config Help = This parameters allows the user to ask the model
!Config to take into account the flood plains reinfiltration
!Config into the soil moisture. It then can go
!Config back to the slow and fast reservoirs
!
dofloodinfilt = .FALSE.
CALL getin_p('DO_FLOODINFILT', dofloodinfilt)
!
!Config Key = DO_SWAMPS
!Config Desc = Should we include swamp parameterization
!Config Def = FALSE
!Config Help = This parameters allows the user to ask the model
!Config to take into account the swamps and return
!Config the water into the bottom of the soil. It then can go
!Config back to the atmopshere. This tried to simulate
!Config internal deltas of rivers.
!
doswamps = .FALSE.
CALL getin_p('DO_SWAMPS', doswamps)
!
!Config Key = DOPONDS
!Config Desc = Should we include ponds
!Config Def = FALSE
!Config Help = This parameters allows the user to ask the model
!Config to take into account the ponds and return
!Config the water into the soil moisture. It then can go
!Config back to the atmopshere. This tried to simulate
!Config little ponds especially in West Africa.
!
doponds = .FALSE.
CALL getin_p('DO_PONDS', doponds)
!
! Fix the time constants according to hydrol_cwrr flag
!
!
!Config Key = SLOW_TCST
!Config Desc = Time constant for the slow reservoir
!Config Def = FALSE
!Config Help = This parameters allows the user to fix the
!Config time constant (in days) of the slow reservoir
!Config in order to get better river flows for
!Config particular regions.
!
IF ( hydrol_cwrr ) THEN
slow_tcst = slow_tcst_cwrr
ELSE
slow_tcst = slow_tcst_chois
ENDIF
CALL getin_p('SLOW_TCST', slow_tcst)
!
!Config Key = FAST_TCST
!Config Desc = Time constant for the fast reservoir
!Config Def = FALSE
!Config Help = This parameters allows the user to fix the
!Config time constant (in days) of the fast reservoir
!Config in order to get better river flows for
!Config particular regions.
!
IF ( hydrol_cwrr ) THEN
fast_tcst = slow_tcst_cwrr
ELSE
fast_tcst = fast_tcst_chois
ENDIF
CALL getin_p('FAST_TCST', fast_tcst)
!
!Config Key = STREAM_TCST
!Config Desc = Time constant for the stream reservoir
!Config Def = FALSE
!Config Help = This parameters allows the user to fix the
!Config time constant (in days) of the stream reservoir
!Config in order to get better river flows for
!Config particular regions.
!
IF ( hydrol_cwrr ) THEN
stream_tcst = stream_tcst_cwrr
ELSE
stream_tcst = stream_tcst_chois
ENDIF
CALL getin_p('STREAM_TCST', stream_tcst)
!
!Config Key = FLOOD_TCST
!Config Desc = Time constant for the flood reservoir
!Config Def = 4.0
!Config Help = This parameters allows the user to fix the
!Config time constant (in days) of the flood reservoir
!Config in order to get better river flows for
!Config particular regions.
!
IF ( hydrol_cwrr ) THEN
flood_tcst = flood_tcst_cwrr
ELSE
flood_tcst = flood_tcst_chois
ENDIF
CALL getin_p('FLOOD_TCST', flood_tcst)
!
!Config Key = SWAMP_CST
!Config Desc = Fraction of the river that flows back to swamps
!Config Def = 0.2
!Config Help = This parameters allows the user to fix the
!Config fraction of the river transport
!Config that flows to swamps
!
IF ( hydrol_cwrr ) THEN
swamp_cst = swamp_cst_cwrr
ELSE
swamp_cst = swamp_cst_chois
ENDIF
CALL getin_p('SWAMP_CST', swamp_cst)
!
!
! In order to simplify the time cascade check that dt_routing
! is a multiple of dtradia
!
ratio = dt_routing/dtradia
IF ( ABS(NINT(ratio) - ratio) .GT. 10*EPSILON(ratio)) THEN
WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
WRITE(numout,*) "The chosen time step for the routing is not a multiple of the"
WRITE(numout,*) "main time step of the model. We will change dt_routing so that"
WRITE(numout,*) "this condition os fulfilled"
dt_routing = NINT(ratio) * dtradia
WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
ENDIF
!
IF ( dt_routing .LT. dtradia) THEN
WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
WRITE(numout,*) 'The routing timestep can not be smaller than the one'
WRITE(numout,*) 'of the model. We reset its value to the model''s timestep.'
dt_routing = dtradia
WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
ENDIF
!
var_name ="routingcounter"
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', 's')
CALL ioconf_setatt('LONG_NAME','Time counter for the routing scheme')
CALL restget (rest_id, var_name, 1, 1, 1, kjit, .TRUE., tmp_day)
time_counter = tmp_day(1)
CALL setvar (time_counter, val_exp, 'NO_KEYWORD', 0.0_r_std)
ENDIF
CALL bcast(time_counter)
!!$ CALL setvar_p (time_counter, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (routing_area_loc(nbpt,nbasmax))
ALLOCATE (routing_area_glo(nbp_glo,nbasmax))
var_name = 'routingarea'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', 'm^2')
CALL ioconf_setatt('LONG_NAME','Area of basin')
CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., routing_area_glo, "gather", nbp_glo, index_g)
ENDIF
CALL scatter(routing_area_glo,routing_area_loc)
routing_area=>routing_area_loc
!
ALLOCATE (tmp_real_g(nbp_glo,nbasmax))
!
ALLOCATE (route_togrid_loc(nbpt,nbasmax))
ALLOCATE (route_togrid_glo(nbp_glo,nbasmax)) ! used in global in routing_flow
IF (is_root_prc) THEN
var_name = 'routetogrid'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Grid into which the basin flows')
CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
route_togrid_glo(:,:) = undef_int
WHERE ( tmp_real_g .LT. val_exp )
route_togrid_glo = NINT(tmp_real_g)
ENDWHERE
ENDIF
CALL bcast(route_togrid_glo) ! used in global in routing_flow
CALL scatter(route_togrid_glo,route_togrid_loc)
route_togrid=>route_togrid_loc
!
ALLOCATE (route_tobasin_loc(nbpt,nbasmax))
ALLOCATE (route_tobasin_glo(nbp_glo,nbasmax))
IF (is_root_prc) THEN
var_name = 'routetobasin'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Basin in to which the water goes')
CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
route_tobasin_glo = undef_int
WHERE ( tmp_real_g .LT. val_exp )
route_tobasin_glo = NINT(tmp_real_g)
ENDWHERE
ENDIF
CALL scatter(route_tobasin_glo,route_tobasin_loc)
route_tobasin=>route_tobasin_loc
!
ALLOCATE (global_basinid_loc(nbpt,nbasmax))
ALLOCATE (global_basinid_glo(nbp_glo,nbasmax))
IF (is_root_prc) THEN
var_name = 'basinid'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','ID of basin')
CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
global_basinid_glo = undef_int
WHERE ( tmp_real_g .LT. val_exp )
global_basinid_glo = NINT(tmp_real_g)
ENDWHERE
ENDIF
CALL scatter(global_basinid_glo,global_basinid_loc)
global_basinid=>global_basinid_loc
!
ALLOCATE (topo_resid_loc(nbpt,nbasmax))
ALLOCATE (topo_resid_glo(nbp_glo,nbasmax))
IF (is_root_prc) THEN
var_name = 'topoindex'
CALL ioconf_setatt('UNITS', 'm')
CALL ioconf_setatt('LONG_NAME','Topographic index of the residence time')
CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., topo_resid_glo, "gather", nbp_glo, index_g)
ENDIF
CALL scatter(topo_resid_glo,topo_resid_loc)
topo_resid=>topo_resid_loc
!
ALLOCATE (fast_reservoir(nbpt,nbasmax))
var_name = 'fastres'
CALL ioconf_setatt('UNITS', 'Kg')
CALL ioconf_setatt('LONG_NAME','Water in the fast reservoir')
CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., fast_reservoir, "gather", nbp_glo, index_g)
CALL setvar_p (fast_reservoir, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (slow_reservoir(nbpt,nbasmax))
var_name = 'slowres'
CALL ioconf_setatt('UNITS', 'Kg')
CALL ioconf_setatt('LONG_NAME','Water in the slow reservoir')
CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., slow_reservoir, "gather", nbp_glo, index_g)
CALL setvar_p (slow_reservoir, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (stream_reservoir(nbpt,nbasmax))
var_name = 'streamres'
CALL ioconf_setatt('UNITS', 'Kg')
CALL ioconf_setatt('LONG_NAME','Water in the stream reservoir')
CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., stream_reservoir, "gather", nbp_glo, index_g)
CALL setvar_p (stream_reservoir, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (flood_reservoir(nbpt,nbasmax))
var_name = 'floodres'
CALL ioconf_setatt('UNITS', 'Kg')
CALL ioconf_setatt('LONG_NAME','Water in the flood reservoir')
CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_reservoir, "gather", nbp_glo, index_g)
CALL setvar_p (flood_reservoir, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (flood_frac_bas(nbpt,nbasmax))
var_name = 'flood_frac_bas'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Flooded fraction per basin')
CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., flood_frac_bas, "gather", nbp_glo, index_g)
CALL setvar_p (flood_frac_bas, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (flood_height(nbpt))
var_name = 'flood_height'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_height, "gather", nbp_glo, index_g)
CALL setvar_p (flood_height, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (pond_frac(nbpt))
var_name = 'pond_frac'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Pond fraction per grid box')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_frac, "gather", nbp_glo, index_g)
CALL setvar_p (pond_frac, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
var_name = 'flood_frac'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Flooded fraction per grid box')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_frac, "gather", nbp_glo, index_g)
CALL setvar_p (flood_frac, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
var_name = 'flood_res'
CALL ioconf_setatt('UNITS','mm')
CALL ioconf_setatt('LONG_NAME','Flooded quantity (estimation)')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., flood_res, "gather", nbp_glo, index_g)
CALL setvar_p (flood_res, val_exp, 'NO_KEYWORD', 0.0_r_std)
! flood_res = zero
!
ALLOCATE (lake_reservoir(nbpt))
var_name = 'lakeres'
CALL ioconf_setatt('UNITS', 'Kg')
CALL ioconf_setatt('LONG_NAME','Water in the lake reservoir')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lake_reservoir, "gather", nbp_glo, index_g)
CALL setvar_p (lake_reservoir, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (pond_reservoir(nbpt))
var_name = 'pondres'
CALL ioconf_setatt('UNITS', 'Kg')
CALL ioconf_setatt('LONG_NAME','Water in the pond reservoir')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., pond_reservoir, "gather", nbp_glo, index_g)
CALL setvar_p (pond_reservoir, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
! Map of irrigated areas
!
IF ( doirrigation ) THEN
ALLOCATE (irrigated(nbpt))
var_name = 'irrigated'
CALL ioconf_setatt('UNITS', 'm^2')
CALL ioconf_setatt('LONG_NAME','Surface of irrigated area')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigated, "gather", nbp_glo, index_g)
CALL setvar_p (irrigated, val_exp, 'NO_KEYWORD', undef_sechiba)
ENDIF
!
IF ( dofloodplains ) THEN
ALLOCATE (floodplains(nbpt))
var_name = 'floodplains'
CALL ioconf_setatt('UNITS', 'm^2')
CALL ioconf_setatt('LONG_NAME','Surface which can be flooded')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodplains, "gather", nbp_glo, index_g)
CALL setvar_p (floodplains, val_exp, 'NO_KEYWORD', undef_sechiba)
ENDIF
IF ( doswamps ) THEN
ALLOCATE (swamp(nbpt))
var_name = 'swamp'
CALL ioconf_setatt('UNITS', 'm^2')
CALL ioconf_setatt('LONG_NAME','Surface which can become swamp')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., swamp, "gather", nbp_glo, index_g)
CALL setvar_p (swamp, val_exp, 'NO_KEYWORD', undef_sechiba)
ENDIF
!
! Put into the restart file the fluxes so that they can be regenerated at restart.
!
ALLOCATE (lakeinflow_mean(nbpt))
var_name = 'lakeinflow'
CALL ioconf_setatt('UNITS', 'Kg/dt')
CALL ioconf_setatt('LONG_NAME','Lake inflow')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lakeinflow_mean, "gather", nbp_glo, index_g)
CALL setvar_p (lakeinflow_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (returnflow_mean(nbpt))
var_name = 'returnflow'
CALL ioconf_setatt('UNITS', 'Kg/m^2/dt')
CALL ioconf_setatt('LONG_NAME','Deep return flux')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., returnflow_mean, "gather", nbp_glo, index_g)
CALL setvar_p (returnflow_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
returnflow(:) = returnflow_mean(:)
!
ALLOCATE (reinfiltration_mean(nbpt))
var_name = 'reinfiltration'
CALL ioconf_setatt('UNITS', 'Kg/m^2/dt')
CALL ioconf_setatt('LONG_NAME','Top return flux')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinfiltration_mean, "gather", nbp_glo, index_g)
CALL setvar_p (reinfiltration_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
reinfiltration(:) = reinfiltration_mean(:)
!
ALLOCATE (irrigation_mean(nbpt))
ALLOCATE (irrig_netereq(nbpt))
irrig_netereq(:) = zero
!
IF ( doirrigation ) THEN
var_name = 'irrigation'
CALL ioconf_setatt('UNITS', 'Kg/dt')
CALL ioconf_setatt('LONG_NAME','Artificial irrigation flux')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigation_mean, "gather", nbp_glo, index_g)
CALL setvar_p (irrigation_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
irrigation(:) = irrigation_mean(:)
ELSE
irrigation_mean(:) = zero
ENDIF
!
ALLOCATE (riverflow_mean(nbpt))
var_name = 'riverflow'
CALL ioconf_setatt('UNITS', 'Kg/dt')
CALL ioconf_setatt('LONG_NAME','River flux into the sea')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., riverflow_mean, "gather", nbp_glo, index_g)
CALL setvar_p (riverflow_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
riverflow(:) = riverflow_mean(:)
!
ALLOCATE (coastalflow_mean(nbpt))
var_name = 'coastalflow'
CALL ioconf_setatt('UNITS', 'Kg/dt')
CALL ioconf_setatt('LONG_NAME','Diffuse flux into the sea')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., coastalflow_mean, "gather", nbp_glo, index_g)
CALL setvar_p (coastalflow_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
coastalflow(:) = coastalflow_mean(:)
!
! Locate it at the 2m level
ipn = MINLOC(ABS(diaglev-2))
floodtemp_lev = ipn(1)
ALLOCATE (floodtemp(nbpt))
floodtemp(:) = stempdiag(:,floodtemp_lev)
!
ALLOCATE(hydrographs(nbpt))
var_name = 'hydrographs'
CALL ioconf_setatt('UNITS', 'm^3/dt')
CALL ioconf_setatt('LONG_NAME','Hydrograph at outlow of grid')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., hydrographs, "gather", nbp_glo, index_g)
CALL setvar_p (hydrographs, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
! The diagnostic variables, they are initialized from the above restart variables.
!
ALLOCATE(fast_diag(nbpt), slow_diag(nbpt), stream_diag(nbpt), flood_diag(nbpt), &
& pond_diag(nbpt), lake_diag(nbpt), delsurfstor(nbpt), stat=ier)
!
fast_diag(:) = 0.0
slow_diag(:) = 0.0
stream_diag(:) = 0.0
flood_diag(:) = 0.0
!!!!
pond_diag(:) = 0.0
!!!!
lake_diag(:) = 0.0
delsurfstor(:) = 0.0
!
DO ig=1,nbpt
totarea = 0.0
DO ib=1,nbasmax
totarea = totarea + routing_area(ig,ib)
fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
ENDDO
!
fast_diag(ig) = fast_diag(ig)/totarea
slow_diag(ig) = slow_diag(ig)/totarea
stream_diag(ig) = stream_diag(ig)/totarea
flood_diag(ig) = flood_diag(ig)/totarea
!
! This is the volume of the lake scaled to the entire grid.
! It would be batter to scale it to the size of the lake
! but this information is not yet available.
!
lake_diag(ig) = lake_reservoir(ig)/totarea
!
ENDDO
!
!
! Get from the restart the fluxes we accumulated.
!
ALLOCATE (floodout_mean(nbpt))
var_name = 'floodout_route'
CALL ioconf_setatt('UNITS', 'Kg')
CALL ioconf_setatt('LONG_NAME','Accumulated flow out of floodplains for routing')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodout_mean, "gather", nbp_glo, index_g)
CALL setvar_p (floodout_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE (runoff_mean(nbpt))
var_name = 'runoff_route'
CALL ioconf_setatt('UNITS', 'Kg')
CALL ioconf_setatt('LONG_NAME','Accumulated runoff for routing')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., runoff_mean, "gather", nbp_glo, index_g)
CALL setvar_p (runoff_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE(drainage_mean(nbpt))
var_name = 'drainage_route'
CALL ioconf_setatt('UNITS', 'Kg')
CALL ioconf_setatt('LONG_NAME','Accumulated drainage for routing')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., drainage_mean, "gather", nbp_glo, index_g)
CALL setvar_p (drainage_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE(evapot_mean(nbpt))
var_name = 'evapot_route'
CALL ioconf_setatt('UNITS', 'Kg/m^2')
CALL ioconf_setatt('LONG_NAME','Accumulated potential evaporation for routing')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., evapot_mean, "gather", nbp_glo, index_g)
CALL setvar_p (evapot_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
!MG
ALLOCATE(etm_mean(nbpt))
var_name = 'etm_route'
CALL ioconf_setatt('UNITS', 'Kg/m^2')
CALL ioconf_setatt('LONG_NAME','Accumulated maximum evapotranspiration for routing')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., etm_mean, "gather", nbp_glo, index_g)
CALL setvar_p (etm_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
ALLOCATE(precip_mean(nbpt))
var_name = 'precip_route'
CALL ioconf_setatt('UNITS', 'Kg/m^2')
CALL ioconf_setatt('LONG_NAME','Accumulated rain precipitation for irrigation')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., precip_mean, "gather", nbp_glo, index_g)
CALL setvar_p (precip_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE(humrel_mean(nbpt))
var_name = 'humrel_route'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Mean humrel for irrigation')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., humrel_mean, "gather", nbp_glo, index_g)
CALL setvar_p (humrel_mean, val_exp, 'NO_KEYWORD', 1.0_r_std)
!
ALLOCATE(k_litt_mean(nbpt))
var_name = 'k_litt_route'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Mean cond. for litter')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., k_litt_mean, "gather", nbp_glo, index_g)
CALL setvar_p (k_litt_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE(totnobio_mean(nbpt))
var_name = 'totnobio_route'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Last Total fraction of no bio for irrigation')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., totnobio_mean, "gather", nbp_glo, index_g)
CALL setvar_p (totnobio_mean, val_exp, 'NO_KEYWORD', 0.0_r_std)
!
ALLOCATE(vegtot_mean(nbpt))
var_name = 'vegtot_route'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Last Total fraction of vegetation')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vegtot_mean, "gather", nbp_glo, index_g)
CALL setvar_p (vegtot_mean, val_exp, 'NO_KEYWORD', 1.0_r_std)
!
!
DEALLOCATE(tmp_real_g)
!
! Allocate diagnostic variables
!
ALLOCATE(hydrodiag_loc(nbpt,nbasmax),hydrodiag_glo(nbp_glo,nbasmax),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in hydrodiag allocation. We stop. We need kjpindex words = ', nbpt*nbasmax
STOP 'routing_init'
END IF
hydrodiag=>hydrodiag_loc
!
!
END SUBROUTINE routing_init
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_clear()
!
l_first_routing=.TRUE.
!
IF (ALLOCATED(routing_area_loc)) DEALLOCATE(routing_area_loc)
IF (ALLOCATED(route_togrid_loc)) DEALLOCATE(route_togrid_loc)
IF (ALLOCATED(route_tobasin_loc)) DEALLOCATE(route_tobasin_loc)
IF (ALLOCATED(global_basinid_loc)) DEALLOCATE(global_basinid_loc)
IF (ALLOCATED(topo_resid_loc)) DEALLOCATE(topo_resid_loc)
IF (ALLOCATED(routing_area_glo)) DEALLOCATE(routing_area_glo)
IF (ALLOCATED(route_togrid_glo)) DEALLOCATE(route_togrid_glo)
IF (ALLOCATED(route_tobasin_glo)) DEALLOCATE(route_tobasin_glo)
IF (ALLOCATED(global_basinid_glo)) DEALLOCATE(global_basinid_glo)
IF (ALLOCATED(topo_resid_glo)) DEALLOCATE(topo_resid_glo)
IF (ALLOCATED(fast_reservoir)) DEALLOCATE(fast_reservoir)
IF (ALLOCATED(slow_reservoir)) DEALLOCATE(slow_reservoir)
IF (ALLOCATED(stream_reservoir)) DEALLOCATE(stream_reservoir)
IF (ALLOCATED(flood_reservoir)) DEALLOCATE(flood_reservoir)
IF (ALLOCATED(flood_frac_bas)) DEALLOCATE(flood_frac_bas)
IF (ALLOCATED(flood_height)) DEALLOCATE(flood_height)
IF (ALLOCATED(pond_frac)) DEALLOCATE(pond_frac)
IF (ALLOCATED(lake_reservoir)) DEALLOCATE(lake_reservoir)
IF (ALLOCATED(pond_reservoir)) DEALLOCATE(pond_reservoir)
IF (ALLOCATED(returnflow_mean)) DEALLOCATE(returnflow_mean)
IF (ALLOCATED(reinfiltration_mean)) DEALLOCATE(reinfiltration_mean)
IF (ALLOCATED(riverflow_mean)) DEALLOCATE(riverflow_mean)
IF (ALLOCATED(coastalflow_mean)) DEALLOCATE(coastalflow_mean)
IF (ALLOCATED(lakeinflow_mean)) DEALLOCATE(lakeinflow_mean)
IF (ALLOCATED(runoff_mean)) DEALLOCATE(runoff_mean)
IF (ALLOCATED(floodout_mean)) DEALLOCATE(floodout_mean)
IF (ALLOCATED(drainage_mean)) DEALLOCATE(drainage_mean)
IF (ALLOCATED(evapot_mean)) DEALLOCATE(evapot_mean)
!MG
IF (ALLOCATED(etm_mean)) DEALLOCATE(etm_mean)
IF (ALLOCATED(precip_mean)) DEALLOCATE(precip_mean)
IF (ALLOCATED(humrel_mean)) DEALLOCATE(humrel_mean)
IF (ALLOCATED(k_litt_mean)) DEALLOCATE(k_litt_mean)
IF (ALLOCATED(totnobio_mean)) DEALLOCATE(totnobio_mean)
IF (ALLOCATED(vegtot_mean)) DEALLOCATE(vegtot_mean)
IF (ALLOCATED(floodtemp)) DEALLOCATE(floodtemp)
IF (ALLOCATED(hydrodiag_loc)) DEALLOCATE(hydrodiag_loc)
IF (ALLOCATED(hydrodiag_glo)) DEALLOCATE(hydrodiag_glo)
IF (ALLOCATED(hydrographs)) DEALLOCATE(hydrographs)
IF (ALLOCATED(irrigation_mean)) DEALLOCATE(irrigation_mean)
IF (ALLOCATED(irrigated)) DEALLOCATE(irrigated)
IF (ALLOCATED(floodplains)) DEALLOCATE(floodplains)
IF (ALLOCATED(swamp)) DEALLOCATE(swamp)
IF (ALLOCATED(fast_diag)) DEALLOCATE(fast_diag)
IF (ALLOCATED(slow_diag)) DEALLOCATE(slow_diag)
IF (ALLOCATED(stream_diag)) DEALLOCATE(stream_diag)
IF (ALLOCATED(flood_diag)) DEALLOCATE(flood_diag)
IF (ALLOCATED(pond_diag)) DEALLOCATE(pond_diag)
IF (ALLOCATED(lake_diag)) DEALLOCATE(lake_diag)
IF (ALLOCATED(delsurfstor)) DEALLOCATE(delsurfstor)
!
END SUBROUTINE routing_clear
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_flow(nbpt, dt_routing, floodout, runoff, drainage, &
! & vegtot, totnobio, evapot, precip, humrel, k_litt, floodtemp, reinf_slope, &
!MG
& vegtot, totnobio, evapot, etm_mean, precip, humrel, k_litt, floodtemp, reinf_slope, &
& lakeinflow, returnflow, reinfiltration, irrigation, riverflow, &
& coastalflow, hydrographs, flood_frac, flood_res)
!
IMPLICIT NONE
!
!
! INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt !! Domain size
REAL(r_std), INTENT (in) :: dt_routing !! Time step in seconds
REAL(r_std), INTENT(in) :: runoff(nbpt) !! grid-point runoff
REAL(r_std), INTENT(in) :: floodout(nbpt) !! grid-point flow out of floodplains
REAL(r_std), INTENT(in) :: drainage(nbpt) !! grid-point drainage
REAL(r_std), INTENT(in) :: vegtot(nbpt) !! Potentially vegetated area
REAL(r_std), INTENT(in) :: totnobio(nbpt) !! Other areas whichcan not have vegetation
REAL(r_std), INTENT(in) :: evapot(nbpt) !! grid-point potential evaporation
!MG
REAL(r_std), INTENT(in) :: etm_mean(nbpt) !! grid-point maximum transpiration
REAL(r_std), INTENT(in) :: precip(nbpt) !! Precipitation (rainfall here)
REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture stress
REAL(r_std), INTENT(in) :: k_litt(nbpt) !! Litter cond.
REAL(r_std), INTENT(in) :: floodtemp(nbpt) !! Temperature to decide if floodplains work
REAL(r_std), INTENT(in) :: reinf_slope(nbpt) !! Slope coef for reinfiltration
REAL(r_std), INTENT(out) :: lakeinflow(nbpt) !! The water flow which flows into lakes (kg/dt)
REAL(r_std), INTENT(out) :: returnflow(nbpt) !! Water flowing back into soil moisture (kg/m^2/dt)
REAL(r_std), INTENT(out) :: reinfiltration(nbpt)!! Water flowing back into soil moisture (kg/m^2/dt)
REAL(r_std), INTENT(out) :: irrigation(nbpt) !! The artificial irrigation (kg/m^2 per dt)
REAL(r_std), INTENT(out) :: riverflow(nbpt) !! Outflow of the major rivers (kg/dt)
REAL(r_std), INTENT(out) :: coastalflow(nbpt) !! Outflow on coastal points by small basins (kg/dt)
REAL(r_std), INTENT(out) :: hydrographs(nbpt) !! Hydrographs at the outflow of the gird box for major basins
REAL(r_std), INTENT(out) :: flood_frac(nbpt) ! Flooded fraction of grid box
REAL(r_std), INTENT(out) :: flood_res(nbpt) ! Flooded quantity (estimation)
!
! LOCAL
!
REAL(r_std), DIMENSION(nbpt, nbasmax) :: fast_flow
REAL(r_std), DIMENSION(nbpt, nbasmax) :: slow_flow
REAL(r_std), DIMENSION(nbpt, nbasmax) :: stream_flow
REAL(r_std), DIMENSION(nbpt, nbasmax) :: flood_flow
REAL(r_std), DIMENSION(nbpt, nbasmax) :: pond_inflow, pond_drainage, flood_drainage
REAL(r_std), DIMENSION(nbpt, nbasmax) :: return_swamp
REAL(r_std), DIMENSION(nbpt, nbasmax) :: baseirrig !! Irrigation uptake from each basin reservoir.
REAL(r_std), DIMENSION(nbpt, 0:nbasmax+3) :: transport
REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_glo
REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_sum
REAL(r_std), DIMENSION(nbpt, nbasmax) :: floods, potflood
REAL(r_std), DIMENSION(nbpt) :: tobeflooded
REAL(r_std), DIMENSION(nbpt) :: totarea
REAL(r_std), DIMENSION(nbpt) :: totflood
REAL(r_std) :: flow, floodindex, pondflow, flood_frac_pot
INTEGER(i_std) :: ig, ib, rtg, rtb, ierr
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fast_flow_g,slow_flow_g,stream_flow_g
!
transport(:,:) = zero
transport_glo(:,:) = zero
irrig_netereq(:) = zero
baseirrig(:,:) = zero
totarea(:) = zero
totflood(:) = zero
!
! Compute all the fluxes
!
DO ig=1,nbpt
DO ib=1,nbasmax
!
totarea(ig) = totarea(ig) + routing_area(ig,ib)
totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
ENDDO
ENDDO
!
DO ig=1,nbpt
DO ib=1,nbasmax
IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
!
flow = MIN(fast_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*fast_tcst*one_day/dt_routing),&
& fast_reservoir(ig,ib))
fast_flow(ig,ib) = flow
!
flow = MIN(slow_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*slow_tcst*one_day/dt_routing),&
& slow_reservoir(ig,ib))
slow_flow(ig,ib) = flow
!
flow = MIN(stream_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*stream_tcst* &
& MAX(un-SQRT(flood_frac_bas(ig,ib)),min_sechiba)*one_day/dt_routing),&
& stream_reservoir(ig,ib))
stream_flow(ig,ib) = flow
!
!
ELSE
fast_flow(ig,ib) = 0.0
slow_flow(ig,ib) = 0.0
stream_flow(ig,ib) = 0.0
ENDIF
ENDDO
ENDDO
!-
!- Updating reservoir with atmospheric demand
!-
IF (dofloodplains .OR. doponds) THEN
DO ig=1,nbpt
IF (flood_frac(ig) .GT. min_sechiba) THEN
!
flow = floodout(ig)*totarea(ig)*pond_frac(ig)/flood_frac(ig)
pondflow = MIN(flow, pond_reservoir(ig))
pond_reservoir(ig) = pond_reservoir(ig) - pondflow
! If demand was over reservoir size, we will take it out from floodplains
pondflow = flow - pondflow
!
DO ib=1,nbasmax
!
flow = floodout(ig)*routing_area(ig,ib)*flood_frac_bas(ig,ib)/flood_frac(ig) + &
! If more than pondcri was taken out
& pondflow*flood_frac_bas(ig,ib)/(flood_frac(ig)-pond_frac(ig))
flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flow
!
! A few verifications to be stable
!
IF (flood_reservoir(ig,ib) .LT. -0.1) THEN
PRINT *, 'Floodplains dried out very fast!', ig, ib, flow, flow/(flood_reservoir(ig,ib)+flow)
PRINT *, 'This is corrected by putting floodplains to zero'
ENDIF
!
IF (flood_reservoir(ig,ib) .LT. min_sechiba) THEN
flood_reservoir(ig,ib) = zero
ENDIF
IF (pond_reservoir(ig) .LT. min_sechiba) THEN
pond_reservoir(ig) = zero
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
!-
!- Computing the drainage and outflow from floodplains
!-
IF (dofloodplains) THEN
IF (dofloodinfilt) THEN
DO ig=1,nbpt
DO ib=1,nbasmax
flood_drainage(ig,ib) = MAX(zero, MIN(flood_reservoir(ig,ib), &
& flood_frac(ig)*routing_area(ig,ib)*k_litt(ig)*dt_routing/one_day))
flood_reservoir(ig,ib) = flood_reservoir(ig,ib) - flood_drainage(ig,ib)
ENDDO
ENDDO
ELSE
DO ig=1,nbpt
DO ib=1,nbasmax
flood_drainage(ig,ib) = zero
ENDDO
ENDDO
ENDIF
!
DO ig=1,nbpt
DO ib=1,nbasmax
IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
IF (flood_frac_bas(ig,ib) .GT. min_sechiba) THEN
flow = MIN(flood_reservoir(ig,ib) &
& /((topo_resid(ig,ib)/1000.)*flood_tcst* &
& flood_frac_bas(ig,ib)*one_day/dt_routing),&
& flood_reservoir(ig,ib))
ELSE
flow = zero
ENDIF
flood_flow(ig,ib) = flow
ELSE
flood_flow(ig,ib) = zero
ENDIF
ENDDO
ENDDO
ELSE
DO ig=1,nbpt
DO ib=1,nbasmax
flood_drainage(ig,ib) = zero
flood_flow(ig,ib) = zero
flood_reservoir(ig,ib) = zero
ENDDO
ENDDO
ENDIF
!-
!- Computing drainage and inflow for ponds
!-
IF (doponds) THEN
DO ig=1,nbpt
! If used, the slope coef is not used in hydrol for water2infilt
DO ib=1,nbasmax
pond_inflow(ig,ib) = fast_flow(ig,ib) * reinf_slope(ig)
pond_drainage(ig,ib) = MIN(pond_reservoir(ig)*routing_area(ig,ib)/totarea(ig), &
& pond_frac(ig)*routing_area(ig,ib)*k_litt(ig)*dt_routing/one_day)
fast_flow(ig,ib) = fast_flow(ig,ib) - pond_inflow(ig,ib)
ENDDO
ENDDO
ELSE
DO ig=1,nbpt
DO ib=1,nbasmax
pond_inflow(ig,ib) = zero
pond_drainage(ig,ib) = zero
pond_reservoir(ig) = zero
ENDDO
ENDDO
ENDIF
!-
!- Compute the transport from one basin to another
!-
!ym cette methode conserve les erreurs d'arrondie
!ym mais n'est pas la plus efficace
IF (is_root_prc) &
ALLOCATE( fast_flow_g(nbp_glo, nbasmax), slow_flow_g(nbp_glo, nbasmax), &
stream_flow_g(nbp_glo, nbasmax) )
CALL gather(fast_flow,fast_flow_g)
CALL gather(slow_flow,slow_flow_g)
CALL gather(stream_flow,stream_flow_g)
IF (is_root_prc) THEN
DO ig=1,nbp_glo
DO ib=1,nbasmax
!
rtg = route_togrid_glo(ig,ib)
rtb = route_tobasin_glo(ig,ib)
transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow_g(ig,ib) + slow_flow_g(ig,ib) + &
& stream_flow_g(ig,ib)
!
ENDDO
ENDDO
ENDIF
IF (is_root_prc) &
DEALLOCATE( fast_flow_g, slow_flow_g, stream_flow_g )
CALL scatter(transport_glo,transport)
!ym DO ig=1,nbpt
!ym DO ib=1,nbasmax
!ym !
!ym rtg = route_togrid(ig,ib)
!ym rtb = route_tobasin(ig,ib)
!ym transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow(ig,ib) + slow_flow(ig,ib) + &
!ym & stream_flow(ig,ib) - floods(ig,ib) - wdelay(ig,ib)
!ym !
!ym ENDDO
!ym ENDDO
!ym
!ym CALL reduce_sum(transport_glo,transport_sum)
!ym CALL scatter(transport_sum,transport)
!-
!- Do the floodings - First initialize
!-
return_swamp(:,:)=zero
floods(:,:)=zero
!-
!- 1. Swamps: Take out water from the river to put it to the swamps
!-
IF ( doswamps ) THEN
DO ig=1,nbpt
tobeflooded(ig) = swamp(ig)
DO ib=1,nbasmax
potflood(ig,ib) = transport(ig,ib)
!
IF ( tobeflooded(ig) > 0. .AND. potflood(ig,ib) > 0. .AND. floodtemp(ig) > tp_00 ) THEN
!
IF (routing_area(ig,ib) > tobeflooded(ig)) THEN
floodindex = tobeflooded(ig) / routing_area(ig,ib)
ELSE
floodindex = 1.0
ENDIF
return_swamp(ig,ib) = swamp_cst * potflood(ig,ib) * floodindex
!
tobeflooded(ig) = tobeflooded(ig) - routing_area(ig,ib)
!
ENDIF
ENDDO
ENDDO
ENDIF
!-
!- 2. Floodplains: Then computes how much goes to the floodplains
!-
IF ( dofloodplains ) THEN
DO ig=1,nbpt
IF (floodplains(ig) .GT. min_sechiba .AND. floodtemp(ig) .GT. tp_00) THEN
DO ib=1,nbasmax
floods(ig,ib) = transport(ig,ib) - return_swamp(ig,ib)
ENDDO
ENDIF
ENDDO
ENDIF
!
! Update all reservoirs
!
DO ig=1,nbpt
DO ib=1,nbasmax
!
fast_reservoir(ig,ib) = fast_reservoir(ig,ib) + runoff(ig)*routing_area(ig,ib) - &
& fast_flow(ig,ib) - pond_inflow(ig,ib) + 1e-2
!
slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + drainage(ig)*routing_area(ig,ib) - &
& slow_flow(ig,ib)
!
stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + flood_flow(ig,ib) + transport(ig,ib) - &
& stream_flow(ig,ib) - return_swamp(ig,ib) - floods(ig,ib) + 1e-2
!
flood_reservoir(ig,ib) = flood_reservoir(ig,ib) + floods(ig,ib) - &
& flood_flow(ig,ib)
!
pond_reservoir(ig) = pond_reservoir(ig) + pond_inflow(ig,ib) - pond_drainage(ig,ib)
!
IF (fast_reservoir(ig,ib).LT.-min_sechiba.OR.slow_reservoir(ig,ib).LT.-min_sechiba &
& .OR.stream_reservoir(ig,ib).LT.-min_sechiba.OR.flood_reservoir(ig,ib).LT.-min_sechiba) THEN
PRINT *, 'There is a negative reservoir'
PRINT *, 'fastr, fast_flow, runoff', &
& fast_reservoir(ig,ib), fast_flow(ig,ib), runoff(ig)
PRINT *, 'slowr, slow_flow, drainage', &
& slow_reservoir(ig,ib), slow_flow(ig,ib), drainage(ig)
PRINT *, 'streamr, stream_flow, floods, transport', &
& stream_reservoir(ig,ib), stream_flow(ig,ib), floods(ig,ib), transport(ig,ib)
PRINT *, 'floodr, flood_flow, floodout, reinfilt', &
& flood_reservoir(ig,ib), flood_flow(ig,ib), floodout(ig), return_swamp(ig,ib)
PRINT *, 'pondr, pond_inflow, pond_drainage', &
& pond_reservoir(ig), pond_inflow(ig,ib), pond_drainage(ig,ib)
STOP
ENDIF
!
!
ENDDO
ENDDO
totflood(:) = zero
DO ig=1,nbpt
DO ib=1,nbasmax
!
totflood(ig) = totflood(ig) + flood_reservoir(ig,ib)
ENDDO
ENDDO
!-
!- Computes the fraction of floodplains and ponds according to their volume
!-
IF (dofloodplains .OR. doponds) THEN
flood_frac(:) = zero
flood_height(:) = zero
flood_frac_bas(:,:) = zero
DO ig=1, nbpt
IF (totflood(ig) .GT. min_sechiba) THEN
! We first compute the total fraction of the grid box which is flooded at optimum repartition
flood_frac_pot = (totflood(ig) / (totarea(ig)*floodcri/(beta+un)))**(beta/(beta+un))
flood_frac(ig) = MIN(floodplains(ig) / totarea(ig), flood_frac_pot)
! Then we diagnose the fraction for each basin with the size of its flood_reservoir (flood_frac_bas may be > 1)
DO ib=1,nbasmax
IF (routing_area(ig,ib) .GT. min_sechiba) THEN
flood_frac_bas(ig,ib) = flood_frac(ig) * &
& (flood_reservoir(ig,ib) / totflood(ig)) / (routing_area(ig,ib) / totarea(ig))
ENDIF
ENDDO
! We diagnose the maximum height of floodplain
flood_height(ig) = (beta/(beta+1))*floodcri*(flood_frac(ig))**(un/beta) + totflood(ig)/(totarea(ig)*flood_frac(ig))
! And finaly add the pond surface
pond_frac(ig) = MIN(un-flood_frac(ig), ((betap+1)*pond_reservoir(ig) / (pondcri*totarea(ig)))**(betap/(betap+1)) )
flood_frac(ig) = flood_frac(ig) + pond_frac(ig)
!
ENDIF
ENDDO
ELSE
flood_frac(:) = zero
flood_height(:) = zero
flood_frac_bas(:,:) = zero
ENDIF
!-
!- Compute the total reinfiltration and returnflow to the grid box
!-
IF (dofloodplains .OR. doswamps .OR. doponds) THEN
returnflow(:) = zero
reinfiltration(:) = zero
DO ig=1,nbpt
!
DO ib=1,nbasmax
returnflow(ig) = returnflow(ig) + return_swamp(ig,ib)
reinfiltration(ig) = reinfiltration(ig) + pond_drainage(ig,ib) + flood_drainage(ig,ib)
ENDDO
!
returnflow(ig) = returnflow(ig)/totarea(ig)
reinfiltration(ig) = reinfiltration(ig)/totarea(ig)
!
ENDDO
ELSE
returnflow(:) = zero
reinfiltration(:) = zero
ENDIF
!-
!- Compute the net irrigation requirement from Univ of Kassel
!-
! This is a very low priority process and thus only applies if
! there is some water left in the reservoirs after all other things.
!
IF ( doirrigation ) THEN
DO ig=1,nbpt
IF ((vegtot(ig) .GT. min_sechiba) .AND. (humrel(ig) .LT. un-min_sechiba)) THEN
irrig_netereq(ig) = (irrigated(ig) / totarea(ig) ) * MAX(zero, &
!MG
! & crop_coef * evapot(ig) - &
& etm_mean(ig) - &
& MAX(precip(ig)+returnflow(ig)+reinfiltration(ig)-runoff(ig)-drainage(ig), zero) )
! irrig_netereq(ig) = 1 * irrig_netereq(ig)
! IF(irrig_netereq(ig)*routing_area(ig,ib).LT.-min_sechiba) THEN
IF(irrig_netereq(ig).LT.0) THEN
WRITE(numout,*) 'there is a probleme for irrig_netereq',ig,irrig_netereq(ig)
STOP
ENDIF
ENDIF
DO ib=1,nbasmax
IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
baseirrig(ig,ib) = MIN( irrig_netereq(ig) * routing_area(ig,ib),&
& stream_reservoir(ig,ib) + fast_reservoir(ig,ib) + slow_reservoir(ig,ib) )
slow_reservoir(ig,ib) = MAX(0.0, slow_reservoir(ig,ib) + &
& MIN(0.0, fast_reservoir(ig,ib) + MIN(0.0, stream_reservoir(ig,ib)-baseirrig(ig,ib))))
fast_reservoir(ig,ib) = MAX( 0.0, &
& fast_reservoir(ig,ib) + MIN(0.0, stream_reservoir(ig,ib)-baseirrig(ig,ib)))
stream_reservoir(ig,ib) = MAX(0.0, stream_reservoir(ig,ib)-baseirrig(ig,ib) )
IF(baseirrig(ig,ib) .LT. -min_sechiba .OR. slow_reservoir(ig,ib) .LT. -min_sechiba .OR. &
& fast_reservoir(ig,ib) .LT. -min_sechiba .OR. stream_reservoir(ig,ib) .LT. -min_sechiba) THEN
PRINT *,'There is negative values related to irrigation', ig,ib,baseirrig(ig,ib), &
& slow_reservoir(ig,ib),fast_reservoir(ig,ib),stream_reservoir(ig,ib)
STOP
ENDIF
ENDIF
ENDDO
ENDDO
!
ENDIF
!
!
! Compute the fluxes which leave the routing scheme
!
! Lakeinflow is in Kg/dt
! returnflow is in Kg/m^2/dt
!
delsurfstor(:) = -flood_diag(:)-pond_diag(:)-lake_diag(:)
hydrographs(:) = zero
fast_diag(:) = zero
slow_diag(:) = zero
stream_diag(:) = zero
flood_diag(:) = zero
pond_diag(:) = zero
irrigation(:) = zero
!
!
DO ig=1,nbpt
!
DO ib=1,nbasmax
IF (hydrodiag(ig,ib) > 0 ) THEN
hydrographs(ig) = hydrographs(ig) + fast_flow(ig,ib) + slow_flow(ig,ib) + &
& stream_flow(ig,ib)
ENDIF
fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
flood_diag(ig) = flood_diag(ig) + flood_reservoir(ig,ib)
irrigation (ig) = irrigation (ig) + baseirrig(ig,ib)
ENDDO
!
fast_diag(ig) = fast_diag(ig)/totarea(ig)
slow_diag(ig) = slow_diag(ig)/totarea(ig)
stream_diag(ig) = stream_diag(ig)/totarea(ig)
flood_diag(ig) = flood_diag(ig)/totarea(ig)
pond_diag(ig) = pond_reservoir(ig)/totarea(ig)
!
irrigation(ig) = irrigation(ig)/totarea(ig)
!
! The three output types for the routing : endoheric basins,, rivers and
! diffuse coastal flow.
!
lakeinflow(ig) = transport(ig,nbasmax+1)
coastalflow(ig) = transport(ig,nbasmax+2)
riverflow(ig) = transport(ig,nbasmax+3)
!
IF ( irrigation(ig) .GE. irrig_netereq(ig)+1e4 ) THEN
WRITE(numout,*) 'There is a problem here with irrigation',ig,irrigation(ig),irrig_netereq(ig)
WRITE(numout,*) irrigated(ig),totarea(ig), evapot(ig), precip_mean(ig),runoff(ig),drainage(ig)
STOP
ENDIF
!
ENDDO
!
flood_res = flood_diag + pond_diag
!
END SUBROUTINE routing_flow
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_lake(nbpt, dt_routing, lakeinflow, humrel, return_lakes)
!
IMPLICIT NONE
!
! This routine stores water in lakes so that it does not cycle through
! the runoff. For the moment it only works for endoheric lakes but it can
! be extended in the future.
! The return flow to the soil moisture reservoir is based on a maximum
! lake evaporation rate (maxevap_lake).
!
INTEGER(i_std), INTENT(in) :: nbpt !! Domain size
REAL(r_std), INTENT (in) :: dt_routing !! Time step in seconds
REAL(r_std), INTENT(in) :: lakeinflow(nbpt) !! Flow into the lake (kg/dt)
REAL(r_std), INTENT(in) :: humrel(nbpt) !! Soil moisture deficit around the lake (Hum !)
REAL(r_std), INTENT(out) :: return_lakes(nbpt) !! Water flowing back into soil moisture (kg/m^2/dt)
!
! LOCAL
!
INTEGER(i_std) :: ig
REAL(r_std) :: refill, total_area
!
!
!
DO ig=1,nbpt
!
total_area = SUM(routing_area(ig,:))
!
lake_reservoir(ig) = lake_reservoir(ig) + lakeinflow(ig)
!uptake in Kg/dt
refill = MAX(zero, maxevap_lake * (un - humrel(ig)) * dt_routing * total_area)
return_lakes(ig) = MIN(refill, lake_reservoir(ig))
lake_reservoir(ig) = lake_reservoir(ig) - return_lakes(ig)
!Return in Kg/m^2/dt
IF ( doswamps ) THEN
return_lakes(ig) = return_lakes(ig)/total_area
ELSE
return_lakes(ig) = zero
ENDIF
!
! This is the volume of the lake scaled to the entire grid.
! It would be batter to scale it to the size of the lake
! but this information is not yet available.
lake_diag(ig) = lake_reservoir(ig)/total_area
!
ENDDO
!
END SUBROUTINE routing_lake
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_diagnostic_p(nbpt,index, resolution, contfrac, hist_id, hist2_id)
!
IMPLICIT NONE
INTEGER(i_std), INTENT(in) :: nbpt !! Domain size
INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indeces of the points on the map
REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box.
INTEGER(i_std),INTENT (in) :: hist_id !! _history_ file identifier
INTEGER(i_std),INTENT (in) :: hist2_id !! _history_ file 2 identifier
REAL(r_std), DIMENSION(nbpt) :: nbrivers !! Number of rivers in the grid
REAL(r_std), DIMENSION(nbpt) :: basinmap !! Map of basins
REAL(r_std), DIMENSION(nbp_glo) :: nbrivers_g !! Number of rivers in the grid
REAL(r_std), DIMENSION(nbp_glo) :: basinmap_g !! Map of basins
routing_area => routing_area_glo
topo_resid => topo_resid_glo
route_togrid => route_togrid_glo
route_tobasin => route_tobasin_glo
global_basinid => global_basinid_glo
hydrodiag=>hydrodiag_glo
IF (is_root_prc) CALL routing_diagnostic(nbp_glo,index_g, resolution_g, contfrac_g, nbrivers_g,basinmap_g)
routing_area => routing_area_loc
topo_resid => topo_resid_loc
route_togrid => route_togrid_loc
route_tobasin => route_tobasin_loc
global_basinid => global_basinid_loc
hydrodiag=>hydrodiag_loc
CALL scatter(nbrivers_g,nbrivers)
CALL scatter(basinmap_g,basinmap)
CALL scatter(hydrodiag_glo,hydrodiag_loc)
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'basinmap', 1, basinmap, nbpt, index)
CALL histwrite(hist_id, 'nbrivers', 1, nbrivers, nbpt, index)
ELSE
ENDIF
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist2_id, 'basinmap', 1, basinmap, nbpt, index)
CALL histwrite(hist2_id, 'nbrivers', 1, nbrivers, nbpt, index)
ELSE
ENDIF
ENDIF
END SUBROUTINE routing_diagnostic_p
SUBROUTINE routing_diagnostic(nbpt,index, resolution, contfrac,nbrivers,basinmap)
!
! This subroutine will set up a map of the major basins
!
! INPUTS
!
INTEGER(i_std), INTENT(in) :: nbpt !! Domain size
INTEGER(i_std), INTENT(in) :: index(nbpt) !! Indeces of the points on the map
REAL(r_std), INTENT(in) :: resolution(nbpt,2) !! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) !! Fraction of land in each grid box.
!
! OUTPUTS
!
REAL(r_std), DIMENSION(nbpt), INTENT(out) :: nbrivers !! Number of rivers in the grid
REAL(r_std), DIMENSION(nbpt), INTENT(out) :: basinmap !! Map of basins
!
! LOCAL
!
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: pts !! list the points belonging to the basin
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: ptbas !! list the basin number for this point
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outpt !! Outflow point for each basin
INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nb_pts !! Number of points in the basin
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: totarea !! Total area of basin
INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: topids !! The IDs of the first num_largest basins.
CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: basin_names !! Names of the rivers
CHARACTER(LEN=25) :: name_str
!
INTEGER(i_std) :: ig, ib, og, ob, ign, ibn, ff(1), ic, icc, nb_small
!
ALLOCATE(pts(num_largest, nbpt))
ALLOCATE(ptbas(num_largest, nbpt))
ALLOCATE(outpt(num_largest, 2))
ALLOCATE(nb_pts(num_largest))
ALLOCATE(totarea(num_largest))
ALLOCATE(topids(num_largest))
!
!
! First we get the list of all river outflow points
! We work under the assumption that we only have num_largest basins finishing with
! nbasmax+3. This is checked in routing_truncate.
!
nb_small = 1
outpt(:,:) = -1
ic = 0
DO ig=1,nbpt
DO ib=1,nbasmax
ign = route_togrid(ig, ib)
ibn = route_tobasin(ig, ib)
IF ( ibn .EQ. nbasmax+3) THEN
ic = ic + 1
outpt(ic,1) = ig
outpt(ic,2) = ib
!
! Get the largest id of the basins we call a river. This is
! to extract the names of all rivers.
!
IF ( global_basinid(ig,ib) > nb_small ) THEN
nb_small = global_basinid(ig,ib)
ENDIF
ENDIF
ENDDO
ENDDO
!
nb_small = MIN(nb_small, 349)
!
ALLOCATE(basin_names(nb_small))
!
CALL routing_names(nb_small, basin_names)
!
! Go through all points and basins to see if they outflow as a river and store the
! information needed in the various arrays.
!
nb_pts(:) = 0
totarea(:) = 0.0
hydrodiag(:,:) = 0
DO ig=1,nbpt
DO ib=1,nbasmax
ic = 0
ign = ig
ibn = ib
! Locate outflow point
DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax .AND. ic .LT. nbasmax*nbpt)
ic = ic + 1
og = ign
ob = ibn
ign = route_togrid(og, ob)
ibn = route_tobasin(og, ob)
ENDDO
!
! Now that we have an outflow check if it is one of the num_largest rivers.
! In this case we keeps the location so we diagnose it.
!
IF ( ibn .EQ. nbasmax + 3) THEN
DO icc = 1,num_largest
IF ( outpt(icc,1) .EQ. og .AND. outpt(icc,2) .EQ. ob ) THEN
!
! We only keep this point for our map if it is large enough.
!
IF ( routing_area(ig,ib) .GT. 0.25*resolution(ig,1)*resolution(ig,2)*contfrac(ig) ) THEN
nb_pts(icc) = nb_pts(icc) + 1
pts(icc, nb_pts(icc)) = ig
ptbas(icc, nb_pts(icc)) = ib
ENDIF
totarea(icc) = totarea(icc) + routing_area(ig,ib)
! ID of the river is taken from the last point before the outflow.
topids(icc) = global_basinid(og,ob)
!
! On this gridbox and basin we will diagnose the hydrograph
!
hydrodiag(ig, ib) = 1
!
ENDIF
ENDDO
ENDIF
ENDDO
ENDDO
!
! Construct the map of the largest basins. We take the num_largest basins
! if they have more than 4 points. After that it is of no use.
!
!
basinmap(:) = 0.0
DO icc = 1, num_largest
ff = MAXLOC(totarea)
IF ( nb_pts(ff(1)) .GT. 2 ) THEN
DO ig = 1, nb_pts(ff(1))
basinmap(pts(ff(1),ig)) = REAL(icc,r_std)
ENDDO
!
IF ( topids(ff(1)) .GT. nb_small ) THEN
WRITE(name_str, '("NN, Nb : ",I4)') topids(ff(1))
ELSE
name_str = basin_names(topids(ff(1)))
ENDIF
!
WRITE(numout,&
'("Basin ID ", I5," ", A15, " Area [km^2] : ", F13.4, " Nb points : ", I4)')&
& topids(ff(1)), name_str(1:15), totarea(ff(1))/1.e6, nb_pts(ff(1))
ENDIF
totarea(ff(1)) = 0.0
ENDDO
!
!
nbrivers(:) = 0.0
DO ig=1,nbpt
nbrivers(ig) = COUNT(route_tobasin(ig,1:nbasmax) == nbasmax+3)
ENDDO
DO ig=1,nbpt
IF ( nbrivers(ig) > 1 ) THEN
WRITE(numout,*) 'Grid box ', ig, ' has ', NINT(nbrivers(ig)), ' outflow points.'
WRITE(numout,*) 'The rivers which flow into the ocean at this point are :'
DO icc=1,nbasmax
IF ( route_tobasin(ig,icc) == nbasmax+3) THEN
IF ( global_basinid(ig,icc) <= nb_small ) THEN
WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Name = ', basin_names(global_basinid(ig,icc))
ELSE
WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Problem ===== ID is larger than possible'
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
!
WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
ic = COUNT(topo_resid .GT. 0.)
WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. 0.)/ic
WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. 0.)
!
DEALLOCATE(pts)
DEALLOCATE(outpt)
DEALLOCATE(nb_pts)
DEALLOCATE(totarea)
!
END SUBROUTINE routing_diagnostic
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
!
IMPLICIT NONE
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box.
! INTEGER(i_std) :: neighbours_tmp(nbpt,8)
INTEGER(i_std) :: i,j
! DO i=1,nbp_loc
! DO j=1,8
! IF (neighbours(i,j)==-1) THEN
! neighbours_tmp(i,j)=neighbours(i,j)
! ELSE
! neighbours_tmp(i,j)=neighbours(i,j)+nbp_para_begin(mpi_rank)-1
! ENDIF
! ENDDO
! ENDDO
routing_area => routing_area_glo
topo_resid => topo_resid_glo
route_togrid => route_togrid_glo
route_tobasin => route_tobasin_glo
global_basinid => global_basinid_glo
IF (is_root_prc) CALL routing_basins(nbp_glo,lalo_g, neighbours_g, resolution_g, contfrac_g)
routing_area => routing_area_loc
topo_resid => topo_resid_loc
route_togrid => route_togrid_loc
route_tobasin => route_tobasin_loc
global_basinid => global_basinid_loc
CALL scatter(routing_area_glo,routing_area_loc)
CALL scatter(topo_resid_glo,topo_resid_loc)
CALL scatter(route_togrid_glo,route_togrid_loc)
CALL scatter(route_tobasin_glo,route_tobasin_loc)
CALL scatter(global_basinid_glo,global_basinid_loc)
END SUBROUTINE routing_basins_p
SUBROUTINE routing_basins(nbpt, lalo, neighbours, resolution, contfrac)
!
IMPLICIT NONE
!
!
! This subroutine reads in the map of basins and flow direction to construct the
! the catchments of each grid box.
!
! The work is done in a number of steps which are performed locally on the
! GCM grid:
! 1) First we find the grid-points of the high resolution routing grid which are
! within the coarser grid of GCM.
! 2) When we have these grid points we decompose them into basins in the routine
! routing_findbasins. A number of simplifications are done if needed.
! 3) In the routine routing_globalize we put the basin information of this grid
! into global fields.
! Then we work on the global grid to perform the following tasks :
! 1) We linkup the basins of the various and check the global consistence.
! 2) The area of each outflow point is computed.
! 3) The final step is to reduce the number of basins in order to fit into the truncation.
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box.
!
!
! 0.3 LOCAL
!
REAL(r_std), PARAMETER :: R_Earth = 6378000.
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt, lastjp, nbexp
REAL(r_std) :: lev(1), date, dt, coslat, pi
INTEGER(i_std) :: itau(1), sgn
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: trip, basins, topoindex, hierarchy
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel, lon_rel, lat_ful, lon_ful
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: loup_rel, lolow_rel, laup_rel, lalow_rel
REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
!
INTEGER(i_std) :: nbi, nbj
REAL(r_std) :: ax, ay, min_topoind, max_basins, invented_basins
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index
INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sub_pts
REAL(r_std), DIMENSION(nbvmax,nbvmax) :: area_bx, hierarchy_bx, lon_bx, lat_bx, topoind_bx
INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_bx, basin_bx
!
INTEGER(i_std) :: coast_pts(nbvmax)
REAL(r_std) :: lonrel, louprel, lolowrel
!
INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: basin_count
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_id
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: basin_area, basin_hierarchy, basin_topoind
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: fetch_basin
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: basin_flowdir
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_grid
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: outflow_basin
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: inflow_number
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_basin, inflow_grid
INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: nbcoastal
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: coastal_basin
!
INTEGER(i_std) :: nb_basin, nwbas
INTEGER(i_std) :: basin_inbxid(nbvmax), basin_sz(nbvmax), basin_pts(nbvmax,nbvmax,2), basin_bxout(nbvmax)
CHARACTER(LEN=7) :: fmt
LOGICAL :: debug = .FALSE.
INTEGER(i_std), DIMENSION(2) :: diagbox = (/ 1147, 1148 /)
! Test on diagbox and nbpt
IF (debug) THEN
IF (ANY(diagbox .GT. nbpt)) THEN
WRITE(*,*) "Debug diganostics : nbpt, diagbox", nbpt, diagbox
call ipslerr(3,'routing_basin', &
& 'Problem with diagbox in debug mode.', &
& 'diagbox values can''t be greater than land points number.', &
& '(decrease diagbox wrong value)')
ENDIF
ENDIF
!
pi = 4. * ATAN(1.)
!
! Needs to be a configurable variable
!
!
!Config Key = ROUTING_FILE
!Config Desc = Name of file which contains the routing information
!Config Def = routing.nc
!Config Help = The file provided here should alow the routing module to
!Config read the high resolution grid of basins and the flow direction
!Config from one mesh to the other.
!
filename = 'routing.nc'
CALL getin('ROUTING_FILE',filename)
!
CALL flininfo(filename,iml, jml, lml, tml, fid)
!
!
ALLOCATE (lat_rel(iml,jml))
ALLOCATE (lon_rel(iml,jml))
ALLOCATE (laup_rel(iml,jml))
ALLOCATE (loup_rel(iml,jml))
ALLOCATE (lalow_rel(iml,jml))
ALLOCATE (lolow_rel(iml,jml))
ALLOCATE (lat_ful(iml+2,jml+2))
ALLOCATE (lon_ful(iml+2,jml+2))
ALLOCATE (trip(iml,jml))
ALLOCATE (basins(iml,jml))
ALLOCATE (topoindex(iml,jml))
ALLOCATE (hierarchy(iml,jml))
!
ALLOCATE (sub_area(nbpt,nbvmax))
ALLOCATE (sub_index(nbpt,nbvmax,2))
ALLOCATE (sub_pts(nbpt))
!
!
CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
!
! The trip field follows the following convention for the flow of the water :
! trip = 1 : flow = N
! trip = 2 : flow = NE
! trip = 3 : flow = E
! trip = 4 : flow = SE
! trip = 5 : flow = S
! trip = 6 : flow = SW
! trip = 7 : flow = W
! trip = 8 : flow = NW
! trip = 97 : return flow into the ground
! trip = 98 : coastal flow (diffuse flow into the oceans)
! trip = 99 : river flow into the oceans
!
!
CALL flinget(fid, 'trip', iml, jml, lml, tml, 1, 1, trip)
!
CALL flinget(fid, 'basins', iml, jml, lml, tml, 1, 1, basins)
!
CALL flinget(fid, 'topoind', iml, jml, lml, tml, 1, 1, topoindex)
!
CALL flinclo(fid)
!
nbexp = 0
!
min_topoind = MINVAL(topoindex, MASK=topoindex .LT. undef_sechiba-1.)
!
DO ip=1,iml
DO jp=1,jml
IF ( trip(ip,jp) .LT. 1.e10 .AND. topoindex(ip,jp) .GT. 1.e10) THEN
WRITE(numout,*) 'trip exists but not topoind :'
WRITE(numout,*) 'ip, jp :', ip, jp
WRITE(numout,*) 'trip, topoind : ', trip(ip,jp), topoindex(ip,jp)
STOP
ENDIF
ENDDO
ENDDO
!
! Duplicate the border assuming we have a global grid going from west to east
!
lon_ful(2:iml+1,2:jml+1) = lon_rel(1:iml,1:jml)
lat_ful(2:iml+1,2:jml+1) = lat_rel(1:iml,1:jml)
!
IF ( lon_rel(iml,1) .LT. lon_ful(2,2)) THEN
lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)
lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
ELSE
lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)-360
lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
ENDIF
IF ( lon_rel(1,1) .GT. lon_ful(iml+1,2)) THEN
lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)
lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
ELSE
lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)+360
lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
ENDIF
!
sgn = INT(lat_rel(1,1)/ABS(lat_rel(1,1)))
lat_ful(2:iml+1,1) = sgn*180 - lat_rel(1:iml,1)
sgn = INT(lat_rel(1,jml)/ABS(lat_rel(1,jml)))
lat_ful(2:iml+1,jml+2) = sgn*180 - lat_rel(1:iml,jml)
lat_ful(1,1) = lat_ful(iml+1,1)
lat_ful(iml+2,1) = lat_ful(2,1)
lat_ful(1,jml+2) = lat_ful(iml+1,jml+2)
lat_ful(iml+2,jml+2) = lat_ful(2,jml+2)
!
! Add the longitude lines to the top and bottom
!
lon_ful(:,1) = lon_ful(:,2)
lon_ful(:,jml+2) = lon_ful(:,jml+1)
!
! Get the upper and lower limits of each grid box
!
DO ip=1,iml
DO jp=1,jml
!
loup_rel(ip,jp) =MAX(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)),&
& 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
lolow_rel(ip,jp) =MIN(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)),&
& 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
laup_rel(ip,jp) =MAX(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)),&
& 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
lalow_rel(ip,jp) =MIN(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)),&
& 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
!
ENDDO
ENDDO
!
!
!
! Now we take each grid point and find out which values from the forcing we need to average
!
DO ib =1, nbpt
!
! We find the 4 limits of the grid-box. As we transform the resolution of the model
! into longitudes and latitudes we do not have the problem of periodicity.
! coslat is a help variable here !
!
coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
!
lon_up = lalo(ib,2) + resolution(ib,1)/(2.0*coslat)
lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
!
lat_up =lalo(ib,1) + resolution(ib,2)/(2.0*coslat)
lat_low =lalo(ib,1) - resolution(ib,2)/(2.0*coslat)
!
!
! Find the grid boxes from the data that go into the model's boxes
! We still work as if we had a regular grid ! Well it needs to be localy regular so
! so that the longitude at the latitude of the last found point is close to the one of the next point.
!
fopt = 0
lastjp = 1
DO ip=1,iml
!
! Either the center of the data grid point is in the interval of the model grid or
! the East and West limits of the data grid point are on either sides of the border of
! the data grid.
!
! To do that correctly we have to check if the grid box sits on the date-line.
!
IF ( lon_low < -180.0 ) THEN
lonrel = MOD( lon_rel(ip,lastjp) - 360.0, 360.0)
lolowrel = MOD( lolow_rel(ip,lastjp) - 360.0, 360.0)
louprel = MOD( loup_rel(ip,lastjp) - 360.0, 360.0)
!
ELSE IF ( lon_up > 180.0 ) THEN
lonrel = MOD( 360. - lon_rel(ip,lastjp), 360.0)
lolowrel = MOD( 360. - lolow_rel(ip,lastjp), 360.0)
louprel = MOD( 360. - loup_rel(ip,lastjp), 360.0)
ELSE
lonrel = lon_rel(ip,lastjp)
lolowrel = lolow_rel(ip,lastjp)
louprel = loup_rel(ip,lastjp)
ENDIF
!
!
!
IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
& lolowrel < lon_low .AND. louprel > lon_low .OR. &
& lolowrel < lon_up .AND. louprel > lon_up ) THEN
!
DO jp = 1, jml
!
! Now that we have the longitude let us find the latitude
!
IF ( lat_rel(ip,jp) > lat_low .AND. lat_rel(ip,jp) < lat_up .OR. &
& lalow_rel(ip,jp) < lat_low .AND. laup_rel(ip,jp) > lat_low .OR.&
& lalow_rel(ip,jp) < lat_up .AND. laup_rel(ip,jp) > lat_up) THEN
!
lastjp = jp
!
! Is it a land point ?
!
IF (trip(ip,jp) .LT. 1.e10) THEN
!
fopt = fopt + 1
IF ( fopt .GT. nbvmax) THEN
WRITE(numout,*) 'Please increase nbvmax in subroutine routing_basins', ib
STOP
ELSE
!
! If we sit on the date line we need to do the same transformations as above.
!
IF ( lon_low < -180.0 ) THEN
lolowrel = MOD( lolow_rel(ip,jp) - 360.0, 360.0)
louprel = MOD( loup_rel(ip,jp) - 360.0, 360.0)
!
ELSE IF ( lon_up > 180.0 ) THEN
lolowrel = MOD( 360. - lolow_rel(ip,jp), 360.0)
louprel = MOD( 360. - loup_rel(ip,jp), 360.0)
ELSE
lolowrel = lolow_rel(ip,jp)
louprel = loup_rel(ip,jp)
ENDIF
!
! Get the area of the fine grid in the model grid
!
coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), 0.001 )
ax = (MIN(lon_up,louprel)-MAX(lon_low, lolowrel))*pi/180. * R_Earth * coslat
ay = (MIN(lat_up, laup_rel(ip,jp))-MAX(lat_low,lalow_rel(ip,jp)))*pi/180. * R_Earth
sub_area(ib, fopt) = ax*ay
sub_index(ib, fopt, 1) = ip
sub_index(ib, fopt, 2) = jp
ENDIF
ENDIF
!
sub_pts(ib) = fopt
!
ENDIF
!
ENDDO
!
ENDIF
!
ENDDO
!
!
ENDDO
!
! Do some memory management.
!
DEALLOCATE (laup_rel)
DEALLOCATE (loup_rel)
DEALLOCATE (lalow_rel)
DEALLOCATE (lolow_rel)
DEALLOCATE (lat_ful)
DEALLOCATE (lon_ful)
!
nwbas = MAXVAL(sub_pts)
!
ALLOCATE (basin_count(nbpt))
ALLOCATE (basin_area(nbpt,nwbas), basin_hierarchy(nbpt,nwbas), basin_topoind(nbpt,nwbas))
ALLOCATE (fetch_basin(nbpt,nwbas))
ALLOCATE (basin_id(nbpt,nwbas), basin_flowdir(nbpt,nwbas))
ALLOCATE (outflow_grid(nbpt,nwbas),outflow_basin(nbpt,nwbas))
ALLOCATE (inflow_number(nbpt,nwbas))
ALLOCATE (inflow_basin(nbpt,nwbas,nbvmax), inflow_grid(nbpt,nwbas,nbvmax))
ALLOCATE (nbcoastal(nbpt), coastal_basin(nbpt,nwbas))
!
! Order all sub points in each grid_box and find the sub basins
!
! before we start we set the maps to empty
!
basin_id(:,:) = undef_int
basin_count(:) = 0
hierarchy(:,:) = undef_sechiba
max_basins = MAXVAL(basins, MASK=basins .LT. 1.e10)
invented_basins = max_basins
nbcoastal(:) = 0
!
CALL routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
!
!
DO ib =1, nbpt
!
!
! Set everything to undef to locate easily empty points
!
trip_bx(:,:) = undef_int
basin_bx(:,:) = undef_int
topoind_bx(:,:) = undef_sechiba
area_bx(:,:) = undef_sechiba
hierarchy_bx(:,:) = undef_sechiba
!
! extract the information for this grid box
!
CALL routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
!
CALL routing_findbasins(nbi, nbj, trip_bx, basin_bx, hierarchy_bx, topoind_bx,&
& nb_basin, basin_inbxid, basin_sz, basin_bxout, basin_pts, coast_pts)
!
! Deal with the case where nb_basin=0 for this grid box. In this case all goes into coatal flow
!
IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
WRITE(numout,*) '===================== IB = :', ib
WRITE(numout,*) "sub_pts(ib) :", sub_pts(ib)
WRITE(numout,*) 'LON LAT of GCM :', lalo(ib,2), lalo(ib,1)
WRITE(numout,*) 'Neighbor options :', neighbours(ib,1:8)
WRITE(numout,*) 'Resolution :', resolution(ib,1:2)
WRITE(fmt,"('(',I3,'I6)')") nbi
WRITE(numout,*) '-------------> trip ', trip_bx(1,1)
DO jp=1,nbj
WRITE(numout,fmt) trip_bx(1:nbi,jp)
ENDDO
WRITE(numout,*) '-------------> basin ',basin_bx(1,1)
DO jp=1,nbj
WRITE(numout,fmt) basin_bx(1:nbi,jp)
ENDDO
WRITE(numout,*) '-------------> hierarchy ',hierarchy_bx(1,1)
DO jp=1,nbj
WRITE(numout,fmt) INT(hierarchy_bx(1:nbi,jp)/1000.)
ENDDO
WRITE(numout,*) '-------------> topoindex ',topoind_bx(1,1)
DO jp=1,nbj
WRITE(numout,fmt) INT(topoind_bx(1:nbi,jp)/1000.)
ENDDO
!
WRITE(numout,*) '------------> The basins we retain'
DO jp=1,nb_basin
WRITE(numout,*) 'index, size, bxout, coast :', basin_inbxid(jp), basin_sz(jp),&
& basin_bxout(jp), coast_pts(jp)
ENDDO
!
ENDIF
!
CALL routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
& nbcoastal, coastal_basin)
!
IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
WRITE(numout,*) 'GLOBAL information after routing_globalize for grid ', ib
DO jp=1,basin_count(ib)
WRITE(numout,*) 'Basin ID : ', basin_id(ib, jp)
WRITE(numout,*) 'Basin flowdir :', basin_flowdir(ib, jp)
WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(ib, jp)
WRITE(numout,*) 'Basin topoindex :', basin_topoind(ib, jp)
WRITE(numout,*) 'Basin outflow grid :', outflow_grid(ib,jp)
ENDDO
ENDIF
!
ENDDO
!
CALL routing_linkup(nbpt, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
& basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, &
& nbcoastal, coastal_basin, invented_basins)
!
WRITE(numout,*) 'The maximum number of basins in any grid :', MAXVAL(basin_count)
!
IF ( debug ) THEN
DO ib=1,SIZE(diagbox)
IF ( diagbox(ib) .GT. 0 ) THEN
WRITE(numout,*) 'After routing_linkup information for grid ', diagbox(ib)
DO jp=1,basin_count(diagbox(ib))
WRITE(numout,*) 'Basin ID : ', basin_id(diagbox(ib), jp)
WRITE(numout,*) 'Basin outflow_grid :', outflow_grid(diagbox(ib), jp)
WRITE(numout,*) 'Basin outflow_basin:', outflow_basin(diagbox(ib), jp)
WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(diagbox(ib), jp)
ENDDO
ENDIF
ENDDO
ENDIF
!
CALL routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id, outflow_grid, &
& outflow_basin, fetch_basin)
!
WRITE(numout,*) "Start reducing the number of basins per grid to meet the required truncation."
!
CALL routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
& inflow_grid, inflow_basin)
!
DEALLOCATE (lat_rel)
DEALLOCATE (lon_rel)
!
DEALLOCATE (trip)
DEALLOCATE (basins)
DEALLOCATE (topoindex)
DEALLOCATE (hierarchy)
!
DEALLOCATE (sub_area)
DEALLOCATE (sub_index)
DEALLOCATE (sub_pts)
!
DEALLOCATE (basin_count)
DEALLOCATE (basin_area, basin_hierarchy, basin_topoind, fetch_basin)
DEALLOCATE (basin_id, basin_flowdir)
DEALLOCATE (outflow_grid,outflow_basin)
DEALLOCATE (inflow_number)
DEALLOCATE (inflow_basin, inflow_grid)
DEALLOCATE (nbcoastal, coastal_basin)
!
RETURN
!
END SUBROUTINE routing_basins
!
!-----------------------------------------------------------------------
!
SUBROUTINE routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
& lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
& nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
!
IMPLICIT NONE
!
! Extracts from the global high resolution fields the data for the current grid box
! we are dealing with.
!
! Convention for trip on the input :
! The trip field follows the following convention for the flow of the water :
! trip = 1 : flow = N
! trip = 2 : flow = NE
! trip = 3 : flow = E
! trip = 4 : flow = SE
! trip = 5 : flow = S
! trip = 6 : flow = SW
! trip = 7 : flow = W
! trip = 8 : flow = NW
! trip = 97 : return flow into the ground
! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here
! trip = 99 : river flow into the oceans
!
! On output, the grid boxes of the basin map which flow out of the GCM grid are identified
! by numbers larger than 100 :
! trip = 101 : flow = N out of the coarse grid
! trip = 102 : flow = NE out of the coarse grid
! trip = 103 : flow = E out of the coarse grid
! trip = 104 : flow = SE out of the coarse grid
! trip = 105 : flow = S out of the coarse grid
! trip = 106 : flow = SW out of the coarse grid
! trip = 107 : flow = W out of the coarse grid
! trip = 108 : flow = NW out of the coarse grid
! Inside the grid the convention remains the same as above (ie between 1 and 99).
!
! INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points in the global grid
INTEGER(i_std), INTENT(in) :: iml, jml ! Resolution of the high resolution grid
INTEGER(i_std), INTENT(in) :: ib ! point we are currently dealing with
INTEGER(i_std), INTENT(in) :: sub_pts(nbpt) ! Number of high resiolution points on this grid
INTEGER(i_std), INTENT(in) :: sub_index(nbpt, nbvmax,2) ! indeces of the points we need on the fine grid
REAL(r_std), INTENT(inout) :: max_basins ! The current maximum of basins
REAL(r_std), INTENT(in) :: min_topoind ! The current maximum of topographic index
REAL(r_std), INTENT(in) :: sub_area(nbpt, nbvmax) ! area on the fine grid
REAL(r_std), INTENT(in) :: lon_rel(iml, jml), lat_rel(iml, jml) ! coordinates of the fine grid
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box.
REAL(r_std), INTENT(inout) :: trip(iml, jml), basins(iml, jml) ! data on the fine grid
REAL(r_std), INTENT(inout) :: topoindex(iml, jml), hierarchy(iml, jml) ! data on the fine grid
INTEGER(i_std), INTENT(out):: nbi, nbj ! Number of point ion x and y within the grid
REAL(r_std), INTENT(out) :: area_bx(nbvmax,nbvmax), hierarchy_bx(nbvmax,nbvmax)
REAL(r_std), INTENT(out) :: lon_bx(nbvmax,nbvmax), lat_bx(nbvmax,nbvmax), topoind_bx(nbvmax,nbvmax)
INTEGER(i_std), INTENT(out):: trip_bx(nbvmax,nbvmax), basin_bx(nbvmax,nbvmax)
!
! LOCAL
!
INTEGER(i_std) :: ip, jp, ll(1), iloc, jloc
REAL(r_std) :: lonstr(nbvmax*nbvmax), latstr(nbvmax*nbvmax)
!
IF ( sub_pts(ib) > 0 ) THEN
!
DO ip=1,sub_pts(ib)
lonstr(ip) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
latstr(ip) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
ENDDO
!
! Get the size of the area and order the coordinates to go from North to South and West to East
!
CALL routing_sortcoord(sub_pts(ib), lonstr, 'WE', nbi)
CALL routing_sortcoord(sub_pts(ib), latstr, 'NS', nbj)
!
! Transfer the data in such a way that (1,1) is the North Western corner and
! (nbi, nbj) the South Eastern.
!
DO ip=1,sub_pts(ib)
ll = MINLOC(ABS(lonstr(1:nbi) - lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
iloc = ll(1)
ll = MINLOC(ABS(latstr(1:nbj) - lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
jloc = ll(1)
trip_bx(iloc, jloc) = NINT(trip(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
basin_bx(iloc, jloc) = NINT(basins(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
area_bx(iloc, jloc) = sub_area(ib, ip)
topoind_bx(iloc, jloc) = topoindex(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
hierarchy_bx(iloc, jloc) = hierarchy(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
lon_bx(iloc, jloc) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
lat_bx(iloc, jloc) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
ENDDO
ELSE
!
! This is the case where the model invented a continental point
!
nbi = 1
nbj = 1
iloc = 1
jloc = 1
trip_bx(iloc, jloc) = 98
basin_bx(iloc, jloc) = NINT(max_basins + 1)
max_basins = max_basins + 1
area_bx(iloc, jloc) = resolution(ib,1)*resolution(ib,2)*contfrac(ib)
topoind_bx(iloc, jloc) = min_topoind
hierarchy_bx(iloc, jloc) = min_topoind
lon_bx(iloc, jloc) = lalo(ib,2)
lat_bx(iloc, jloc) = lalo(ib,1)
!
ENDIF
!
! Tag in trip all the outflow conditions. The table is thus :
! trip = 100+n : Outflow into another grid-box
! trip = 99 : River outflow into the ocean
! trip = 98 : This will be coastal flow (not organized as a basin)
! trip = 97 : return flow into the soil (local)
!
DO jp=1,nbj
IF ( trip_bx(1,jp) .EQ. 8 .OR. trip_bx(1,jp) .EQ. 7 .OR. trip_bx(1,jp) .EQ. 6) THEN
trip_bx(1,jp) = trip_bx(1,jp) + 100
ENDIF
IF ( trip_bx(nbi,jp) .EQ. 2 .OR. trip_bx(nbi,jp) .EQ. 3 .OR. trip_bx(nbi,jp) .EQ. 4) THEN
trip_bx(nbi,jp) = trip_bx(nbi,jp) + 100
ENDIF
ENDDO
DO ip=1,nbi
IF ( trip_bx(ip,1) .EQ. 8 .OR. trip_bx(ip,1) .EQ. 1 .OR. trip_bx(ip,1) .EQ. 2) THEN
trip_bx(ip,1) = trip_bx(ip,1) + 100
ENDIF
IF ( trip_bx(ip,nbj) .EQ. 6 .OR. trip_bx(ip,nbj) .EQ. 5 .OR. trip_bx(ip,nbj) .EQ. 4) THEN
trip_bx(ip,nbj) = trip_bx(ip,nbj) + 100
ENDIF
ENDDO
!
!
! We simplify the outflow. We only need the direction normal to the
! box boundary and the 4 corners.
!
! Northern border
IF ( trip_bx(1,1) .EQ. 102 ) trip_bx(1,1) = 101
IF ( trip_bx(nbi,1) .EQ. 108 ) trip_bx(nbi,1) = 101
DO ip=2,nbi-1
IF ( trip_bx(ip,1) .EQ. 108 .OR. trip_bx(ip,1) .EQ. 102 ) trip_bx(ip,1) = 101
ENDDO
! Southern border
IF ( trip_bx(1,nbj) .EQ. 104 ) trip_bx(1,nbj) = 105
IF ( trip_bx(nbi,nbj) .EQ. 106 ) trip_bx(nbi,nbj) = 105
DO ip=2,nbi-1
IF ( trip_bx(ip,nbj) .EQ. 104 .OR. trip_bx(ip,nbj) .EQ. 106 ) trip_bx(ip,nbj) = 105
ENDDO
! Eastern border
IF ( trip_bx(nbi,1) .EQ. 104) trip_bx(nbi,1) = 103
IF ( trip_bx(nbi,nbj) .EQ. 102) trip_bx(nbi,nbj) = 103
DO jp=2,nbj-1
IF ( trip_bx(nbi,jp) .EQ. 104 .OR. trip_bx(nbi,jp) .EQ. 102 ) trip_bx(nbi,jp) = 103
ENDDO
! Western border
IF ( trip_bx(1,1) .EQ. 106) trip_bx(1,1) = 107
IF ( trip_bx(1,nbj) .EQ. 108) trip_bx(1,nbj) = 107
DO jp=2,nbj-1
IF ( trip_bx(1,jp) .EQ. 106 .OR. trip_bx(1,jp) .EQ. 108 ) trip_bx(1,jp) = 107
ENDDO
!
!
END SUBROUTINE routing_getgrid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
SUBROUTINE routing_sortcoord(nb_in, coords, direction, nb_out)
!
IMPLICIT NONE
!
! Input/Output
!
INTEGER(i_std), INTENT(in) :: nb_in
REAL(r_std), INTENT(inout) :: coords(nb_in)
CHARACTER(LEN=2) :: direction
INTEGER(i_std), INTENT(out) :: nb_out
!
! Local
!
INTEGER(i_std) :: ipos
REAL(r_std) :: coords_tmp(nb_in)
INTEGER(i_std), DIMENSION(1) :: ll
INTEGER(i_std) :: ind(nb_in)
!
ipos = 1
nb_out = nb_in
!
! Compress the coordinates array
!
DO WHILE ( ipos < nb_in )
IF ( coords(ipos+1) /= undef_sechiba) THEN
IF ( COUNT(coords(ipos:nb_out) == coords(ipos)) > 1 ) THEN
coords(ipos:nb_out-1) = coords(ipos+1:nb_out)
coords(nb_out:nb_in) = undef_sechiba
nb_out = nb_out - 1
ELSE
ipos = ipos + 1
ENDIF
ELSE
EXIT
ENDIF
ENDDO
!
! Sort it now
!
! First we get ready and adjust for the periodicity in longitude
!
coords_tmp(:) = undef_sechiba
IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'EW') == 1) THEN
IF ( MAXVAL(ABS(coords(1:nb_out))) .GT. 160 ) THEN
coords_tmp(1:nb_out) = MOD(coords(1:nb_out) + 360.0, 360.0)
ELSE
coords_tmp(1:nb_out) = coords(1:nb_out)
ENDIF
ELSE IF ( INDEX(direction, 'NS') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
coords_tmp(1:nb_out) = coords(1:nb_out)
ELSE
WRITE(numout,*) 'The chosen direction (', direction,') is not recognized'
STOP 'routing_sortcoord'
ENDIF
!
! Get it sorted out now
!
ipos = 1
!
IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
ll = MINLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
ind(ipos) = ll(1)
coords_tmp(ll(1)) = undef_sechiba
ipos = ipos + 1
ENDDO
ELSE IF ( INDEX(direction, 'EW') == 1 .OR. INDEX(direction, 'NS') == 1) THEN
DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
ll = MAXLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
ind(ipos) = ll(1)
coords_tmp(ll(1)) = undef_sechiba
ipos = ipos + 1
ENDDO
ELSE
WRITE(numout,*) 'The chosen direction (', direction,') is not recognized (second)'
STOP 'routing_sortcoord'
ENDIF
!
coords(1:nb_out) = coords(ind(1:nb_out))
IF (nb_out < nb_in) THEN
coords(nb_out+1:nb_in) = zero
ENDIF
!
END SUBROUTINE routing_sortcoord
!
!-------------------------------------------------------------------------------------------------
!
SUBROUTINE routing_findbasins(nbi, nbj, trip, basin, hierarchy, topoind, nb_basin, basin_inbxid, basin_sz,&
& basin_bxout, basin_pts, coast_pts)
!
IMPLICIT NONE
!
! This subroutine find the basins and does some clean up. The aim is to return the list off all
! points which are within the same basin of the grid_box.
! We will also collect all points which directly flow into the ocean in one basin
! Make sure that we do not have a basin with two outflows and other exceptions.
!
! At this stage no effort is made to come down to the truncation of the model.
!
! Convention for trip
! -------------------
! Inside of the box :
! trip = 1 : flow = N
! trip = 2 : flow = NE
! trip = 3 : flow = E
! trip = 4 : flow = SE
! trip = 5 : flow = S
! trip = 6 : flow = SW
! trip = 7 : flow = W
! trip = 8 : flow = NW
! trip = 97 : return flow into the ground
! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here
! trip = 99 : river flow into the oceans
!
! Out flow from the gird :
! trip = 101 : flow = N out of the coarse grid
! trip = 102 : flow = NE out of the coarse grid
! trip = 103 : flow = E out of the coarse grid
! trip = 104 : flow = SE out of the coarse grid
! trip = 105 : flow = S out of the coarse grid
! trip = 106 : flow = SW out of the coarse grid
! trip = 107 : flow = W out of the coarse grid
! trip = 108 : flow = NW out of the coarse grid
!
! Inputs
!
INTEGER(i_std) :: nbi, nbj
INTEGER(i_std) :: trip(:,:), basin(:,:)
REAL(r_std) :: hierarchy(:,:), topoind(:,:)
!
! Outputs
!
INTEGER(i_std) :: nb_basin
INTEGER(i_std) :: basin_inbxid(nbvmax), basin_sz(nbvmax), basin_bxout(nbvmax)
INTEGER(i_std) :: basin_pts(nbvmax, nbvmax, 2)
INTEGER(i_std) :: coast_pts(nbvmax)
!
! Local
!
INTEGER(i_std) :: ibas, ilf, nbb, nb_in
INTEGER(i_std) :: bname(nbvmax), sz(nbvmax), pts(nbvmax,nbvmax,2), nbout(nbvmax)
INTEGER(i_std) :: new_nb, new_bname(nbvmax), new_sz(nbvmax), new_pts(nbvmax,nbvmax,2)
INTEGER(i_std) :: itrans, trans(nbvmax), outdir(nbvmax)
INTEGER(i_std) :: tmpsz(nbvmax)
INTEGER(i_std) :: ip, jp, jpp(1), ipb
INTEGER(i_std) :: sortind(nbvmax)
CHARACTER(LEN=7) :: fmt
!
nbb = 0
bname(:) = undef_int
sz(:) = 0
nbout(:) = 0
new_pts(:,:,:) = 0
!
! 1.0 Find all basins within this grid-box
! Sort the variables per basin so that we can more easily
! access data from the same basin (The variables are :
! bname, sz, pts, nbout)
!
DO ip=1,nbi
DO jp=1,nbj
IF ( basin(ip,jp) .LT. undef_int) THEN
IF ( COUNT(basin(ip,jp) .EQ. bname(:)) .EQ. 0 ) THEN
nbb = nbb + 1
IF ( nbb .GT. nbvmax ) STOP 'nbvmax too small'
bname(nbb) = basin(ip,jp)
sz(nbb) = 0
ENDIF
!
DO ilf=1,nbb
IF ( basin(ip,jp) .EQ. bname(ilf) ) THEN
ibas = ilf
ENDIF
ENDDO
!
sz(ibas) = sz(ibas) + 1
IF ( sz(ibas) .GT. nbvmax ) STOP 'nbvmax too small'
pts(ibas, sz(ibas), 1) = ip
pts(ibas, sz(ibas), 2) = jp
! We deal only with outflow and leave flow back into the grid-box for later.
IF ( trip(ip,jp) .GE. 97 ) THEN
nbout(ibas) = nbout(ibas) + 1
ENDIF
!
ENDIF
!
ENDDO
ENDDO
!
! 2.0 All basins which have size 1 and flow to the ocean are put together.
!
itrans = 0
coast_pts(:) = undef_int
! Get all the points we can collect
DO ip=1,nbb
IF ( sz(ip) .EQ. 1 .AND. trip(pts(ip,1,1),pts(ip,1,2)) .EQ. 99) THEN
itrans = itrans + 1
trans(itrans) = ip
trip(pts(ip,1,1),pts(ip,1,2)) = 98
ENDIF
ENDDO
! put everything in the first basin
IF ( itrans .GT. 1) THEN
ipb = trans(1)
coast_pts(sz(ipb)) = bname(ipb)
bname(ipb) = -1
DO ip=2,itrans
sz(ipb) = sz(ipb) + 1
coast_pts(sz(ipb)) = bname(trans(ip))
sz(trans(ip)) = 0
pts(ipb, sz(ipb), 1) = pts(trans(ip), 1, 1)
pts(ipb, sz(ipb), 2) = pts(trans(ip), 1, 2)
ENDDO
ENDIF
!
! 3.0 Make sure that we have only one outflow point in each basin
!
! nbb is the number of basins on this grid box.
new_nb = 0
DO ip=1,nbb
! We only do this for grid-points which have more than one outflow
IF ( sz(ip) .GT. 1 .AND. nbout(ip) .GT. 1) THEN
!
! Pick up all points needed and store them in trans
!
itrans = 0
DO jp=1,sz(ip)
IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 97) THEN
itrans = itrans + 1
trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
ENDIF
ENDDO
!
! First issue : We have more than one point of the basin which flows into
! the ocean. In this case we put everything into coastal flow. It will go into
! a separate basin in the routing_globalize routine.
!
IF ( (COUNT(trans(1:itrans) .EQ. 99) + COUNT(trans(1:itrans) .EQ. 98)) .GT. 1) THEN
DO jp=1,sz(ip)
IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .EQ. 99 ) THEN
trip(pts(ip,jp,1),pts(ip,jp,2)) = 98
trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
ENDIF
ENDDO
ENDIF
!
! Second issue : We have redundant outflows at the boundaries. That is two small grid
! boxes flowing into the same GCM grid box.
!
IF ( COUNT(trans(1:itrans) .GT. 100) .GE. 1) THEN
CALL routing_simplify(nbi, nbj, trip, basin, hierarchy, bname(ip))
itrans = 0
DO jp=1,sz(ip)
IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 9) THEN
itrans = itrans + 1
trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
ENDIF
ENDDO
ENDIF
!
! Third issue : we have more than one outflow from the boxes. This could be
! - flow into 2 or more neighboring GCM grids
! - flow into a neighboring GCM grids and into the ocean or be a return flow (=97. =98, =99)
! - flow into a neighboring GCM grids or ocean and back into the same GCM grid box
! The only solution is to cut the basin up in as many parts.
!
IF ( COUNT(trans(1:itrans) .GE. 97) .GT. 1) THEN
!
nb_in = new_nb
CALL routing_cutbasin(nbi, nbj, nbb, trip, basin, bname(ip), new_nb, new_bname, new_sz, new_pts)
!
! If we have split the basin then we need to cancel the old one
!
IF ( nb_in .NE. new_nb) THEN
sz(ip) = 0
ENDIF
!
ENDIF
!
ENDIF
ENDDO
!
! Add the new basins to the end of the list
!
If ( nbb+new_nb .LE. nbvmax) THEN
DO ip=1,new_nb
bname(nbb+ip) = new_bname(ip)
sz(nbb+ip) = new_sz(ip)
pts(nbb+ip,:,:) = new_pts(ip,:,:)
ENDDO
nbb = nbb+new_nb
ELSE
WRITE(numout,*) 'Increase nbvmax. It is too small to contain all the basins (routing_findbasins)'
STOP
ENDIF
!
! Keep the output direction
!
DO ip=1,nbb
IF ( sz(ip) .GT. 0 ) THEN
trans(:) = 0
DO jp=1,sz(ip)
trans(jp) = trip(pts(ip,jp,1),pts(ip,jp,2))
ENDDO
outdir(ip) = MAXVAL(trans(1:sz(ip)))
IF ( outdir(ip) .GE. 97 ) THEN
outdir(ip) = outdir(ip) - 100
ELSE
WRITE(numout,*) 'Why are we here and can not find a trip larger than 96'
WRITE(numout,*) 'Does this mean that the basin does not have any outflow ', ip, bname(ip)
WRITE(fmt,"('(',I3,'I9)')") nbi
WRITE(numout,*) '-----------------------> trip'
DO jp=1,nbj
WRITE(numout,fmt) trip(1:nbi,jp)
ENDDO
WRITE(numout,*) '-----------------------> basin'
DO jp=1,nbj
WRITE(numout,fmt) basin(1:nbi,jp)
ENDDO
STOP 'SUBROUTINE : routing_findbasins'
ENDIF
ENDIF
ENDDO
!
!
! Sort the output by size of the various basins.
!
nb_basin = COUNT(sz(1:nbb) .GT. 0)
tmpsz(:) = -1
tmpsz(1:nbb) = sz(1:nbb)
DO ip=1,nbb
jpp = MAXLOC(tmpsz(:))
IF ( sz(jpp(1)) .GT. 0) THEN
sortind(ip) = jpp(1)
tmpsz(jpp(1)) = -1
ENDIF
ENDDO
basin_inbxid(1:nb_basin) = bname(sortind(1:nb_basin))
basin_sz(1:nb_basin) = sz(sortind(1:nb_basin))
basin_pts(1:nb_basin,:,:) = pts(sortind(1:nb_basin),:,:)
basin_bxout(1:nb_basin) = outdir(sortind(1:nb_basin))
!
! We can only check if we have at least as many outflows as basins
!
ip = COUNT(trip(1:nbi,1:nbj) .GE. 97 .AND. trip(1:nbi,1:nbj) .LT. undef_int)
!! ip = ip + COUNT(trip(1:nbi,1:nbj) .EQ. 97)
!! IF ( COUNT(trip(1:nbi,1:nbj) .EQ. 98) .GT. 0) ip = ip + 1
IF ( ip .LT. nb_basin ) THEN
WRITE(numout,*) 'We have less outflow points than basins :', ip
WRITE(fmt,"('(',I3,'I9)')") nbi
WRITE(numout,*) '-----------------------> trip'
DO jp=1,nbj
WRITE(numout,fmt) trip(1:nbi,jp)
ENDDO
WRITE(numout,*) '-----------------------> basin'
DO jp=1,nbj
WRITE(numout,fmt) basin(1:nbi,jp)
ENDDO
WRITE(numout,*) 'nb_basin :', nb_basin
WRITE(numout,*) 'Basin sized :', basin_sz(1:nb_basin)
STOP 'in routing_findbasins'
ENDIF
!
END SUBROUTINE routing_findbasins
!
! ------------------------------------------------------------------------------------------
!
SUBROUTINE routing_simplify(nbi, nbj, trip, basin, hierarchy, basin_inbxid)
!
IMPLICIT NONE
!
! This subroutine symplifies the routing out of each basin by taking
! out redundancies at the borders of the GCM box. The aim is to have
! only one outflow point per basin. But here we will not change the
! the direction of the outflow.
!
! Inputs
INTEGER(i_std) :: nbi, nbj
INTEGER(i_std) :: trip(:,:), basin(:,:)
REAL(r_std) :: hierarchy(:,:)
INTEGER(i_std) :: basin_inbxid
!
! Local
!
INTEGER(i_std) :: ip, jp, nbout, basin_sz, iborder
INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_tmp
INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow
INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow
INTEGER(i_std), DIMENSION(nbvmax) :: outsz
CHARACTER(LEN=7) :: fmt
!
INTEGER(i_std), DIMENSION(8,2) :: inc
INTEGER(i_std) :: itodo, ill(1), icc, ismall, ibas, iip, jjp, ib, id
INTEGER(i_std), DIMENSION(nbvmax) :: todopt, todosz
REAL(r_std), DIMENSION(nbvmax) :: todohi
LOGICAL :: not_found, debug = .FALSE.
!
!
! The routing code (i=1, j=2)
!
inc(1,1) = 0
inc(1,2) = -1
inc(2,1) = 1
inc(2,2) = -1
inc(3,1) = 1
inc(3,2) = 0
inc(4,1) = 1
inc(4,2) = 1
inc(5,1) = 0
inc(5,2) = 1
inc(6,1) = -1
inc(6,2) = 1
inc(7,1) = -1
inc(7,2) = 0
inc(8,1) = -1
inc(8,2) = -1
!
!
! Symplify the outflow conditions first. We are only interested in the
! outflows which go to different GCM grid-boxes.
!
IF ( debug ) THEN
WRITE(numout,*) '+++++++++++++++++++ BEFORE ANYTHING ++++++++++++++++++++'
WRITE(fmt,"('(',I3,'I6)')") nbi
DO jp=1,nbj
WRITE(numout,fmt) trip_tmp(1:nbi,jp)
ENDDO
ENDIF
!
! transfer the trips into an array which only contains the basin we are interested in
!
trip_tmp(:,:) = -1
basin_sz = 0
DO ip=1,nbi
DO jp=1,nbj
IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
trip_tmp(ip,jp) = trip(ip,jp)
basin_sz = basin_sz + 1
ENDIF
ENDDO
ENDDO
!
! Determine for each point where it flows to
!
CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
!
!
!
!
! Over the width of a GCM grid box we can have many outflows but we are interested
! in only one for each basin. Thus we wish to collect them all to form only one outflow
! to the neighboring grid-box.
!
DO iborder = 101,107,2
!
! If we have more than one of these outflows then we need to merge the sub-basins
!
icc = COUNT(trip_tmp .EQ. iborder)-1
DO WHILE ( icc .GT. 0)
! Pick out all the points we will have to do
itodo = 0
DO ip=1,nbout
IF (trip_tmp(outflow(ip,1),outflow(ip,2)) .EQ. iborder) THEN
itodo = itodo + 1
todopt(itodo) = ip
todosz(itodo) = outsz(ip)
! We take the hierarchy of the outflow point as we will try to
! minimize if for the outflow of the entire basin.
todohi(itodo) = hierarchy(outflow(ip,1),outflow(ip,2))
ENDIF
ENDDO
!
! We change the direction of the smalest basin.
!
ill=MAXLOC(todohi(1:itodo))
ismall = todopt(ill(1))
!
DO ip=1,nbi
DO jp=1,nbj
IF ( trip_flow(ip,jp,1) .EQ. outflow(ismall,1) .AND.&
& trip_flow(ip,jp,2) .EQ. outflow(ismall,2) ) THEN
! Now that we have found a point of the smallest sub-basin we
! look around for another sub-basin
ib = 1
not_found = .TRUE.
DO WHILE ( not_found .AND. ib .LE. itodo )
IF ( ib .NE. ill(1) ) THEN
ibas = todopt(ib)
DO id=1,8
iip = ip + inc(id,1)
jjp = jp + inc(id,2)
! Can we look at this points or is there any need to ?
IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
! Is this point the one we look for ?
IF ( trip_flow(iip,jjp,1) .EQ. outflow(ibas,1) .AND. &
& trip_flow(iip,jjp,2) .EQ. outflow(ibas,2)) THEN
trip_flow(ip,jp,1) = outflow(ibas,1)
trip_flow(ip,jp,2) = outflow(ibas,2)
trip_tmp(ip,jp) = id
! This last line ensures that we do not come back to this point
! and that in the end the outer while will stop
not_found = .FALSE.
ENDIF
ENDIF
ENDDO
ENDIF
ib = ib + 1
ENDDO
ENDIF
ENDDO
ENDDO
!
icc = icc - 1
ENDDO
!
!
ENDDO
!
IF ( debug ) THEN
WRITE(numout,*) '+++++++++++++++++++ AFTER +++++++++++++++++++++++++++++'
WRITE(fmt,"('(',I3,'I6)')") nbi
DO jp=1,nbj
WRITE(numout,fmt) trip_tmp(1:nbi,jp)
ENDDO
ENDIF
!
! Put trip_tmp back into trip
!
DO ip=1,nbi
DO jp=1,nbj
IF ( trip_tmp(ip,jp) .GT. 0) THEN
trip(ip,jp) = trip_tmp(ip,jp)
ENDIF
ENDDO
ENDDO
!
END SUBROUTINE routing_simplify
!
!-------------------------------------
!
SUBROUTINE routing_cutbasin (nbi, nbj, nbbasins, trip, basin, basin_inbxid, nb, bname, sz, pts)
!
IMPLICIT NONE
!
! This subroutine cuts the original basin which has more than one outflow into as
! many subbasins as outflow directions.
!
! Inputs
INTEGER(i_std) :: nbi, nbj
INTEGER(i_std) :: nbbasins
INTEGER(i_std) :: trip(:,:), basin(:,:)
INTEGER(i_std) :: basin_inbxid
!
! Outputs
!
INTEGER(i_std) :: nb, bname(nbvmax), sz(nbvmax), pts(nbvmax,nbvmax,2)
!
! Local
!
INTEGER(i_std) :: ip, jp, iip, jjp, ib, ibb, id, nbout
INTEGER(i_std) :: basin_sz, nb_in
INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_tmp
INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow
INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow
INTEGER(i_std), DIMENSION(nbvmax) :: outsz
CHARACTER(LEN=7) :: fmt
LOGICAL :: not_found, debug=.FALSE.
!
INTEGER(i_std), DIMENSION(8,2) :: inc
!
!
! The routing code (i=1, j=2)
!
inc(1,1) = 0
inc(1,2) = -1
inc(2,1) = 1
inc(2,2) = -1
inc(3,1) = 1
inc(3,2) = 0
inc(4,1) = 1
inc(4,2) = 1
inc(5,1) = 0
inc(5,2) = 1
inc(6,1) = -1
inc(6,2) = 1
inc(7,1) = -1
inc(7,2) = 0
inc(8,1) = -1
inc(8,2) = -1
!
! Set up a temporary trip field which only contains the values
! for the basin on which we currently work.
!
trip_tmp(:,:) = -1
basin_sz = 0
DO ip=1,nbi
DO jp=1,nbj
IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
trip_tmp(ip,jp) = trip(ip,jp)
basin_sz = basin_sz + 1
ENDIF
ENDDO
ENDDO
!
CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
!
!! IF ( debug ) THEN
!! DO ib = nb_in+1,nb
!! DO ip=1,sz(ib)
!! trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
!! ENDDO
!! ENDDO
!! WRITE(fmt,"('(',I3,'I6)')") nbi
!! WRITE(numout,*) 'BEFORE ------------> New basins '
!! WRITE(numout,*) nb, ' sz :', sz(1:nb)
!! DO jp=1,nbj
!! WRITE(numout,fmt) trip_tmp(1:nbi,jp)
!! ENDDO
!! ENDIF
!
! Take out the small sub-basins. That is those which have only one grid box
! This is only done if we need to save space in the number of basins. Else we
! can take it easy and keep diverging sub-basins for the moment.
!
IF ( nbbasins .GE. nbasmax ) THEN
DO ib=1,nbout
! If the sub-basin is of size one and its larger neighbor is flowing into another
! direction then we put them together.
IF ( outsz(ib) .EQ. 1 .AND. trip(outflow(ib,1), outflow(ib,2)) .GT. 99 ) THEN
!
not_found = .TRUE.
DO id=1,8
ip = outflow(ib,1)
jp = outflow(ib,2)
iip = ip + inc(id,1)
jjp = jp + inc(id,2)
! Can we look at this points ?
IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
& jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
! Did we find a direct neighbor which is an outflow point ?
IF ( trip_tmp(iip,jjp) .GT. 100 ) THEN
! IF so direct the flow towards it and update the tables.
not_found = .FALSE.
trip(ip,jp) = id
trip_tmp(ip,jp) = id
outsz(ib) = 0
! update the table of this basin
DO ibb=1,nbout
IF ( iip .EQ. outflow(ibb,1) .AND. jjp .EQ. outflow(ibb,2) ) THEN
outsz(ibb) = outsz(ibb)+1
trip_flow(ip,jp,1) = outflow(ibb,1)
trip_flow(ip,jp,2) = outflow(ibb,2)
ENDIF
ENDDO
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
ENDIF
!
!
! Cut the basin if we have more than 1 left.
!
!
IF ( COUNT(outsz(1:nbout) .GT. 0) .GT. 1 ) THEN
!
nb_in = nb
!
DO ib = 1,nbout
IF ( outsz(ib) .GT. 0) THEN
nb = nb+1
IF ( nb .GT. nbvmax) THEN
WRITE(numout,*) 'nbvmax too small, increase it (routing_cutbasin)'
ENDIF
bname(nb) = basin_inbxid
sz(nb) = 0
DO ip=1,nbi
DO jp=1,nbj
IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,1)) .GT. 0 .AND. &
& trip_flow(ip,jp,1) .EQ. outflow(ib,1) .AND. &
& trip_flow(ip,jp,2) .EQ. outflow(ib,2) ) THEN
sz(nb) = sz(nb) + 1
pts(nb, sz(nb), 1) = ip
pts(nb, sz(nb), 2) = jp
ENDIF
ENDDO
ENDDO
ENDIF
ENDDO
! A short verification
IF ( SUM(sz(nb_in+1:nb)) .NE. basin_sz) THEN
WRITE(numout,*) 'Lost some points while spliting the basin'
WRITE(numout,*) 'nbout :', nbout
DO ib = nb_in+1,nb
WRITE(numout,*) 'ib, SZ :', ib, sz(ib)
ENDDO
WRITE(fmt,"('(',I3,'I6)')") nbi
WRITE(numout,*) '-------------> trip '
DO jp=1,nbj
WRITE(numout,fmt) trip_tmp(1:nbi,jp)
ENDDO
STOP
ENDIF
!
IF ( debug ) THEN
DO ib = nb_in+1,nb
DO ip=1,sz(ib)
trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
ENDDO
ENDDO
WRITE(fmt,"('(',I3,'I6)')") nbi
WRITE(numout,*) 'AFTER-------------> New basins '
WRITE(numout,*) nb, ' sz :', sz(1:nb)
DO jp=1,nbj
WRITE(numout,fmt) trip_tmp(1:nbi,jp)
ENDDO
IF ( MAXVAl(trip_tmp(1:nbi,1:nbj)) .GT. 0) THEN
STOP
ENDIF
ENDIF
ENDIF
!
END SUBROUTINE routing_cutbasin
!
!------------------------------------------------------------------------
!
SUBROUTINE routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
!
IMPLICIT NONE
!
! This subroutine will find for each point the distance to the outflow point
! along the flowlines of the basin.
!
INTEGER(i_std) :: iml, jml
REAL(r_std), DIMENSION(iml,jml) :: trip, hierarchy, topoindex
!
INTEGER(i_std), DIMENSION(8,2) :: inc
INTEGER(i_std) :: ip, jp, ib, ntripi, ntripj, cnt, trp
REAL(r_std) :: topohier, topohier_old
CHARACTER(LEN=7) :: fmt
!
! The routing code (i=1, j=2)
!
inc(1,1) = 0
inc(1,2) = -1
inc(2,1) = 1
inc(2,2) = -1
inc(3,1) = 1
inc(3,2) = 0
inc(4,1) = 1
inc(4,2) = 1
inc(5,1) = 0
inc(5,2) = 1
inc(6,1) = -1
inc(6,2) = 1
inc(7,1) = -1
inc(7,2) = 0
inc(8,1) = -1
inc(8,2) = -1
!
DO ip=1,iml
DO jp=1,jml
IF ( trip(ip,jp) .LT. undef_sechiba ) THEN
ntripi = ip
ntripj = jp
trp = trip(ip,jp)
cnt = 1
! Warn for extreme numbers
IF ( topoindex(ip,jp) .GT. 1.e10 ) THEN
WRITE(numout,*) 'We have a very large topographic index for point ', ip, jp
WRITE(numout,*) 'This can not be right :', topoindex(ip,jp)
STOP
ELSE
topohier = topoindex(ip,jp)
ENDIF
!
DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. iml*jml)
cnt = cnt + 1
ntripi = ntripi + inc(trp,1)
IF ( ntripi .LT. 1) ntripi = iml
IF ( ntripi .GT. iml) ntripi = 1
ntripj = ntripj + inc(trp,2)
topohier_old = topohier
topohier = topohier + topoindex(ntripi, ntripj)
IF ( topohier_old .GT. topohier) THEN
WRITE(numout,*) 'Big Problem, how comes we climb up a hill ?'
WRITE(numout,*) 'The old value of topographicaly weighted hierarchy was : ', topohier_old
WRITE(numout,*) 'The new one is :', topohier
STOP 'routing_hierarchy'
ENDIF
trp = trip(ntripi, ntripj)
ENDDO
!
IF ( cnt .EQ. iml*jml) THEN
WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
WRITE(numout,*) '-------------> trip '
WRITE(fmt,"('(',I3,'I6)')") iml
DO ib=1,jml
WRITE(numout,fmt) trip(1:iml,ib)
ENDDO
STOP
ENDIF
!
hierarchy(ip,jp) = topohier
!
ENDIF
ENDDO
ENDDO
!
!
END SUBROUTINE routing_hierarchy
!
!------------------------------------------------------------------------
!
SUBROUTINE routing_findrout(nbi, nbj, trip, basin_sz, basinid, nbout, outflow, trip_flow, outsz)
!
IMPLICIT NONE
!
! This subroutine simply computes the route to each outflow point and returns
! the outflow point for each point in the basin.
!
! INPUT
!
INTEGER(i_std) :: nbi, nbj
INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip
INTEGER(i_std) :: basin_sz, basinid, nbout
INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow
INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow
INTEGER(i_std), DIMENSION(nbvmax) :: outsz
!
! LOCAL
!
INTEGER(i_std), DIMENSION(8,2) :: inc
INTEGER(i_std) :: ip, jp, ib, cnt, trp, totsz
CHARACTER(LEN=7) :: fmt
!
!
! The routing code (i=1, j=2)
!
inc(1,1) = 0
inc(1,2) = -1
inc(2,1) = 1
inc(2,2) = -1
inc(3,1) = 1
inc(3,2) = 0
inc(4,1) = 1
inc(4,2) = 1
inc(5,1) = 0
inc(5,2) = 1
inc(6,1) = -1
inc(6,2) = 1
inc(7,1) = -1
inc(7,2) = 0
inc(8,1) = -1
inc(8,2) = -1
!
!
! Get the outflows and determine for each point to which outflow point it belong
!
nbout = 0
trip_flow(:,:,:) = 0
DO ip=1,nbi
DO jp=1,nbj
IF ( trip(ip,jp) .GT. 9) THEN
nbout = nbout + 1
outflow(nbout,1) = ip
outflow(nbout,2) = jp
ENDIF
IF ( trip(ip,jp) .GT. 0) THEN
trip_flow(ip,jp,1) = ip
trip_flow(ip,jp,2) = jp
ENDIF
ENDDO
ENDDO
!
! Follow the flow of the water
!
DO ip=1,nbi
DO jp=1,nbj
IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,2)) .GT. 0) THEN
trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
cnt = 0
DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. nbi*nbj)
cnt = cnt + 1
trip_flow(ip,jp,1) = trip_flow(ip,jp,1) + inc(trp,1)
trip_flow(ip,jp,2) = trip_flow(ip,jp,2) + inc(trp,2)
trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
ENDDO
IF ( cnt .EQ. nbi*nbj) THEN
WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
WRITE(numout,*) '-------------> trip '
WRITE(fmt,"('(',I3,'I6)')") nbi
DO ib=1,nbj
WRITE(numout,fmt) trip(1:nbi,ib)
ENDDO
STOP
ENDIF
ENDIF
ENDDO
ENDDO
!
! What is the size of the region behind each outflow point ?
!
totsz = 0
DO ip=1,nbout
outsz(ip) = COUNT(trip_flow(:,:,1) .EQ. outflow(ip,1) .AND. trip_flow(:,:,2) .EQ. outflow(ip,2))
totsz = totsz + outsz(ip)
ENDDO
IF ( basin_sz .NE. totsz) THEN
WRITE(numout,*) 'Water got lost while I tried to follow it '
WRITE(numout,*) basin_sz, totsz
WRITE(numout,*) 'Basin id :', basinid
DO ip=1,nbout
WRITE(numout,*) 'ip :', ip, ' outsz :', outsz(ip), ' outflow :', outflow(ip,1), outflow(ip,2)
ENDDO
WRITE(numout,*) '-------------> trip '
WRITE(fmt,"('(',I3,'I6)')") nbi
DO jp=1,nbj
WRITE(numout,fmt) trip(1:nbi,jp)
ENDDO
STOP
ENDIF
!
END SUBROUTINE routing_findrout
!
!----------------------------------------------------------------------------------------------
!
SUBROUTINE routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
& nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
& basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
& nbcoastal, coastal_basin)
!
IMPLICIT NONE
!
! This subroutine will put the basins found for grid-box in in the global map. Connection can
! only be made later when all information is together.
!
!
! One of the outputs is basin_flowdir. Its convention is 1-8 for the directions from North to North
! West going through South. The negative values will be -3 for return flow, -2 for coastal flow
! and -1 river flow.
!
! LOCAL
!
INTEGER(i_std), INTENT (in) :: nbpt, ib ! Current grid-box
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point
! (1=N, 2=E, 3=S, 4=W)
REAL(r_std), DIMENSION(nbvmax,nbvmax) :: area_bx ! Area of each small box in the grid-box
INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_bx ! The trip field for each of the smaler boxes
REAL(r_std), DIMENSION(nbvmax,nbvmax) :: hierarchy_bx ! level in the basin of the point
REAL(r_std), DIMENSION(nbvmax,nbvmax) :: topoind_bx ! Topographic index
REAL(r_std) :: min_topoind ! The default topographic index
INTEGER(i_std) :: nb_basin ! number of sub-basins
INTEGER(i_std), DIMENSION(nbvmax) :: basin_inbxid, basin_sz ! ID of basin, number of points in the basin
INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2):: basin_pts ! Points in each basin
INTEGER(i_std), DIMENSION(nbvmax) :: basin_bxout ! outflow direction
INTEGER(i_std) :: coast_pts(nbvmax) ! The coastal flow points
! global maps
INTEGER(i_std) :: nwbas
INTEGER(i_std), DIMENSION(nbpt) :: basin_count
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id, basin_flowdir
REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area, basin_hierarchy, basin_topoind
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid
INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin
!
! LOCAL
!
INTEGER(i_std) :: ij, iz
CHARACTER(LEN=4) :: hierar_method = 'OUTP'
!
!
DO ij=1, nb_basin
!
! Count the basins and keep their ID
!
basin_count(ib) = basin_count(ib)+1
if (basin_count(ib) > nwbas) then
WRITE(numout,*) 'ib=',ib
call ipslerr(3,'routing_globalize', &
& 'Problem with basin_count : ', &
& 'It is greater than number of allocated basin nwbas.', &
& '(stop to count basins)')
endif
basin_id(ib,basin_count(ib)) = basin_inbxid(ij)
!
! Transfer the list of basins which flow into the ocean as coastal flow.
!
IF ( basin_id(ib,basin_count(ib)) .LT. 0) THEN
nbcoastal(ib) = basin_sz(ij)
coastal_basin(ib,1:nbcoastal(ib)) = coast_pts(1:nbcoastal(ib))
ENDIF
!
!
! Compute the area of the basin
!
basin_area(ib,ij) = 0.0
basin_hierarchy(ib,ij) = 0.0
!
SELECT CASE (hierar_method)
!
CASE("MINI")
basin_hierarchy(ib,ij) = undef_sechiba
!
END SELECT
basin_topoind(ib,ij) = 0.0
!
DO iz=1,basin_sz(ij)
basin_area(ib,ij) = basin_area(ib,ij) + area_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
basin_topoind(ib,ij) = basin_topoind(ib,ij) + topoind_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
!
! There are a number of ways to determine the hierarchy of the entire basin.
! We allow for three here :
! - Take the mean value
! - Take the minimum value within the basin
! - Take the value at the outflow point
! Probably taking the value of the outflow point is the best solution.
!
SELECT CASE (hierar_method)
!
CASE("MEAN")
! Mean hierarchy of the basin
basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij) + &
& hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
CASE("MINI")
! The smalest value of the basin
IF ( hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .LT. basin_hierarchy(ib,ij)) THEN
basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
ENDIF
CASE("OUTP")
! Value at the outflow point
IF ( trip_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .GT. 100 ) THEN
basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
ENDIF
CASE DEFAULT
WRITE(numout,*) 'Unknown method for computing the hierarchy of the basin'
STOP 'routing_globalize'
END SELECT
!
ENDDO
!
basin_topoind(ib,ij) = basin_topoind(ib,ij)/REAL(basin_sz(ij),r_std)
!
SELECT CASE (hierar_method)
!
CASE("MEAN")
basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij)/REAL(basin_sz(ij),r_std)
!
END SELECT
!
! To make sure that it has the lowest number if this is an outflow point we reset basin_hierarchy
!
IF (basin_bxout(ij) .LT. 0) THEN
basin_hierarchy(ib,ij) = min_topoind
basin_topoind(ib,ij) = min_topoind
ENDIF
!
!
! Keep the outflow boxes and basin
!
basin_flowdir(ib,ij) = basin_bxout(ij)
IF (basin_bxout(ij) .GT. 0) THEN
outflow_grid(ib,ij) = neighbours(ib,basin_bxout(ij))
ELSE
outflow_grid(ib,ij) = basin_bxout(ij)
ENDIF
!
!
ENDDO
!
!
END SUBROUTINE routing_globalize
!
!-----------------------------------------------------------------------------
!
SUBROUTINE routing_linkup(nbpt, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
& basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, nbcoastal,&
& coastal_basin, invented_basins)
!
IMPLICIT NONE
!
! This subroutine will make the connections between the basins and ensure global coherence.
!
! The convention for outflow_grid is :
! outflow_grid = -1 : River flow
! outflow_grid = -2 : Coastal flow
! outflow_grid = -3 : Return flow
!
!
! INPUT
!
INTEGER(i_std), INTENT (in) :: nbpt
INTEGER(i_std), DIMENSION(nbpt,8), INTENT (in) :: neighbours
!
INTEGER(i_std) :: nwbas
INTEGER(i_std), DIMENSION(nbpt) :: basin_count
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir
REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area, basin_hierarchy
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number
INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_basin
INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax) :: inflow_grid
INTEGER(i_std), DIMENSION(nbpt) :: nbcoastal
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: coastal_basin
REAL(r_std), INTENT(in) :: invented_basins
!
! LOCAL
!
INTEGER(i_std) :: sp, sb, sbl, inp, bid, outdm1, outdp1
INTEGER(i_std) :: dp1, dm1, dm1i, dp1i, bp1, bm1
INTEGER(i_std) :: dop, bop
INTEGER(i_std) :: fbas(nwbas), nbfbas
REAL(r_std) :: fbas_hierarchy(nwbas)
INTEGER(i_std) :: ff(1)
!
outflow_basin(:,:) = undef_int
inflow_number(:,:) = 0
!
DO sp=1,nbpt
DO sb=1,basin_count(sp)
!
inp = outflow_grid(sp,sb)
bid = basin_id(sp,sb)
!
! We only work on this point if it does not flow into the ocean
! At this point any of the outflows is designated by a negative values in
! outflow_grid
!
IF ( inp .GT. 0 ) THEN
!
! Now find the basin in the onflow point (inp)
!
nbfbas = 0
!
!
DO sbl=1,basin_count(inp)
!
! Either it is a standard basin or one aggregated from ocean flow points.
! If we flow into a another grid box we have to make sure that its hierarchy in the
! basin is lower.
!
!
IF ( basin_id(inp,sbl) .GT. 0 ) THEN
IF ( basin_id(inp,sbl) .EQ. bid .OR. basin_id(inp,sbl) .GT. invented_basins) THEN
nbfbas =nbfbas + 1
fbas(nbfbas) = sbl
fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
ENDIF
ELSE
IF ( COUNT(coastal_basin(inp,1:nbcoastal(inp)) .EQ. bid) .GT. 0 ) THEN
nbfbas =nbfbas + 1
fbas(nbfbas) = sbl
fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
ENDIF
ENDIF
!
ENDDO
!
! If we have more than one basin we will take the one which is lowest
! in the hierarchy.
!
IF (nbfbas .GE. 1) THEN
ff = MINLOC(fbas_hierarchy(1:nbfbas))
sbl = fbas(ff(1))
!
bop = undef_int
IF ( basin_hierarchy(inp,sbl) .LE. basin_hierarchy(sp,sb) ) THEN
IF ( basin_hierarchy(inp,sbl) .LE. basin_hierarchy(sp,sb) ) THEN
bop = sbl
ELSE
! The same hierarchy is allowed if both grids flow in about
! the same direction :
IF ( ( MOD(basin_flowdir(inp,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)).OR. &
& ( basin_flowdir(inp,sbl) .EQ. basin_flowdir(sp,sb)).OR. &
& ( MOD(basin_flowdir(inp,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
bop = sbl
ENDIF
ENDIF
ENDIF
!
! If the basin is suitable (bop < undef_int) then take it
!
IF ( bop .LT. undef_int ) THEN
outflow_basin(sp,sb) = bop
inflow_number(inp,bop) = inflow_number(inp,bop) + 1
IF ( inflow_number(inp,bop) .LE. nbvmax ) THEN
inflow_grid(inp, bop, inflow_number(inp,bop)) = sp
inflow_basin(inp, bop, inflow_number(inp,bop)) = sb
ELSE
WRITE(numout,*) 'Increase nbvmax'
STOP 'routing_linkup'
ENDIF
ENDIF
ENDIF
!
!
ENDIF
!
!
!
! Did we find it ?
!
! In case the outflow point was ocean or we did not find the correct basin we start to look
! around. We find two options for the outflow direction (dp1 & dm1) and the corresponding
! basin index (bp1 & bm1).
!
!
IF ( outflow_basin(sp,sb) .EQ. undef_int &
& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
!
dp1i = MOD(basin_flowdir(sp,sb)+1-1, 8)+1
dp1 = neighbours(sp,dp1i)
dm1i = MOD(basin_flowdir(sp,sb)+7-1, 8)+1
IF ( dm1i .LT. 1 ) dm1i = 8
dm1 = neighbours(sp,dm1i)
!
!
bp1 = -1
IF ( dp1 .GT. 0 ) THEN
DO sbl=1,basin_count(dp1)
IF (basin_id(dp1,sbl) .EQ. bid .AND.&
& basin_hierarchy(sp,sb) .GE. basin_hierarchy(dp1,sbl) .AND. &
& bp1 .LT. 0) THEN
IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dp1,sbl) ) THEN
bp1 = sbl
ELSE
! The same hierarchy is allowed if both grids flow in about
! the same direction :
IF ( ( MOD(basin_flowdir(dp1,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)).OR. &
& ( basin_flowdir(dp1,sbl) .EQ. basin_flowdir(sp,sb)).OR. &
& ( MOD(basin_flowdir(dp1,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
bp1 = sbl
ENDIF
ENDIF
ENDIF
ENDDO
ENDIF
!
bm1 = -1
IF ( dm1 .GT. 0 ) THEN
DO sbl=1,basin_count(dm1)
IF (basin_id(dm1,sbl) .EQ. bid .AND.&
& basin_hierarchy(sp,sb) .GE. basin_hierarchy(dm1,sbl) .AND. &
& bm1 .LT. 0) THEN
IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dm1,sbl) ) THEN
bm1 = sbl
ELSE
! The same hierarchy is allowed if both grids flow in about
! the same direction :
IF ( ( MOD(basin_flowdir(dm1,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)) .OR. &
& ( basin_flowdir(dm1,sbl) .EQ. basin_flowdir(sp,sb)) .OR. &
& ( MOD(basin_flowdir(dm1,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
bm1 = sbl
ENDIF
ENDIF
ENDIF
ENDDO
ENDIF
!
!
! First deal with the case on land.
!
! For that we need to check if the water will be able to flow out of the grid dp1 or dm1
! and not return to our current grid. If it is the current grid
! then we can not do anything with that neighbour. Thus we set the
! value of outdm1 and outdp1 back to -1
!
outdp1 = undef_int
IF ( dp1 .GT. 0 .AND. bp1 .GT. 0 ) THEN
! if the outflow is into the ocean then we put something less than undef_int in outdp1!
IF (basin_flowdir(dp1,bp1) .GT. 0) THEN
outdp1 = neighbours(dp1,basin_flowdir(dp1,bp1))
IF ( outdp1 .EQ. sp ) outdp1 = undef_int
ELSE
outdp1 = nbpt + 1
ENDIF
ENDIF
outdm1 = undef_int
IF ( dm1 .GT. 0 .AND. bm1 .GT. 0 ) THEN
IF (basin_flowdir(dm1,bm1) .GT. 0) THEN
outdm1 = neighbours(dm1,basin_flowdir(dm1,bm1))
IF ( outdm1 .EQ. sp ) outdm1 = undef_int
ELSE
outdm1 = nbpt + 1
ENDIF
ENDIF
!
! Now that we know our options we need go through them.
!
dop = undef_int
bop = undef_int
IF ( outdp1 .LT. undef_int .AND. outdm1 .LT. undef_int) THEN
!
! In this case we let the current basin flow into the smaller one
!
IF ( basin_area(dp1,bp1) .LT. basin_area(dm1,bm1) ) THEN
dop = dp1
bop = bp1
ELSE
dop = dm1
bop = bm1
ENDIF
!
!
ELSE IF ( outdp1 .LT. undef_int ) THEN
! If only the first one is possible
dop = dp1
bop = bp1
ELSE IF ( outdm1 .LT. undef_int ) THEN
! If only the second one is possible
dop = dm1
bop = bm1
ELSE
!
! Now we are at the point where none of the neighboring points is suitable
! or we have a coastal point.
!
! If there is an option to put the water into the ocean go for it.
!
IF ( outflow_grid(sp,sb) .LT. 0 .OR. dm1 .LT. 0 .OR. dp1 .LT. 0 ) THEN
dop = -1
ELSE
!
! If we are on a land point with only land neighbors but no one suitable to let the
! water flow into we have to look for a solution in the current grid box.
!
!
IF ( bp1 .LT. 0 .AND. bm1 .LT. 0 ) THEN
!
! Do we have more than one basin with the same ID ?
!
IF ( COUNT(basin_id(sp,1:basin_count(sp)) .EQ. bid) .GE. 2) THEN
!
! Now we can try the option of flowing into the basin of the same grid box.
!
DO sbl=1,basin_count(sp)
IF (sbl .NE. sb .AND. basin_id(sp,sbl) .EQ. bid) THEN
! In case this basin has a lower hierarchy or flows into a totaly
! different direction we go for it.
IF ( (basin_hierarchy(sp,sb) .GE. basin_hierarchy(sp,sbl)) .OR. &
& (basin_flowdir(sp,sbl) .LT. dm1i .AND.&
& basin_flowdir(sp,sbl) .GT. dp1i) ) THEN
dop = sp
bop = sbl
IF (basin_hierarchy(sp,sb) .LT. basin_hierarchy(sp,sbl)) THEN
WRITE(numout,*) '>>>>>>> POINT CORRECTED against hierarchy :',&
& sp, sb, 'into', sbl
ENDIF
ENDIF
!
ENDIF
ENDDO
!
ENDIF
ENDIF
ENDIF
!
IF ( dop .EQ. undef_int .AND. bop .EQ. undef_int ) THEN
WRITE(numout,*) 'Why are we here with point ', sp, sb
WRITE(numout,*) 'Local Basin ID :', basin_id(sp,1:basin_count(sp))
WRITE(numout,*) 'Local hierarchies :', basin_hierarchy(sp,1:basin_count(sp))
WRITE(numout,*) 'Local basin_flowdir :', basin_flowdir(sp,1:basin_count(sp))
WRITE(numout,*) 'Local outflowgrid :', outflow_grid(sp,1:basin_count(sp))
WRITE(numout,*) 'outflow_grid :', inp
WRITE(numout,*) 'Outflow Basin ID :', basin_id(inp,1:basin_count(inp))
WRITE(numout,*) 'Outflow hierarchies :', basin_hierarchy(inp,1:basin_count(inp))
WRITE(numout,*) 'Outflow basin_flowdir :', basin_flowdir(inp,1:basin_count(inp))
WRITE(numout,*) 'Explored options +1 :', dp1, bp1, outdp1
WRITE(numout,*) 'Explored +1 Basin ID :', basin_id(dp1,1:basin_count(dp1))
WRITE(numout,*) 'Explored +1 hierarchies :', basin_hierarchy(dp1,1:basin_count(dp1))
WRITE(numout,*) 'Explored +1 basin_flowdir :', basin_flowdir(dp1,1:basin_count(dp1))
WRITE(numout,*) 'Explored options -1 :', dm1, bm1, outdm1
WRITE(numout,*) 'Explored -1 Basin ID :', basin_id(dm1,1:basin_count(dm1))
WRITE(numout,*) 'Explored -1 hierarchies :', basin_hierarchy(dm1,1:basin_count(dm1))
WRITE(numout,*) 'Explored -1 basin_flowdir :', basin_flowdir(dm1,1:basin_count(dm1))
WRITE(numout,*) '****************************'
STOP 'routing_linkup'
ENDIF
!
ENDIF
!
! Now that we know where we want the water to flow to we write the
! the information in the right fields.
!
IF ( dop .GT. 0 ) THEN
outflow_grid(sp,sb) = dop
outflow_basin(sp,sb) = bop
inflow_number(dop,bop) = inflow_number(dop,bop) + 1
IF ( inflow_number(dop,bop) .LE. nbvmax ) THEN
inflow_grid(dop, bop, inflow_number(dop,bop)) = sp
inflow_basin(dop, bop, inflow_number(dop,bop)) = sb
ELSE
WRITE(numout,*) 'Increase nbvmax'
STOP 'routing_linkup'
ENDIF
!
ELSE
outflow_grid(sp,sb) = -2
outflow_basin(sp,sb) = undef_int
ENDIF
!
ENDIF
!
!
! If we still have not found anything then we have to check that there is not a basin
! within the same grid box which has a lower hierarchy.
!
!
IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
!
WRITE(numout,*) 'There is no reason to here, this part of the code should be dead :', sp,sb
!
DO sbl=1,basin_count(sp)
!
! Three conditons are needed to let the water flow into another basin of the
! same grid :
! - another basin than the current one
! - same ID
! - of lower hierarchy.
!
IF ( (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid)&
& .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl)) ) THEN
outflow_basin(sp,sb) = sbl
inflow_number(sp,sbl) = inflow_number(sp,sbl) + 1
IF ( inflow_number(sp,sbl) .LE. nbvmax ) THEN
IF ( sp .EQ. 42 .AND. sbl .EQ. 1) THEN
WRITE(numout,*) 'ADD INFLOW (3):', sp, sb
ENDIF
inflow_grid(sp, sbl, inflow_number(sp,sbl)) = sp
inflow_basin(sp, sbl, inflow_number(sp,sbl)) = sb
ELSE
WRITE(numout,*) 'Increase nbvmax'
STOP 'routing_linkup'
ENDIF
ENDIF
ENDDO
ENDIF
!
! Ok that is it, we give up :-)
!
IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
& .AND. basin_flowdir(sp,sb) .GT. 0) THEN
!
WRITE(numout,*) 'We could not find the basin into which we need to flow'
WRITE(numout,*) 'Grid point ', sp, ' and basin ', sb
WRITE(numout,*) 'Explored neighbours :', dm1, dp1
WRITE(numout,*) 'Outflow direction :', basin_flowdir(sp,sb)
WRITE(numout,*) 'Outlfow grid :', outflow_grid(sp,sb)
WRITE(numout,*) 'basin ID:',basin_id(sp,sb)
WRITE(numout,*) 'Hierarchy :', basin_hierarchy(sp,sb)
STOP 'routing_linkup'
ENDIF
ENDDO
!
ENDDO
!
! Check for each outflow basin that it exists
!
DO sp=1,nbpt
DO sb=1,basin_count(sp)
!
inp = outflow_grid(sp,sb)
sbl = outflow_basin(sp,sb)
IF ( inp .GE. 0 ) THEN
IF ( basin_count(inp) .LT. sbl ) THEN
WRITE(numout,*) 'point :', sp, ' basin :', sb
WRITE(numout,*) 'Flows into point :', inp, ' basin :', sbl
WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(inp)
STOP
ENDIF
ENDIF
ENDDO
ENDDO
!
END SUBROUTINE routing_linkup
!
!---------------------------------------------------------------------------
!
SUBROUTINE routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id,&
& outflow_grid, outflow_basin, fetch_basin)
!
IMPLICIT NONE
!
! This subroutine will compute the fetch of each basin. This means that for each basin we
! will know how much area is upstream. It will help decide how to procede with the
! the truncation later and allow to set correctly in outflow_grid the distinction
! between coastal and river flow
!
!
! INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt
!
REAL(r_std), DIMENSION(nbpt,2), INTENT(in) :: resolution
REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac ! Fraction of land in each grid box
!
INTEGER(i_std) :: nwbas
INTEGER(i_std), DIMENSION(nbpt), INTENT(in) :: basin_count
REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: basin_area
INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: basin_id
INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(inout) :: outflow_grid
INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in) :: outflow_basin
REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(out) :: fetch_basin
!
! LOCAL
!
INTEGER(i_std) :: ib, ij, ff(1), it, itt, igrif, ibasf, nboutflow
REAL(r_std) :: contarea, totbasins
REAL(r_std), DIMENSION(nbpt*nbvmax) :: tmp_area
INTEGER(i_std), DIMENSION(nbpt*nbvmax,2) :: tmpindex
!
!
! Normalize the area of all basins
!
DO ib=1,nbpt
!
totbasins = SUM(basin_area(ib,1:basin_count(ib)))
contarea = resolution(ib,1)*resolution(ib,2)*contfrac(ib)
!
DO ij=1,basin_count(ib)
basin_area(ib,ij) = basin_area(ib,ij)/totbasins*contarea
ENDDO
!
ENDDO
WRITE(numout,*) 'Normalization done'
!
! Compute the area upstream of each basin
!
fetch_basin(:,:) = 0.0
!
!
DO ib=1,nbpt
!
DO ij=1,basin_count(ib)
!
fetch_basin(ib, ij) = fetch_basin(ib, ij) + basin_area(ib,ij)
!
igrif = outflow_grid(ib,ij)
ibasf = outflow_basin(ib,ij)
!
itt = 0
DO WHILE (igrif .GT. 0)
fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + basin_area(ib, ij)
it = outflow_grid(igrif, ibasf)
ibasf = outflow_basin(igrif, ibasf)
igrif = it
itt = itt + 1
IF ( itt .GT. 500) THEN
WRITE(numout,&
"('Grid ',I5, ' and basin ',I5, 'did not converge after iteration ',I5)") ib, ij, itt
WRITE(numout,*) 'Basin ID :', basin_id(igrif,ibasf)
WRITE(numout,&
"('We are stuck with the flow into grid ',I5,' and basin ',I5)") igrif, ibasf
IF ( itt .GT. 510) THEN
STOP ' routing_fetch'
ENDIF
ENDIF
ENDDO
!
ENDDO
!
ENDDO
!
WRITE(numout,*) 'The smalest FETCH :', MINVAL(fetch_basin)
WRITE(numout,*) 'The largest FETCH :', MAXVAL(fetch_basin)
!
! Now we set for the 'num_largest' largest basins the outflow condition as stream flow
! (i.e. outflow_grid = -1) and all other outflow basins are set to coastal flow
! (i.e. outflow_grid = -2). The return flow is not touched.
!
nboutflow = 0
!
DO ib=1,nbpt
!
DO ij=1,basin_count(ib)
!
! We do not need any more the river flow flag as we are going to reset it.
!
IF ( outflow_grid(ib,ij) .EQ. -1) THEN
outflow_grid(ib,ij) = -2
ENDIF
!
IF ( outflow_grid(ib,ij) .EQ. -2) THEN
!
nboutflow = nboutflow + 1
tmp_area(nboutflow) = fetch_basin(ib,ij)
tmpindex(nboutflow,1) = ib
tmpindex(nboutflow,2) = ij
!
ENDIF
!
ENDDO
ENDDO
!
DO ib=1, num_largest
ff = MAXLOC(tmp_area(1:nboutflow))
outflow_grid(tmpindex(ff(1),1), tmpindex(ff(1),2)) = -1
tmp_area(ff(1)) = 0.0
ENDDO
!
END SUBROUTINE routing_fetch
!
!---------------------------------------------------------------------------
!
SUBROUTINE routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
& inflow_grid, inflow_basin)
!
IMPLICIT NONE
!
!
! This subroutine reduces the number of basins per gird to the value chosen by the user.
! it also computes the final field which will be used to route the water at the
! requested truncation.
!
! INPUT
!
INTEGER(i_std) :: nbpt
!
REAL(r_std), DIMENSION(nbpt,2) :: resolution
REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac ! Fraction of land in each grid box
!
INTEGER(i_std) :: nwbas
INTEGER(i_std), DIMENSION(nbpt) :: basin_count
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir
REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area
REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind
REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number
INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin
INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid
!
! LOCAL
!
INTEGER(i_std), PARAMETER :: pickmax = 200
INTEGER(i_std) :: ib, ij, ibf, ijf, igrif, ibasf, cnt, pold, bold, ff(2)
INTEGER(i_std) :: ii, kbas, sbas, ik, iter, ibt, obj
REAL(r_std), DIMENSION(nbpt,nbasmax) :: floflo
REAL(r_std), DIMENSION(nbpt) :: gridarea, gridbasinarea
REAL(r_std) :: ratio
INTEGER(i_std), DIMENSION(pickmax,2) :: largest_basins
INTEGER(i_std), DIMENSION(pickmax) :: tmp_ids
INTEGER(i_std) :: multbas, iml(1)
INTEGER(i_std), DIMENSION(pickmax) :: multbas_sz
REAL(r_std), DIMENSION(pickmax) :: tmp_area
INTEGER(i_std), DIMENSION(pickmax,pickmax) :: multbas_list
!
INTEGER(i_std) :: nbtruncate
INTEGER(i_std), SAVE, ALLOCATABLE, DIMENSION(:) :: indextrunc
!
IF ( .NOT. ALLOCATED(indextrunc)) THEN
ALLOCATE(indextrunc(nbpt))
ENDIF
!
! Truncate if needed and find the path closest to the high resolution data.
!
! The algorithm :
!
! We only go through this procedure only as many times as there are basins to take out at most.
! This is important as it allows the simplifications to spread from one grid to the other.
! The for each step of the iteration and at each grid point we check the following options for
! simplifying the pathways of water :
! 1) If the basin of a grid flows into another basin of the same grid. Kill the one which only
! served as a transition
! 2) If in one grid box we have a number of basins which flow into the ocean as coastal flow.
! We kill the smallest one and put into the largest basin. There is no need to manage many
! basins going into the ocean as coastal flows.
! 3) If we have streams run in parallel from one gird box to the others (that is these are
! different basins) we will put the smaller one in the larger one. This may hapen at any
! level of the flow but in theory it should propagate downstream.
! 4) If we have two basins with the same ID but flow into different grid boxes we sacrifice
! the smallest one and route it through the largest.
!
! Obviously if any of the options find something then we skip the rest and take out the basin.
!
!
! We have to go through the grid as least as often as we have to reduce the number of basins
! For good measure we add 3 more passages.
!
!
DO iter = 1, MAXVAL(basin_count) - nbasmax +3
!
! Get the points over which we wish to truncate
!
nbtruncate = 0
DO ib = 1, nbpt
IF ( basin_count(ib) .GT. nbasmax ) THEN
nbtruncate = nbtruncate + 1
indextrunc(nbtruncate) = ib
ENDIF
ENDDO
!
! Go through the basins which need to be truncated.
!
DO ibt=1,nbtruncate
!
ib = indextrunc(ibt)
!
! Check if we have basin which flows into a basin in the same grid
! kbas = basin we will have to kill
! sbas = basin which takes over kbas
!
kbas = 0
sbas = 0
!
! 1) Can we find a basin which flows into a basin of the same grid ?
!
DO ij=1,basin_count(ib)
DO ii=1,basin_count(ib)
IF ( outflow_grid(ib,ii) .EQ. ib .AND. outflow_basin(ib, ii) .EQ. ij .AND. kbas*sbas .NE. 0) THEN
kbas = ii
sbas = ij
ENDIF
ENDDO
ENDDO
!
! 2) Merge two basins which flow into the ocean as coastal or return flow
! (outflow_grid = -2 or -3). Well obviously only if we have more than 1 and
! have not found anything yet!
!
IF ( (COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 .OR.&
& COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -3) .GT. 1) .AND.&
& kbas*sbas .EQ. 0) THEN
!
multbas = 0
multbas_sz(:) = 0
!
IF ( COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 ) THEN
obj = -2
ELSE
obj = -3
ENDIF
!
! First we get the list of all basins which go out as coastal or return flow (obj)
!
DO ij=1,basin_count(ib)
IF ( outflow_grid(ib,ij) .EQ. obj ) THEN
multbas = multbas + 1
multbas_sz(multbas) = ij
tmp_area(multbas) = fetch_basin(ib,ij)
ENDIF
ENDDO
!
! Now the take the smalest to be transfered to the largest
!
iml = MAXLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. 0.)
sbas = multbas_sz(iml(1))
iml = MINLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. 0.)
kbas = multbas_sz(iml(1))
!
ENDIF
!
! 3) If we have basins flowing into the same grid but different basins then we put them
! together. Obviously we first work with the grid which has most streams runing into it
! and puting the smalest in the largests catchments.
!
IF ( kbas*sbas .EQ. 0) THEN
!
tmp_ids(1:basin_count(ib)) = outflow_grid(ib,1:basin_count(ib))
multbas = 0
multbas_sz(:) = 0
!
! First obtain the list of basins which flow into the same basin
!
DO ij=1,basin_count(ib)
IF ( outflow_grid(ib,ij) .GT. 0 .AND.&
& COUNT(tmp_ids(1:basin_count(ib)) .EQ. outflow_grid(ib,ij)) .GT. 1) THEN
multbas = multbas + 1
DO ii=1,basin_count(ib)
IF ( tmp_ids(ii) .EQ. outflow_grid(ib,ij)) THEN
multbas_sz(multbas) = multbas_sz(multbas) + 1
multbas_list(multbas,multbas_sz(multbas)) = ii
tmp_ids(ii) = -99
ENDIF
ENDDO
ELSE
tmp_ids(ij) = -99
ENDIF
ENDDO
!
! Did we come up with any basins to deal with this way ?
!
IF ( multbas .GT. 0 ) THEN
!
iml = MAXLOC(multbas_sz(1:multbas))
ik = iml(1)
!
! Take the smallest and largest of these basins !
!
DO ii=1,multbas_sz(ik)
tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
ENDDO
iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. 0.)
sbas = multbas_list(ik,iml(1))
iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. 0.)
kbas = multbas_list(ik,iml(1))
!
ENDIF
!
ENDIF
!
! 4) If we have twice the same basin we put them together even if they flow into different
! directions. If one of them goes to the ocean it takes the advantage.
!
IF ( kbas*sbas .EQ. 0) THEN
!
tmp_ids(1:basin_count(ib)) = basin_id(ib,1:basin_count(ib))
multbas = 0
multbas_sz(:) = 0
!
! First obtain the list of basins which have sub-basins in this grid box.
! (these are identified by their IDs)
!
DO ij=1,basin_count(ib)
IF ( COUNT(tmp_ids(1:basin_count(ib)) .EQ. basin_id(ib,ij)) .GT. 1) THEN
multbas = multbas + 1
DO ii=1,basin_count(ib)
IF ( tmp_ids(ii) .EQ. basin_id(ib,ij)) THEN
multbas_sz(multbas) = multbas_sz(multbas) + 1
multbas_list(multbas,multbas_sz(multbas)) = ii
tmp_ids(ii) = -99
ENDIF
ENDDO
ELSE
tmp_ids(ij) = -99
ENDIF
ENDDO
!
! We are going to work on the basin with the largest number of sub-basins.
! (IF we have a basin which has subbasins !)
!
IF ( multbas .GT. 0 ) THEN
!
iml = MAXLOC(multbas_sz(1:multbas))
ik = iml(1)
!
! If one of the basins goes to the ocean then it is going to have the priority
!
tmp_area(:) = 0.
IF ( COUNT(outflow_grid(ib,multbas_list(ik,1:multbas_sz(ik))) .LT. 0) .GT. 0) THEN
DO ii=1,multbas_sz(ik)
IF ( outflow_grid(ib,multbas_list(ik,ii)) .LT. 0 .AND. sbas .EQ. 0 ) THEN
sbas = multbas_list(ik,ii)
ELSE
tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
ENDIF
ENDDO
! take the smalest of the subbasins
iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. 0.)
kbas = multbas_list(ik,iml(1))
ELSE
!
! Else we take simply the largest and smalest
!
DO ii=1,multbas_sz(ik)
tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
ENDDO
iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. 0.)
sbas = multbas_list(ik,iml(1))
iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. 0.)
kbas = multbas_list(ik,iml(1))
!
ENDIF
!
!
ENDIF
ENDIF
!
!
!
! Then we call routing_killbas to clean up the basins in this grid
!
IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
& inflow_grid, inflow_basin)
ENDIF
!
ENDDO
!
!
ENDDO
!
! If there are any grids left with too many basins we need to take out the big hammer !
! We will only do it if this represents less than 5% of all points.
!
IF ( COUNT(basin_count .GT. nbasmax) .GT. 0 ) THEN
!
!
IF ( COUNT(basin_count .GT. nbasmax)/nbpt*100 .GT. 5 ) THEN
WRITE(numout,*) 'We have ', COUNT(basin_count .GT. nbasmax)/nbpt*100, '% of all points which do not yet'
WRITE(numout,*) 'have the right trunctaction. That is too much to apply a brutal method'
DO ib = 1, nbpt
IF ( basin_count(ib) .GT. nbasmax ) THEN
!
WRITE(numout,*) 'We did not find a basin which could be supressed. We will'
WRITE(numout,*) 'not be able to reduce the truncation in grid ', ib
DO ij=1,basin_count(ib)
WRITE(numout,*) 'grid, basin nb and id :', ib, ij, basin_id(ib,ij)
WRITE(numout,*) 'Outflow grid and basin ->', outflow_grid(ib,ij), outflow_basin(ib, ij)
ENDDO
ENDIF
ENDDO
STOP 'routing_truncate'
!
ELSE
!
!
DO ib = 1,nbpt
DO WHILE ( basin_count(ib) .GT. nbasmax )
!
WRITE(numout,*) 'HAMMER, ib, basin_count :', ib, basin_count(ib)
!
! Here we simply put the smallest basins into the largest ones. It is really a brute force
! method but it will only be applied if everything has failed.
!
DO ii = 1,basin_count(ib)
tmp_area(ii) = fetch_basin(ib, ii)
ENDDO
!
iml = MAXLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
sbas =iml(1)
iml = MINLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
kbas = iml(1)
!
IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
& inflow_grid, inflow_basin)
ENDIF
ENDDO
ENDDO
!
ENDIF
!
!
ENDIF
!
! Now that we have reached the right truncation (resolution) we will start
! to produce the variables we will use to route the water.
!
DO ib=1,nbpt
!
! For non existing basins the route_tobasin variable is put to zero. This will allow us
! to pick up the number of basin afterwards.
!
route_togrid(ib,:) = ib
route_tobasin(ib,:) = 0
routing_area(ib,:) = 0.0
!
ENDDO
!
! Transfer the info into the definitive variables
!
DO ib=1,nbpt
DO ij=1,basin_count(ib)
routing_area(ib,ij) = basin_area(ib,ij)
topo_resid(ib,ij) = basin_topoind(ib,ij)
global_basinid(ib,ij) = basin_id(ib,ij)
route_togrid(ib,ij) = outflow_grid(ib,ij)
route_tobasin(ib,ij) = outflow_basin(ib,ij)
ENDDO
ENDDO
!
!
! Set the new convention for the outflow conditions
! Now it is based in the outflow basin and the outflow grid will
! be the same as the current.
! returnflow to the grid : nbasmax + 1
! coastal flow : nbasmax + 2
! river outflow : nbasmax + 3
!
! Here we put everything here in coastal flow. It is later where we will
! put the largest basins into river outflow.
!
DO ib=1,nbpt
DO ij=1,basin_count(ib)
! River flows
IF ( route_togrid(ib,ij) .EQ. -1 ) THEN
route_tobasin(ib,ij) = nbasmax + 2
route_togrid(ib,ij) = ib
! Coastal flows
ELSE IF ( route_togrid(ib,ij) .EQ. -2 ) THEN
route_tobasin(ib,ij) = nbasmax + 2
route_togrid(ib,ij) = ib
! Return flow
ELSE IF ( route_togrid(ib,ij) .EQ. -3 ) THEN
route_tobasin(ib,ij) = nbasmax + 1
route_togrid(ib,ij) = ib
ENDIF
ENDDO
ENDDO
!
! A second check on the data. Just make sure that each basin flows somewhere.
!
DO ib=1,nbpt
DO ij=1,basin_count(ib)
ibf = route_togrid(ib,ij)
ijf = route_tobasin(ib,ij)
IF ( ijf .GT. basin_count(ibf) .AND. ijf .LE. nbasmax) THEN
WRITE(numout,*) 'Second check'
WRITE(numout,*) 'point :', ib, ' basin :', ij
WRITE(numout,*) 'Flows into point :', ibf, ' basin :', ijf
WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(ibf)
STOP
ENDIF
ENDDO
ENDDO
!
! Verify areas of the continents
!
floflo(:,:) = 0.0
gridarea(:) = contfrac(:)*resolution(:,1)*resolution(:,2)
DO ib=1,nbpt
gridbasinarea(ib) = SUM(routing_area(ib,:))
ENDDO
!
DO ib=1,nbpt
DO ij=1,basin_count(ib)
cnt = 0
igrif = ib
ibasf = ij
DO WHILE (ibasf .LE. nbasmax .AND. cnt .LT. nbasmax*nbpt)
cnt = cnt + 1
pold = igrif
bold = ibasf
igrif = route_togrid(pold, bold)
ibasf = route_tobasin(pold, bold)
IF ( ibasf .GT. basin_count(igrif) .AND. ibasf .LE. nbasmax) THEN
WRITE(numout,*) 'We should not be here as the basin flows into the pampa'
WRITE(numout,*) 'Last correct point :', pold, bold
WRITE(numout,*) 'It pointed to in the new variables :', route_togrid(pold, bold),route_tobasin(pold, bold)
WRITE(numout,*) 'The old variables gave :', outflow_grid(pold, bold), outflow_basin(pold, bold)
WRITE(numout,*) 'Where we ended up :', igrif,ibasf
STOP
ENDIF
ENDDO
!
IF ( ibasf .GT. nbasmax ) THEN
floflo(igrif,bold) = floflo(igrif,bold) + routing_area(ib,ij)
ELSE
WRITE(numout,*) 'The flow did not end up in the ocean or in the grid cell.'
WRITE(numout,*) 'For grid ', ib, ' and basin ', ij
WRITE(numout,*) 'The last grid was ', igrif, ' and basin ', ibasf
STOP 'routing_truncate'
ENDIF
ENDDO
ENDDO
!
DO ib=1,nbpt
IF ( gridbasinarea(ib) > 0. ) THEN
ratio = gridarea(ib)/gridbasinarea(ib)
routing_area(ib,:) = routing_area(ib,:)*ratio
ENDIF
ENDDO
!
WRITE(numout,*) 'Sum of area of all outflow areas :',SUM(routing_area)
WRITE(numout,*) 'Surface of all continents :', SUM(gridarea)
!
! Redo the the distinction between river outflow and coastal flow. We can not
! take into account the return flow points.
!
ibf = 0
DO ib=1, pickmax
ff = MAXLOC(floflo)
! tdo - To take into account rivers that do not flow to the oceans
IF ( route_tobasin(ff(1), ff(2)) .GT. nbasmax ) THEN
! IF ( route_tobasin(ff(1), ff(2)) .EQ. nbasmax + 2) THEN
ibf = ibf + 1
largest_basins(ibf,:) = ff(:)
ENDIF
floflo(ff(1), ff(2)) = 0.0
ENDDO
!
! Put the largest basins into river flows.
!
IF ( ibf .LT. num_largest) THEN
WRITE(numout,*) 'Not enough basins to choose the ', num_largest, 'largest'
STOP 'routing_truncate'
ENDIF
!
!
!
DO ib=1, num_largest
route_tobasin(largest_basins(ib,1),largest_basins(ib,2)) = nbasmax + 3
ENDDO
!
WRITE(numout,*) 'NUMBER OF RIVERS :', COUNT(route_tobasin .GE. nbasmax + 3)
!
END SUBROUTINE routing_truncate
!
!-------------------------------------------------------------------------------------
!
SUBROUTINE routing_killbas(nbpt, ib, tokill, totakeover, nwbas, basin_count, basin_area, basin_topoind,&
& fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
& inflow_grid, inflow_basin)
!
!
IMPLICIT NONE
!
! The aim of this routine is to kill a basin (that is put into another larger one). When
! we do this we need to be careful and change all associated variables.
!
INTEGER(i_std) :: tokill, totakeover
INTEGER(i_std) :: nbpt, ib
!
INTEGER(i_std) :: nwbas
INTEGER(i_std), DIMENSION(nbpt) :: basin_count
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_id
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: basin_flowdir
REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_area
REAL(r_std), DIMENSION(nbpt,nwbas) :: basin_topoind
REAL(r_std), DIMENSION(nbpt,nwbas) :: fetch_basin
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_grid
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: outflow_basin
INTEGER(i_std), DIMENSION(nbpt,nwbas) :: inflow_number
INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_basin
INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas) :: inflow_grid
!
! LOCAL
!
INTEGER(i_std) :: inf, ibs, ing, inb, ibasf, igrif, it
LOGICAL :: doshift
!
! Update the information needed in the basin "totakeover"
! For the moment only area
!!$ !
!!$ WRITE(numout,*) 'KILL BASIN :', ib, tokill, totakeover, basin_id(ib,tokill), basin_id(ib,totakeover)
!!$ !
!
basin_area(ib, totakeover) = basin_area(ib, totakeover) + basin_area(ib, tokill)
basin_topoind(ib, totakeover) = (basin_topoind(ib, totakeover) + basin_topoind(ib, tokill))/2.0
!
! Add the fetch of the basin will kill to the one which gets the water
!
fetch_basin(ib, totakeover) = fetch_basin(ib, totakeover) + fetch_basin(ib, tokill)
igrif = outflow_grid(ib,totakeover)
ibasf = outflow_basin(ib,totakeover)
!
inf = 0
DO WHILE (igrif .GT. 0)
fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) + fetch_basin(ib, tokill)
it = outflow_grid(igrif, ibasf)
ibasf = outflow_basin(igrif, ibasf)
igrif = it
inf = inf + 1
ENDDO
!
! Take out the basin we have just rerouted from the fetch of the basins in which it used to flow.
!
igrif = outflow_grid(ib,tokill)
ibasf = outflow_basin(ib,tokill)
!
DO WHILE (igrif .GT. 0)
fetch_basin(igrif,ibasf) = fetch_basin(igrif,ibasf) - fetch_basin(ib, tokill)
it = outflow_grid(igrif, ibasf)
ibasf = outflow_basin(igrif, ibasf)
igrif = it
ENDDO
!
! Redirect the flows which went into the basin to be killed before we change everything
!
DO inf = 1, inflow_number(ib, tokill)
outflow_basin(inflow_grid(ib, tokill, inf), inflow_basin(ib, tokill, inf)) = totakeover
inflow_number(ib, totakeover) = inflow_number(ib, totakeover) + 1
inflow_grid(ib, totakeover, inflow_number(ib, totakeover)) = inflow_grid(ib, tokill, inf)
inflow_basin(ib, totakeover, inflow_number(ib, totakeover)) = inflow_basin(ib, tokill, inf)
ENDDO
!
! Take out the basin to be killed from the list of inflow basins of the downstream basin
! (In case the basin does not flow into an ocean or lake)
!
IF ( outflow_grid(ib,tokill) .GT. 0) THEN
!
ing = outflow_grid(ib, tokill)
inb = outflow_basin(ib, tokill)
doshift = .FALSE.
!
DO inf = 1, inflow_number(ing, inb)
IF ( doshift ) THEN
inflow_grid(ing, inb, inf-1) = inflow_grid(ing, inb, inf)
inflow_basin(ing, inb, inf-1) = inflow_basin(ing, inb, inf)
ENDIF
IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
doshift = .TRUE.
ENDIF
ENDDO
!
! This is only to allow for the last check
!
inf = inflow_number(ing, inb)
IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
doshift = .TRUE.
ENDIF
!
IF ( .NOT. doshift ) THEN
WRITE(numout,*) 'Strange we did not find the basin to kill in the downstream basin'
STOP 'routing_killbas'
ENDIF
inflow_number(ing, inb) = inflow_number(ing, inb) - 1
!
ENDIF
!
! Now remove from the arrays the information of basin "tokill"
!
basin_id(ib, tokill:basin_count(ib)-1) = basin_id(ib, tokill+1:basin_count(ib))
basin_flowdir(ib, tokill:basin_count(ib)-1) = basin_flowdir(ib, tokill+1:basin_count(ib))
basin_area(ib, tokill:basin_count(ib)-1) = basin_area(ib, tokill+1:basin_count(ib))
basin_area(ib, basin_count(ib):nwbas) = 0.0
basin_topoind(ib, tokill:basin_count(ib)-1) = basin_topoind(ib, tokill+1:basin_count(ib))
basin_topoind(ib, basin_count(ib):nwbas) = 0.0
fetch_basin(ib, tokill:basin_count(ib)-1) = fetch_basin(ib, tokill+1:basin_count(ib))
fetch_basin(ib, basin_count(ib):nwbas) = 0.0
!
! Before we remove the information from the outflow fields we have to correct the corresponding inflow fields
! of the grids into which the flow goes
!
DO ibs = tokill+1,basin_count(ib)
ing = outflow_grid(ib, ibs)
inb = outflow_basin(ib, ibs)
IF ( ing .GT. 0 ) THEN
DO inf = 1, inflow_number(ing, inb)
IF ( inflow_grid(ing,inb,inf) .EQ. ib .AND. inflow_basin(ing,inb,inf) .EQ. ibs) THEN
inflow_basin(ing,inb,inf) = ibs - 1
ENDIF
ENDDO
ENDIF
ENDDO
outflow_grid(ib, tokill:basin_count(ib)-1) = outflow_grid(ib, tokill+1:basin_count(ib))
outflow_basin(ib, tokill:basin_count(ib)-1) = outflow_basin(ib, tokill+1:basin_count(ib))
!
! Basins which moved down also need to redirect their incoming flows.
!
DO ibs=tokill+1, basin_count(ib)
DO inf = 1, inflow_number(ib, ibs)
outflow_basin(inflow_grid(ib, ibs, inf), inflow_basin(ib, ibs, inf)) = ibs-1
ENDDO
ENDDO
!
! Shift the inflow basins
!
DO it = tokill+1,basin_count(ib)
inflow_grid(ib, it-1, 1:inflow_number(ib,it)) = inflow_grid(ib, it, 1:inflow_number(ib,it))
inflow_basin(ib, it-1, 1:inflow_number(ib,it)) = inflow_basin(ib, it, 1:inflow_number(ib,it))
inflow_number(ib,it-1) = inflow_number(ib,it)
ENDDO
!
basin_count(ib) = basin_count(ib) - 1
!
END SUBROUTINE routing_killbas
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_names(numlar, basin_names)
!
IMPLICIT NONE
!
! Arguments
!
INTEGER(i_std), INTENT(in) :: numlar
CHARACTER(LEN=*), INTENT(inout) :: basin_names(numlar)
!
! Local
!
INTEGER(i_std), PARAMETER :: listleng=349
INTEGER(i_std) :: lenstr, i
CHARACTER(LEN=60), DIMENSION(listleng) :: list_names
CHARACTER(LEN=60) :: tmp_str
!
lenstr = LEN(basin_names(1))
!
list_names(1) = "Amazon"
list_names(2) = "Nile"
list_names(3) = "Zaire"
list_names(4) = "Mississippi"
list_names(5) = "Amur"
list_names(6) = "Parana"
list_names(7) = "Yenisei"
list_names(8) = "Ob"
list_names(9) = "Lena"
list_names(10) = "Niger"
list_names(11) = "Zambezi"
list_names(12) = "Yangtze"
list_names(13) = "Chang Jiang"
list_names(14) = "Mackenzie"
list_names(15) = "Ganges"
list_names(16) = "Chari"
list_names(17) = "Volga"
list_names(18) = "St. Lawrence"
list_names(19) = "Indus"
list_names(20) = "Syr-Darya"
list_names(21) = "Nelson"
list_names(22) = "Orinoco"
list_names(23) = "Murray"
list_names(24) = "Great Artesian Basin"
list_names(25) = "Shatt el Arab"
list_names(26) = "Orange"
list_names(27) = "Huang He"
list_names(28) = "Yukon"
list_names(29) = "Senegal"
list_names(30) = "Chott Jerid"
list_names(31) = "Jubba"
list_names(32) = "Colorado (Ari)"
list_names(33) = "Rio Grande (US)"
list_names(34) = "Danube"
list_names(35) = "Mekong"
list_names(36) = "Tocantins"
list_names(37) = "Wadi al Farigh"
list_names(38) = "Tarim"
list_names(39) = "Columbia"
list_names(40) = "Noname (GHAASBasin49)"
list_names(41) = "Kolyma"
list_names(42) = "Sao Francisco"
list_names(43) = "Amu-Darya"
list_names(44) = "Noname (GHAASBasin51)"
list_names(45) = "Dnepr"
list_names(46) = "Noname (GHAASBasin61)"
list_names(47) = "Don"
list_names(48) = "Colorado (Arg)"
list_names(49) = "Limpopo"
list_names(50) = "GHAASBasin50"
list_names(51) = "Zhujiang"
list_names(52) = "Irrawaddy"
list_names(53) = "Volta"
list_names(54) = "GHAASBasin54"
list_names(55) = "Farah"
list_names(56) = "Khatanga"
list_names(57) = "Dvina"
list_names(58) = "Urugay"
list_names(59) = "Qarqan"
list_names(60) = "Noname (GHAASBasin75)"
list_names(61) = "Parnaiba"
list_names(62) = "Noname (GHAASBasin73)"
list_names(63) = "Indigirka"
list_names(64) = "Churchill (Hud)"
list_names(65) = "Godavari"
list_names(66) = "Pur - Taz"
list_names(67) = "Pechora"
list_names(68) = "Baker"
list_names(69) = "Ural"
list_names(70) = "Neva"
list_names(71) = "Liao"
list_names(72) = "Salween"
list_names(73) = "GHAASBasin73"
list_names(74) = "Jordan"
list_names(75) = "Noname (GHAASBasin78)"
list_names(76) = "Magdalena"
list_names(77) = "Krishna"
list_names(78) = "Salado"
list_names(79) = "Fraser"
list_names(80) = "Hai Ho"
list_names(81) = "Huai"
list_names(82) = "Yana"
list_names(83) = "Noname (GHAASBasin95)"
list_names(84) = "Noname (GHAASBasin105)"
list_names(85) = "Kura"
list_names(86) = "Olenek"
list_names(87) = "Ogooue"
list_names(88) = "Taymyr"
list_names(89) = "Negro Arg"
list_names(90) = "Chubut"
list_names(91) = "GHAASBasin91"
list_names(92) = "Noname (GHAASBasin122)"
list_names(93) = "Noname (GHAASBasin120)"
list_names(94) = "Sacramento"
list_names(95) = "Fitzroy West"
list_names(96) = "Grande de Santiago"
list_names(97) = "Rufiji"
list_names(98) = "Wisla"
list_names(99) = "Noname (GHAASBasin47)"
list_names(100) = "Noname (GHAASBasin127)"
list_names(101) = "Hong"
list_names(102) = "Noname (GHAASBasin97)"
list_names(103) = "Swan-Avon"
list_names(104) = "Rhine"
list_names(105) = "Cuanza"
list_names(106) = "GHAASBasin106"
list_names(107) = "Noname (GHAASBasin142)"
list_names(108) = "Roviuna"
list_names(109) = "Essequibo"
list_names(110) = "Elbe"
list_names(111) = "Koksoak"
list_names(112) = "Chao Phraya"
list_names(113) = "Brahmani"
list_names(114) = "Noname (GHAASBasin165)"
list_names(115) = "Pyasina"
list_names(116) = "Fitzroy East"
list_names(117) = "Noname (GHAASBasin173)"
list_names(118) = "Albany"
list_names(119) = "Sanaga"
list_names(120) = "GHAASBasin120"
list_names(121) = "Noname (GHAASBasin178)"
list_names(122) = "Noname (GHAASBasin148)"
list_names(123) = "Brazos (Tex)"
list_names(124) = "GHAASBasin124"
list_names(125) = "Alabama"
list_names(126) = "Noname (GHAASBasin174)"
list_names(127) = "Noname (GHAASBasin179)"
list_names(128) = "Balsas"
list_names(129) = "Noname (GHAASBasin172)"
list_names(130) = "Burdekin"
list_names(131) = "Colorado (Texas)"
list_names(132) = "Noname (GHAASBasin150)"
list_names(133) = "Odra"
list_names(134) = "Loire"
list_names(135) = "Noname (GHAASBasin98)"
list_names(136) = "Galana"
list_names(137) = "Kuskowin"
list_names(138) = "Moose"
list_names(139) = "Narmada"
list_names(140) = "GHAASBasin140"
list_names(141) = "GHAASBasin141"
list_names(142) = "Flinders"
list_names(143) = "Kizil Irmak"
list_names(144) = "GHAASBasin144"
list_names(145) = "Save"
list_names(146) = "Roper"
list_names(147) = "Churchill (Atlantic)"
list_names(148) = "GHAASBasin148"
list_names(149) = "Victoria"
list_names(150) = "Back"
list_names(151) = "Bandama"
list_names(152) = "Severn (Can)"
list_names(153) = "Po"
list_names(154) = "GHAASBasin154"
list_names(155) = "GHAASBasin155"
list_names(156) = "GHAASBasin156"
list_names(157) = "Rhone"
list_names(158) = "Tana (Ken)"
list_names(159) = "La Grande"
list_names(160) = "GHAASBasin160"
list_names(161) = "Cunene"
list_names(162) = "Douro"
list_names(163) = "GHAASBasin163"
list_names(164) = "Nemanus"
list_names(165) = "GHAASBasin165"
list_names(166) = "Anabar"
list_names(167) = "Hayes"
list_names(168) = "Mearim"
list_names(169) = "GHAASBasin169"
list_names(170) = "Panuco"
list_names(171) = "GHAASBasin171"
list_names(172) = "Doce"
list_names(173) = "Gasgoyne"
list_names(174) = "GHAASBasin174"
list_names(175) = "GHAASBasin175"
list_names(176) = "Ashburton"
list_names(177) = "GHAASBasin177"
list_names(178) = "Peel"
list_names(179) = "Daugava"
list_names(180) = "GHAASBasin180"
list_names(181) = "Ebro"
list_names(182) = "Comoe"
list_names(183) = "Jacui"
list_names(184) = "GHAASBasin184"
list_names(185) = "Kapuas"
list_names(186) = "GHAASBasin186"
list_names(187) = "Penzhina"
list_names(188) = "Cauweri"
list_names(189) = "GHAASBasin189"
list_names(190) = "Mamberamo"
list_names(191) = "Sepik"
list_names(192) = "GHAASBasin192"
list_names(193) = "Sassandra"
list_names(194) = "GHAASBasin194"
list_names(195) = "GHAASBasin195"
list_names(196) = "Nottaway"
list_names(197) = "Barito"
list_names(198) = "GHAASBasin198"
list_names(199) = "Seine"
list_names(200) = "Tejo"
list_names(201) = "GHAASBasin201"
list_names(202) = "Gambia"
list_names(203) = "Susquehanna"
list_names(204) = "Dnestr"
list_names(205) = "Murchinson"
list_names(206) = "Deseado"
list_names(207) = "Mitchell"
list_names(208) = "Mahakam"
list_names(209) = "GHAASBasin209"
list_names(210) = "Pangani"
list_names(211) = "GHAASBasin211"
list_names(212) = "GHAASBasin212"
list_names(213) = "GHAASBasin213"
list_names(214) = "GHAASBasin214"
list_names(215) = "GHAASBasin215"
list_names(216) = "Bug"
list_names(217) = "GHAASBasin217"
list_names(218) = "Usumacinta"
list_names(219) = "Jequitinhonha"
list_names(220) = "GHAASBasin220"
list_names(221) = "Corantijn"
list_names(222) = "Fuchun Jiang"
list_names(223) = "Copper"
list_names(224) = "Tapti"
list_names(225) = "Menjiang"
list_names(226) = "Karun"
list_names(227) = "Mezen"
list_names(228) = "Guadiana"
list_names(229) = "Maroni"
list_names(230) = "GHAASBasin230"
list_names(231) = "Uda"
list_names(232) = "GHAASBasin232"
list_names(233) = "Kuban"
list_names(234) = "Colville"
list_names(235) = "Thaane"
list_names(236) = "Alazeya"
list_names(237) = "Paraiba do Sul"
list_names(238) = "GHAASBasin238"
list_names(239) = "Fortesque"
list_names(240) = "GHAASBasin240"
list_names(241) = "GHAASBasin241"
list_names(242) = "Winisk"
list_names(243) = "GHAASBasin243"
list_names(244) = "GHAASBasin244"
list_names(245) = "Ikopa"
list_names(246) = "Gilbert"
list_names(247) = "Kouilou"
list_names(248) = "Fly"
list_names(249) = "GHAASBasin249"
list_names(250) = "GHAASBasin250"
list_names(251) = "GHAASBasin251"
list_names(252) = "Mangoky"
list_names(253) = "Damodar"
list_names(254) = "Onega"
list_names(255) = "Moulouya"
list_names(256) = "GHAASBasin256"
list_names(257) = "Ord"
list_names(258) = "GHAASBasin258"
list_names(259) = "GHAASBasin259"
list_names(260) = "GHAASBasin260"
list_names(261) = "GHAASBasin261"
list_names(262) = "Narva"
list_names(263) = "GHAASBasin263"
list_names(264) = "Seal"
list_names(265) = "Cheliff"
list_names(266) = "Garonne"
list_names(267) = "Rupert"
list_names(268) = "GHAASBasin268"
list_names(269) = "Brahmani"
list_names(270) = "Sakarya"
list_names(271) = "Gourits"
list_names(272) = "Sittang"
list_names(273) = "Rajang"
list_names(274) = "Evros"
list_names(275) = "Appalachicola"
list_names(276) = "Attawapiskat"
list_names(277) = "Lurio"
list_names(278) = "Daly"
list_names(279) = "Penner"
list_names(280) = "GHAASBasin280"
list_names(281) = "GHAASBasin281"
list_names(282) = "Guadalquivir"
list_names(283) = "Nadym"
list_names(284) = "GHAASBasin284"
list_names(285) = "Saint John"
list_names(286) = "GHAASBasin286"
list_names(287) = "Cross"
list_names(288) = "Omoloy"
list_names(289) = "Oueme"
list_names(290) = "GHAASBasin290"
list_names(291) = "Gota"
list_names(292) = "Nueces"
list_names(293) = "Stikine"
list_names(294) = "Yalu"
list_names(295) = "Arnaud"
list_names(296) = "GHAASBasin296"
list_names(297) = "Jequitinhonha"
list_names(298) = "Kamchatka"
list_names(299) = "GHAASBasin299"
list_names(300) = "Grijalva"
list_names(301) = "GHAASBasin301"
list_names(302) = "Kemijoki"
list_names(303) = "Olifants"
list_names(304) = "GHAASBasin304"
list_names(305) = "Tsiribihina"
list_names(306) = "Coppermine"
list_names(307) = "GHAASBasin307"
list_names(308) = "GHAASBasin308"
list_names(309) = "Kovda"
list_names(310) = "Trinity"
list_names(311) = "Glama"
list_names(312) = "GHAASBasin312"
list_names(313) = "Luan"
list_names(314) = "Leichhardt"
list_names(315) = "GHAASBasin315"
list_names(316) = "Gurupi"
list_names(317) = "GR Baleine"
list_names(318) = "Aux Feuilles"
list_names(319) = "GHAASBasin319"
list_names(320) = "Weser"
list_names(321) = "GHAASBasin321"
list_names(322) = "GHAASBasin322"
list_names(323) = "Yesil"
list_names(324) = "Incomati"
list_names(325) = "GHAASBasin325"
list_names(326) = "GHAASBasin326"
list_names(327) = "Pungoe"
list_names(328) = "GHAASBasin328"
list_names(329) = "Meuse"
list_names(330) = "Eastmain"
list_names(331) = "Araguari"
list_names(332) = "Hudson"
list_names(333) = "GHAASBasin333"
list_names(334) = "GHAASBasin334"
list_names(335) = "GHAASBasin335"
list_names(336) = "GHAASBasin336"
list_names(337) = "Kobuk"
list_names(338) = "Altamaha"
list_names(339) = "GHAASBasin339"
list_names(340) = "Mand"
list_names(341) = "Santee"
list_names(342) = "GHAASBasin342"
list_names(343) = "GHAASBasin343"
list_names(344) = "GHAASBasin344"
list_names(345) = "Hari"
list_names(346) = "GHAASBasin346"
list_names(347) = "Wami"
list_names(348) = "GHAASBasin348"
list_names(349) = "GHAASBasin349"
!
basin_names(:) = ' '
!
DO i=1,numlar
tmp_str = list_names(i)
basin_names(i) = tmp_str(1:MIN(lenstr,LEN_TRIM(tmp_str)))
ENDDO
!
END SUBROUTINE routing_names
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_irrigmap (nbpt, index, lalo, neighbours, resolution, contfrac, &
& init_irrig, irrigated, init_flood, floodplains, init_swamp, swamp, hist_id, hist2_id)
!
! This program will interpoalte the 0.5 x 05 deg based data set to the resolution
! of the model.
!
IMPLICIT NONE
!
! INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
INTEGER(i_std), INTENT(in) :: index(nbpt) ! Index on the global map.
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in m of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box
LOGICAL, INTENT(in) :: init_irrig ! Do we need to compute irrigation ?
REAL(r_std), INTENT(out) :: irrigated(:) ! Irrigated surface in each grid-box
LOGICAL, INTENT(in) :: init_flood ! Do we need to compute floodplains
REAL(r_std), INTENT(out) :: floodplains(:) ! Surface which can be inondated in each grid-box
LOGICAL, INTENT(in) :: init_swamp ! Do we need to compute floodplains
REAL(r_std), INTENT(out) :: swamp(:) ! Surface which can be swamp in each grid-box
INTEGER(i_std), INTENT(in) :: hist_id ! Access to history file
INTEGER(i_std), INTENT(in) :: hist2_id ! Access to history file 2
!
! LOCAL
!
REAL(r_std), PARAMETER :: R_Earth = 6378000.
INTEGER(r_std), PARAMETER :: ilake = 1
INTEGER(r_std), PARAMETER :: idam = 2
INTEGER(r_std), PARAMETER :: iflood = 3
INTEGER(r_std), PARAMETER :: iswamp = 4
INTEGER(r_std), PARAMETER :: isal = 5
INTEGER(r_std), PARAMETER :: ipond = 6
INTEGER(r_std), PARAMETER :: ntype = 6
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, ilf, lastjp, nbexp, itype
REAL(r_std) :: lev(1), date, dt, coslat, pi
REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
INTEGER(i_std) :: itau(1)
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel, lon_rel, lat_ful, lon_ful
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrigated_frac
REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: flood_fracmax
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: loup_rel, lolow_rel, laup_rel, lalow_rel
REAL(r_std) :: area_irrig, area_flood(ntype), ax, ay, sgn, surp
REAL(r_std) :: lonrel, louprel, lolowrel
REAL(r_std) :: irrigmap(nbpt)
REAL(r_std) :: floodmap(nbpt)
REAL(r_std) :: swampmap(nbpt)
!
pi = 4. * ATAN(1.)
!
!Config Key = IRRIGATION_FILE
!Config Desc = Name of file which contains the map of irrigated areas
!Config Def = irrigated.nc
!Config If = IRRIGATE
!Config Help = The name of the file to be opened to read the field
!Config with the area in m^2 of the area irrigated within each
!Config 0.5 0.5 deg grid box. The map currently used is the one
!Config developed by the Center for Environmental Systems Research
!Config in Kassel (1995).
!
filename = 'irrigated.nc'
CALL getin_p('IRRIGATION_FILE',filename)
!
IF (is_root_prc) CALL flininfo(filename,iml, jml, lml, tml, fid)
CALL bcast(iml)
CALL bcast(jml)
CALL bcast(lml)
CALL bcast(tml)
!
!
ALLOCATE (lat_rel(iml,jml))
ALLOCATE (lon_rel(iml,jml))
ALLOCATE (laup_rel(iml,jml))
ALLOCATE (loup_rel(iml,jml))
ALLOCATE (lalow_rel(iml,jml))
ALLOCATE (lolow_rel(iml,jml))
ALLOCATE (lat_ful(iml+2,jml+2))
ALLOCATE (lon_ful(iml+2,jml+2))
ALLOCATE (irrigated_frac(iml,jml))
ALLOCATE (flood_fracmax(iml,jml,ntype))
!
IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
CALL bcast(lon_rel)
CALL bcast(lat_rel)
CALL bcast(lev)
CALL bcast(itau)
CALL bcast(date)
CALL bcast(dt)
!
IF (is_root_prc) CALL flinget(fid, 'irrig', iml, jml, lml, tml, 1, 1, irrigated_frac)
CALL bcast(irrigated_frac)
IF (is_root_prc) CALL flinget(fid, 'lake', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ilake))
IF (is_root_prc) CALL flinget(fid, 'dam', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,idam))
IF (is_root_prc) CALL flinget(fid, 'flood', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iflood))
IF (is_root_prc) CALL flinget(fid, 'swamp', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,iswamp))
IF (is_root_prc) CALL flinget(fid, 'saline', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,isal))
IF (is_root_prc) CALL flinget(fid, 'pond', iml, jml, lml, tml, 1, 1, flood_fracmax(:,:,ipond))
CALL bcast(flood_fracmax)
!
IF (is_root_prc) CALL flinclo(fid)
!
! Set to zero all fraction which are less than 0.5%
!
DO ip=1,iml
DO jp=1,jml
!
IF ( irrigated_frac(ip,jp) .LT. undef_sechiba-1.) THEN
irrigated_frac(ip,jp) = irrigated_frac(ip,jp)/100.
IF ( irrigated_frac(ip,jp) < 0.005 ) irrigated_frac(ip,jp) = 0.0
ENDIF
!
DO itype=1,ntype
IF ( flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
flood_fracmax(ip,jp,itype) = flood_fracmax(ip,jp,itype)/100.
IF ( flood_fracmax(ip,jp,itype) < 0.005 ) flood_fracmax(ip,jp,itype) = 0.0
ENDIF
ENDDO
!
ENDDO
ENDDO
!
WRITE(numout,*) 'lon_rel : ', MAXVAL(lon_rel), MINVAL(lon_rel)
WRITE(numout,*) 'lat_rel : ', MAXVAL(lat_rel), MINVAL(lat_rel)
WRITE(numout,*) 'irrigated_frac : ', MINVAL(irrigated_frac, MASK=irrigated_frac .GT. 0), &
& MAXVAL(irrigated_frac, MASK=irrigated_frac .LT. undef_sechiba)
WRITE(numout,*) 'flood_fracmax : ', MINVAL(flood_fracmax, MASK=flood_fracmax .GT. 0), &
& MAXVAL(flood_fracmax, MASK=flood_fracmax .LT. undef_sechiba)
!
nbexp = 0
!
! Duplicate the border assuming we have a global grid going from west to east
!
lon_ful(2:iml+1,2:jml+1) = lon_rel(1:iml,1:jml)
lat_ful(2:iml+1,2:jml+1) = lat_rel(1:iml,1:jml)
!
IF ( lon_rel(iml,1) .LT. lon_ful(2,2)) THEN
lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)
lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
ELSE
lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)-360
lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
ENDIF
IF ( lon_rel(1,1) .GT. lon_ful(iml+1,2)) THEN
lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)
lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
ELSE
lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)+360
lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
ENDIF
!
sgn = lat_rel(1,1)/ABS(lat_rel(1,1))
lat_ful(2:iml+1,1) = sgn*180 - lat_rel(1:iml,1)
sgn = lat_rel(1,jml)/ABS(lat_rel(1,jml))
lat_ful(2:iml+1,jml+2) = sgn*180 - lat_rel(1:iml,jml)
lat_ful(1,1) = lat_ful(iml+1,1)
lat_ful(iml+2,1) = lat_ful(2,1)
lat_ful(1,jml+2) = lat_ful(iml+1,jml+2)
lat_ful(iml+2,jml+2) = lat_ful(2,jml+2)
!
! Add the longitude lines to the top and bottom
!
lon_ful(:,1) = lon_ful(:,2)
lon_ful(:,jml+2) = lon_ful(:,jml+1)
!
! Get the upper and lower limits of each grid box
!
DO ip=1,iml
DO jp=1,jml
loup_rel(ip,jp) =MAX(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
lolow_rel(ip,jp) =MIN(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
laup_rel(ip,jp) =MAX(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
lalow_rel(ip,jp) =MIN(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
ENDDO
ENDDO
!
! Now we take each grid point and find out which values from the forcing we need to average
!
DO ib =1, nbpt
!
! We find the 4 limits of the grid-box. As we transform the resolution of the model
! into longitudes and latitudes we do not have the problem of periodicity.
! coslat is a help variable here !
!
coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
!
lon_up = lalo(ib,2)+ resolution(ib,1)/(2.0*coslat)
lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
!
lat_up =lalo(ib,1)+resolution(ib,2)/(2.0*coslat)
lat_low =lalo(ib,1)-resolution(ib,2)/(2.0*coslat)
!
!
! Find the grid boxes from the data that go into the model's boxes
! We still work as if we had a regular grid ! Well it needs to be localy regular so
! so that the longitude at the latitude of the last found point is close to the one of the next point.
!
lastjp = 1
area_irrig = 0.0
area_flood = 0.0
DO ip=1,iml
!
! Either the center of the data grid point is in the interval of the model grid or
! the East and West limits of the data grid point are on either sides of the border of
! the data grid.
!
!
! We find the 4 limits of the grid-box. As we transform the resolution of the model
! into longitudes and latitudes we do not have the problem of periodicity.
! coslat is a help variable here !
!
!
! To do that correctly we have to check if the grid box sits on the date-line.
!
IF ( lon_low < -180.0 ) THEN
lonrel = MOD( lon_rel(ip,lastjp) - 360.0, 360.0)
lolowrel = MOD( lolow_rel(ip,lastjp) - 360.0, 360.0)
louprel = MOD( loup_rel(ip,lastjp) - 360.0, 360.0)
!
ELSE IF ( lon_up > 180.0 ) THEN
lonrel = MOD( 360. - lon_rel(ip,lastjp), 360.0)
lolowrel = MOD( 360. - lolow_rel(ip,lastjp), 360.0)
louprel = MOD( 360. - loup_rel(ip,lastjp), 360.0)
ELSE
lonrel = lon_rel(ip,lastjp)
lolowrel = lolow_rel(ip,lastjp)
louprel = loup_rel(ip,lastjp)
ENDIF
!
!
!
IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
& lolowrel < lon_low .AND. louprel > lon_low .OR. &
& lolowrel < lon_up .AND. louprel > lon_up ) THEN
!
DO jp = 1, jml
!
! Now that we have the longitude let us find the latitude
!
IF ( lat_rel(ip,jp) > lat_low .AND. lat_rel(ip,jp) < lat_up .OR. &
& lalow_rel(ip,jp) < lat_low .AND. laup_rel(ip,jp) > lat_low .OR.&
& lalow_rel(ip,jp) < lat_up .AND. laup_rel(ip,jp) > lat_up) THEN
!
lastjp = jp
!
! Mising values in the file are assumed to be 1e20
!
IF ( lon_low < -180.0 ) THEN
lolowrel = MOD( lolow_rel(ip,jp) - 360.0, 360.0)
louprel = MOD( loup_rel(ip,jp) - 360.0, 360.0)
!
ELSE IF ( lon_up > 180.0 ) THEN
lolowrel = MOD( 360. - lolow_rel(ip,jp), 360.0)
louprel = MOD( 360. - loup_rel(ip,jp), 360.0)
ELSE
lolowrel = lolow_rel(ip,jp)
louprel = loup_rel(ip,jp)
ENDIF
!
! Get the area of the fine grid in the model grid
!
coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), 0.001 )
ax = (MIN(lon_up,louprel)-MAX(lon_low, lolowrel))*pi/180. * R_Earth * coslat
ay = (MIN(lat_up, laup_rel(ip,jp))-MAX(lat_low,lalow_rel(ip,jp)))*pi/180. * R_Earth
!
IF (irrigated_frac(ip,jp) .LT. undef_sechiba-1.) THEN
area_irrig = area_irrig + ax*ay*irrigated_frac(ip,jp)
ENDIF
!
DO itype=1,ntype
IF (flood_fracmax(ip,jp,itype) .LT. undef_sechiba-1.) THEN
area_flood(itype) = area_flood(itype) + ax*ay*flood_fracmax(ip,jp,itype)
ENDIF
ENDDO
!
ENDIF
!
ENDDO
!
ENDIF
!
ENDDO
!
! Put the total irrigated and flooded areas in the output variables
!
IF ( init_irrig ) THEN
irrigated(ib) = MIN(area_irrig, resolution(ib,1)*resolution(ib,2)*contfrac(ib))
IF ( irrigated(ib) < 0 ) THEN
WRITE(numout,*) 'We have a problem here : ', irrigated(ib)
WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
WRITE(numout,*) area_irrig
STOP
ENDIF
! Compute a diagnostic of the map.
IF(contfrac(ib).GT.0.0) THEN
irrigmap (ib) = irrigated(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) )
ELSE
irrigmap (ib) = 0.0
ENDIF
!
ENDIF
!
IF ( init_flood ) THEN
floodplains(ib) = MIN(area_flood(iflood)+area_flood(idam)+area_flood(isal), &
& resolution(ib,1)*resolution(ib,2)*contfrac(ib))
IF ( floodplains(ib) < 0 ) THEN
WRITE(numout,*) 'We have a problem here : ', floodplains(ib)
WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
WRITE(numout,*) area_flood
STOP
ENDIF
! Compute a diagnostic of the map.
IF(contfrac(ib).GT.0.0) THEN
floodmap (ib) = floodplains(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) )
ELSE
floodmap (ib) = 0.0
ENDIF
ENDIF
!
IF ( init_swamp ) THEN
swamp(ib) = MIN(area_flood(iswamp), resolution(ib,1)*resolution(ib,2)*contfrac(ib))
IF ( swamp(ib) < 0 ) THEN
WRITE(numout,*) 'We have a problem here : ', swamp(ib)
WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
WRITE(numout,*) area_flood
STOP
ENDIF
! Compute a diagnostic of the map.
IF(contfrac(ib).GT.0.0) THEN
swampmap (ib) = swamp(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) )
ELSE
swampmap (ib) = 0.0
ENDIF
ENDIF
!
!
ENDDO
!
! No compensation is done for overlapping floodplains, swamp and irrig. At least overlapping will not
! happen between floodplains and swamp alone
! IF ( init_irrig .AND. init_flood ) THEN
! DO ib = 1, nbpt
! surp = (floodplains(ib)+swamp(ib)+irrigated(ib)) / (resolution(ib,1)*resolution(ib,2)*contfrac(ib))
! IF ( surp .GT. un ) THEN
! floodplains(ib) = floodplains(ib) / surp
! swamp(ib) = swamp(ib) / surp
! irrigated(ib) = irrigated(ib) / surp
! ENDIF
! ENDDO
! ENDIF
!
IF ( init_irrig ) THEN
WRITE(numout,*) 'RESULT irrigated : ', MINVAL(irrigated), MAXVAL(irrigated)
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'irrigmap', 1, irrigmap, nbpt, index)
ELSE
CALL histwrite(hist_id, 'IrrigationMap', 1, irrigated, nbpt, index)
ENDIF
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist2_id, 'irrigmap', 1, irrigmap, nbpt, index)
ELSE
CALL histwrite(hist2_id, 'IrrigationMap', 1, irrigated, nbpt, index)
ENDIF
ENDIF
ENDIF
!
IF ( init_flood ) THEN
WRITE(numout,*) 'RESULT floodplains : ', MINVAL(floodplains), MAXVAL(floodplains)
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'floodmap', 1, floodmap, nbpt, index)
ELSE
CALL histwrite(hist_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
ENDIF
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist2_id, 'floodmap', 1, floodmap, nbpt, index)
ELSE
CALL histwrite(hist2_id, 'FloodplainsMap', 1, floodplains, nbpt, index)
ENDIF
ENDIF
ENDIF
!
IF ( init_swamp ) THEN
WRITE(numout,*) 'RESULT swamp : ', MINVAL(swamp), MAXVAL(swamp)
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'swampmap', 1, swampmap, nbpt, index)
ELSE
CALL histwrite(hist_id, 'SwampMap', 1, swamp, nbpt, index)
ENDIF
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist2_id, 'swampmap', 1, swampmap, nbpt, index)
ELSE
CALL histwrite(hist2_id, 'SwampMap', 1, swamp, nbpt, index)
ENDIF
ENDIF
ENDIF
!
!
END SUBROUTINE routing_irrigmap
!
!---------------------------------------------------------------------------------
!
SUBROUTINE routing_waterbal(nbpt, firstcall, floodout, runoff, drainage, returnflow, &
& reinfiltration, irrigation, riverflow, coastalflow)
!
IMPLICIT NONE
!
! This subroutine should allow us to check the water balance in the routing module.
!
INTEGER(i_std), INTENT(in) :: nbpt ! Domain size
LOGICAL, INTENT(in) :: firstcall ! controls behaviour
REAL(r_std), INTENT(in) :: floodout(nbpt) ! grid-point flow out of floodplains
REAL(r_std), INTENT(in) :: runoff(nbpt) ! grid-point runoff
REAL(r_std), INTENT(in) :: drainage(nbpt) ! grid-point drainage
REAL(r_std), INTENT(in) :: returnflow(nbpt) ! The water flow which returns to the grid box (kg/m^2/dt)
REAL(r_std), INTENT(in) :: reinfiltration(nbpt) ! The water flow which returns to the grid box (kg/m^2/dt)
REAL(r_std), INTENT(in) :: irrigation(nbpt) ! Irrigation flux (kg/m^2 per dt)
REAL(r_std), INTENT(in) :: riverflow(nbpt) ! Outflow of the major rivers (kg/dt)
REAL(r_std), INTENT(in) :: coastalflow(nbpt) ! Outflow on coastal points by small basins (kg/dt)
!
! We sum-up all the water we have in the warious reservoirs
!
REAL(r_std), SAVE :: totw_flood, totw_stream, totw_fast, totw_slow, totw_lake, totw_pond
REAL(r_std), SAVE :: totw_in, totw_out, totw_return, totw_irrig, totw_river, totw_coastal
REAL(r_std) :: totarea, area
!
! Just to make sure we do not get too large numbers !
!
REAL(r_std), PARAMETER :: scaling = 1.0E+6
REAL(r_std), PARAMETER :: allowed_err = 50.
!
INTEGER(i_std) :: ig
!
IF ( firstcall ) THEN
!
totw_flood = 0.0
totw_stream = 0.0
totw_fast = 0.0
totw_slow = 0.0
totw_lake = 0.0
totw_pond = 0.0
totw_in = 0.0
!
DO ig=1,nbpt
!
totarea = SUM(routing_area(ig,:))
!
totw_flood = totw_flood + SUM(flood_reservoir(ig,:)/scaling)
totw_stream = totw_stream + SUM(stream_reservoir(ig,:)/scaling)
totw_fast = totw_fast + SUM(fast_reservoir(ig,:)/scaling)
totw_slow = totw_slow + SUM(slow_reservoir(ig,:)/scaling)
totw_lake = totw_lake + lake_reservoir(ig)/scaling
totw_pond = totw_pond + pond_reservoir(ig)/scaling
!
totw_in = totw_in + (runoff(ig)*totarea + drainage(ig)*totarea - floodout(ig)*totarea)/scaling
!
ENDDO
!
ELSE
!
totw_out = 0.0
totw_return = 0.0
totw_irrig = 0.0
totw_river = 0.0
totw_coastal = 0.0
area = 0.0
!
DO ig=1,nbpt
!
totarea = SUM(routing_area(ig,:))
!
totw_flood = totw_flood - SUM(flood_reservoir(ig,:)/scaling)
totw_stream = totw_stream - SUM(stream_reservoir(ig,:)/scaling)
totw_fast = totw_fast - SUM(fast_reservoir(ig,:)/scaling)
totw_slow = totw_slow - SUM(slow_reservoir(ig,:)/scaling)
totw_lake = totw_lake - lake_reservoir(ig)/scaling
totw_pond = totw_pond - pond_reservoir(ig)/scaling
!
totw_return = totw_return + (reinfiltration(ig)+returnflow(ig))*totarea/scaling
totw_irrig = totw_irrig + irrigation(ig)*totarea/scaling
totw_river = totw_river + riverflow(ig)/scaling
totw_coastal = totw_coastal + coastalflow(ig)/scaling
!
area = area + totarea
!
ENDDO
totw_out = totw_return + totw_irrig + totw_river + totw_coastal
!
! Now we have all the information to balance our water
!
IF ( ABS((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake + totw_pond) - &
& (totw_out - totw_in)) > allowed_err ) THEN
WRITE(numout,*) 'WARNING : Water not conserved in routing. Limit at ', allowed_err, ' 10^6 kg'
WRITE(numout,*) '--Water-- change : flood stream fast ', totw_flood, totw_stream, totw_fast
WRITE(numout,*) '--Water-- change : slow, lake ', totw_slow, totw_lake
WRITE(numout,*) '--Water>>> change in the routing res. : ', totw_flood + totw_stream + totw_fast + totw_slow + totw_lake
WRITE(numout,*) '--Water input : ', totw_in
WRITE(numout,*) '--Water output : ', totw_out
WRITE(numout,*) '--Water output : return, irrig ', totw_return, totw_irrig
WRITE(numout,*) '--Water output : river, coastal ',totw_river, totw_coastal
WRITE(numout,*) '--Water>>> change by fluxes : ', totw_out - totw_in, ' Diff [mm/dt]: ', &
& ((totw_flood + totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in))/area
ENDIF
!
ENDIF
!
END SUBROUTINE routing_waterbal
!
!
END MODULE routing
ORCHIDEE/src_sechiba/sechiba_io.f90 0000754 0103600 0005670 00000041467 11164403473 016613 0 ustar acamlmd lmdjus !! This subroutines initialize a variable or an array
!! with a variable or an array of smaller rank
!! - i is for integer interface - r for real interface
!! - 0 is for a scalar - 1 for a 1D array - 2 for a 2D array
!! Thee right routines is automatically called depending type of input variable
!! This initialisation is done only if the value of input field is egal to val_exp
!!
!! If a key word is provided which is not equal to "NO_KEYWORD" or "NOKEYWORD" then
!! we try to find the value to fill in in the configuration file.
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.7 $, $Date: 2007/06/12 19:53:24 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/sechiba_io.f90,v 1.7 2007/06/12 19:53:24 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE sechiba_io
USE defprec
USE constantes
USE constantes_veg
USE ioipsl
USE sechiba_io_p
IMPLICIT NONE
INTERFACE setvar
MODULE PROCEDURE i0setvar, i10setvar, i20setvar, i11setvar, i21setvar, i22setvar
MODULE PROCEDURE r0setvar, r10setvar, r20setvar, r11setvar, r21setvar, r22setvar, r30setvar
END INTERFACE
!
! mettre la l'interface des routines utilisees:
!
! restget/put/ini histbeg/def flinopen/close
!
LOGICAL, SAVE :: long_print_setvar=.FALSE. !! change to true to have more information
CONTAINS
!! Interface for integer scalar to scalar.
SUBROUTINE i0setvar (var, val_exp, key_wd, val_put)
INTEGER(i_std), INTENT(inout) :: var !! Integer scalar to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), INTENT(in) :: val_put !! Initial value to stored
INTEGER(i_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE (0,*) "i0setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( var == val_exp ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var = val_tmp
END IF
END SUBROUTINE i0setvar
!! Interface for initialising an 1D integer array with a scalar integer.
SUBROUTINE i10setvar (var, val_exp, key_wd, val_put)
INTEGER(i_std), DIMENSION(:), INTENT(inout) :: var !! 1D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), INTENT(in) :: val_put !! Scalar value to stored
INTEGER(i_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE (0,*) "i10setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:) == val_exp ) ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:) = val_tmp
END IF
END SUBROUTINE i10setvar
!! Interface for initialising an 1D array integer with an other 1D array integer.
SUBROUTINE i11setvar (var, val_exp, key_wd, val_put)
INTEGER(i_std), DIMENSION(:), INTENT(inout) :: var !! 1D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), DIMENSION(:), INTENT(in) :: val_put !! 1D integer array to stored
INTEGER(i_std), ALLOCATABLE,DIMENSION(:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE (0,*) "i11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
ALLOCATE(val_tmp(SIZE(val_put)))
val_tmp(:) = val_put(:)
IF ( ALL( var(:) == val_exp ) ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:) = val_tmp (:)
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE i11setvar
!! Interface for initialising an 2D array integer with a scalar integer.
SUBROUTINE i20setvar (var, val_exp, key_wd, val_put)
INTEGER(i_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), INTENT(in) :: val_put !! Scalar value to stored
INTEGER(i_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
!
! this subroutine set val_put value to var if var is constant
!
!
IF (long_print_setvar) WRITE (0,*) "i20setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:,:) = val_tmp
END IF
END SUBROUTINE i20setvar
!! Interface for initialising an 2D array integer with an 1D array integer.
!! Row or column depending size of 1D array to stored.
!!
!! example: 1D 1,2,3 2D is 1, 2, 3,
!! 1, 2, 3
!!
!!
!! example: 1D 1,2,3 2D is 1, 1,
!! 2, 2,
!! 3, 3
!!
SUBROUTINE i21setvar (var, val_exp, key_wd, val_put)
INTEGER(i_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), DIMENSION(:), INTENT(in) :: val_put !! 1D integer array to stored
INTEGER(i_std), ALLOCATABLE,DIMENSION(:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
! test if the 1D array dimension is compatible with first or second
! dimension of the 2D array
IF (long_print_setvar) WRITE (0,*) "i21setvar :", key_wd, val_exp, val_put
ALLOCATE(val_tmp(SIZE(val_put)))
val_tmp(:) = val_put(:)
IF (SIZE(val_put)==SIZE(var,1)) THEN
!
! example: 1D 1.,2.,3. 2D is 1., 2., 3.,
! 1., 2., 3.
!
IF ( ALL( var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
END IF
ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN
!
! example: 1D 1.,2.,3. 2D is 1., 1.,
! 2., 2.,
! 3., 3.
!
IF ( ALL( var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
END IF
ELSE
WRITE (0,*) ' incompatible dimension var and val_put'
WRITE (0,*) ' var ', SIZE(var,1), SIZE(var,2)
WRITE (0,*) ' val_put ', SIZE(val_put)
STOP 'setvar'
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE i21setvar
!! Interface for initialising an 2D array integer with an other 2D array integer.
SUBROUTINE i22setvar (var, val_exp, key_wd, val_put)
INTEGER(i_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), DIMENSION(:,:), INTENT(in) :: val_put !! 2D integer array to stored
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE (0,*) "i21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
val_tmp(:,:) = val_put(:,:)
IF ( ALL(var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:,:) = val_tmp(:,:)
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE i22setvar
!! Interface for scalar to scalar real
SUBROUTINE r0setvar (var, val_exp, key_wd, val_put)
REAL(r_std), INTENT(inout) :: var !! Real scalar to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), INTENT(in) :: val_put !! Initial value to stored
REAL(r_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE (0,*) "r0setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( var==val_exp ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var = val_tmp
END IF
END SUBROUTINE r0setvar
!! Interface for initialising an 1D real array with a scalar real.
SUBROUTINE r10setvar (var, val_exp, key_wd, val_put)
REAL(r_std), DIMENSION(:), INTENT(inout) :: var !! 1D real array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), INTENT(in) :: val_put !! Scalar value to stored
REAL(r_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE (0,*) "r10setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:) == val_exp ) ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:) = val_tmp
END IF
END SUBROUTINE r10setvar
!! Interface for initialising an 1D array real with an other 1D array real.
SUBROUTINE r11setvar (var, val_exp, key_wd, val_put)
REAL(r_std), DIMENSION(:), INTENT(inout) :: var !! 1D real array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), DIMENSION(:), INTENT(in) :: val_put !! 1D integer array to stored
REAL(r_std), ALLOCATABLE,DIMENSION(:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE (0,*) "r11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
ALLOCATE(val_tmp(SIZE(val_put)))
val_tmp(:) = val_put(:)
IF ( ALL( var(:) == val_exp ) ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:) = val_tmp (:)
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE r11setvar
!! Interface for initialising an 2D array real with a scalar real.
SUBROUTINE r20setvar (var, val_exp, key_wd, val_put)
! interface for scalar to 2D array real
REAL(r_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D integer array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), INTENT(in) :: val_put !! Scalar value to stored
REAL(r_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE (0,*) "r20setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:,:) = val_tmp
END IF
END SUBROUTINE r20setvar
!! Interface for initialising an 2D array real with an 1D array real.
!! Row or column depending size of 1D array to stored.
!!
!! example: 1D 1.,2.,3. 2D is 1., 2., 3.,
!! 1., 2., 3.
!!
!!
!! example: 1D 1.,2.,3. 2D is 1., 1.,
!! 2., 2.,
!! 3., 3.
!!
SUBROUTINE r21setvar (var, val_exp, key_wd, val_put)
! interface for 1D array to 2D array real
REAL(r_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D real array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), DIMENSION(:), INTENT(in) :: val_put !! 1D real array to stored
REAL(r_std), ALLOCATABLE,DIMENSION(:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
! test if the 1D array dimension is compatible with first or second
! dimension of the 2D array
IF (long_print_setvar) WRITE (0,*) "r21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
ALLOCATE(val_tmp(SIZE(val_put)))
val_tmp(:) = val_put(:)
IF (SIZE(val_put)==SIZE(var,1)) THEN
!
! example: 1D 1.,2.,3. 2D is 1., 2., 3.,
! 1., 2., 3.
!
IF ( ALL( var(:,:) == val_exp ) .AND. is_key <= 0 ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
END IF
ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN
!
! example: 1D 1.,2.,3. 2D is 1., 1.,
! 2., 2.,
! 3., 3.
!
IF ( ALL( var(:,:) == val_exp ) .AND. is_key <= 0 ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
END IF
ELSE
WRITE (0,*) ' incompatible dimension var and val_put'
WRITE (0,*) ' var ', SIZE(var,1), SIZE(var,2)
WRITE (0,*) ' val_put ', SIZE(val_put)
STOP 'setvar'
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE r21setvar
!! Interface for initialising an 2D array real with an other 2D array real.
SUBROUTINE r22setvar (var, val_exp, key_wd, val_put)
! interface for 2D array to 2D array real
REAL(r_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D real array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), DIMENSION(:,:), INTENT(in) :: val_put !! 2D integer array to stored
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE (0,*) "r22setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
val_tmp(:,:) = val_put(:,:)
IF ( ALL( var(:,:) == val_exp ) .AND. is_key <= 0 ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:,:) = val_tmp(:,:)
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE r22setvar
!! Interface for initialising an 3D array real with a scalar real.
SUBROUTINE r30setvar (var, val_exp, key_wd, val_put)
! interface for scalar to 3D array real
REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: var !! 3D integer array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), INTENT(in) :: val_put !! Scalar value to stored
REAL(r_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar) WRITE(numout,*) 'r30setvar',val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:,:,:) == val_exp ) .AND. is_key <= 0 ) THEN
IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
var(:,:,:) = val_tmp
END IF
END SUBROUTINE r30setvar
END MODULE sechiba_io
ORCHIDEE/src_sechiba/sechiba_io_p.f90 0000754 0103600 0005670 00000044772 11164403473 017134 0 ustar acamlmd lmdjus !! This subroutines initialize a variable or an array
!! with a variable or an array of smaller rank
!! - i is for integer interface - r for real interface
!! - 0 is for a scalar - 1 for a 1D array - 2 for a 2D array
!! Thee right routines is automatically called depending type of input variable
!! This initialisation is done only if the value of input field is egal to val_exp
!!
!! If a key word is provided which is not equal to "NO_KEYWORD" or "NOKEYWORD" then
!! we try to find the value to fill in in the configuration file.
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.2 $, $Date: 2007/06/12 19:53:24 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/sechiba_io_p.f90,v 1.2 2007/06/12 19:53:24 ssipsl Exp $
!!
MODULE sechiba_io_p
USE defprec
USE constantes
USE constantes_veg
USE ioipsl
USE parallel
IMPLICIT NONE
INTERFACE setvar_p
MODULE PROCEDURE i0setvar_p, i10setvar_p, i20setvar_p, i11setvar_p, i21setvar_p, i22setvar_p
MODULE PROCEDURE r0setvar_p, r10setvar_p, r20setvar_p, r11setvar_p, r21setvar_p, r22setvar_p, r30setvar_p
END INTERFACE
!
! mettre la l'interface des routines utilisees:
!
! restget/put/ini histbeg/def flinopen/close
!
LOGICAL, SAVE :: long_print_setvar_p=.FALSE. !! change to true to have more information
CONTAINS
!! Interface for integer scalar to scalar.
SUBROUTINE i0setvar_p (var, val_exp, key_wd, val_put)
INTEGER(i_std), INTENT(inout) :: var !! Integer scalar to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), INTENT(in) :: val_put !! Initial value to stored
INTEGER(i_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE (0,*) "i0setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( var == val_exp ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var = val_tmp
END IF
END SUBROUTINE i0setvar_p
!! Interface for initialising an 1D integer array with a scalar integer.
SUBROUTINE i10setvar_p (var, val_exp, key_wd, val_put)
INTEGER(i_std), DIMENSION(:), INTENT(inout) :: var !! 1D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), INTENT(in) :: val_put !! Scalar value to stored
INTEGER(i_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE (0,*) "i10setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:) == val_exp ) ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:) = val_tmp
END IF
END SUBROUTINE i10setvar_p
!! Interface for initialising an 1D array integer with an other 1D array integer.
SUBROUTINE i11setvar_p (var, val_exp, key_wd, val_put, is_grid)
INTEGER(i_std), DIMENSION(:), INTENT(inout) :: var !! 1D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), DIMENSION(:), INTENT(in) :: val_put !! 1D integer array to stored
LOGICAL, OPTIONAL :: is_grid !! Parameter present indicates a setvar for a grid variable
INTEGER(i_std), ALLOCATABLE,DIMENSION(:) :: val_tmp
INTEGER(i_std), ALLOCATABLE,DIMENSION(:) :: val_tmp_g
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE (0,*) "i11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
ALLOCATE(val_tmp(SIZE(val_put)))
val_tmp(:) = val_put(:)
IF ( ALL( var(:) == val_exp ) ) THEN
IF ( is_key <= 0 ) THEN
IF (PRESENT(is_grid) ) THEN
IF (is_root_prc) &
ALLOCATE( val_tmp_g(nbp_glo) )
CALL gather( val_tmp,val_tmp_g )
IF (is_root_prc) &
CALL getin(key_wd, val_tmp_g)
CALL scatter( val_tmp,val_tmp_g )
IF (is_root_prc) &
DEALLOCATE( val_tmp_g )
ELSE
CALL getin_p(key_wd, val_tmp)
ENDIF
ENDIF
var(:) = val_tmp (:)
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE i11setvar_p
!! Interface for initialising an 2D array integer with a scalar integer.
SUBROUTINE i20setvar_p (var, val_exp, key_wd, val_put)
INTEGER(i_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), INTENT(in) :: val_put !! Scalar value to stored
INTEGER(i_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
!
! this subroutine set val_put value to var if var is constant
!
!
IF (long_print_setvar_p) WRITE (0,*) "i20setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:,:) = val_tmp
END IF
END SUBROUTINE i20setvar_p
!! Interface for initialising an 2D array integer with an 1D array integer.
!! Row or column depending size of 1D array to stored.
!!
!! example: 1D 1,2,3 2D is 1, 2, 3,
!! 1, 2, 3
!!
!!
!! example: 1D 1,2,3 2D is 1, 1,
!! 2, 2,
!! 3, 3
!!
SUBROUTINE i21setvar_p (var, val_exp, key_wd, val_put, is_grid)
INTEGER(i_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), DIMENSION(:), INTENT(in) :: val_put !! 1D integer array to stored
LOGICAL, OPTIONAL :: is_grid !! Parameter present indicates a setvar for a grid variable
INTEGER(i_std), ALLOCATABLE,DIMENSION(:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
! test if the 1D array dimension is compatible with first or second
! dimension of the 2D array
IF (long_print_setvar_p) WRITE (0,*) "i21setvar :", key_wd, val_exp, val_put
ALLOCATE(val_tmp(SIZE(val_put)))
val_tmp(:) = val_put(:)
IF (SIZE(val_put)==SIZE(var,1)) THEN
!
! example: 1D 1.,2.,3. 2D is 1., 2., 3.,
! 1., 2., 3.
!
IF ( ALL( var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
END IF
ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN
!
! example: 1D 1.,2.,3. 2D is 1., 1.,
! 2., 2.,
! 3., 3.
!
IF ( ALL( var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
END IF
ELSE
WRITE (0,*) ' incompatible dimension var and val_put'
WRITE (0,*) ' var ', SIZE(var,1), SIZE(var,2)
WRITE (0,*) ' val_put ', SIZE(val_put)
STOP 'setvar'
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE i21setvar_p
!! Interface for initialising an 2D array integer with an other 2D array integer.
SUBROUTINE i22setvar_p (var, val_exp, key_wd, val_put, is_grid)
INTEGER(i_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D integer array to modify
INTEGER(i_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
INTEGER(i_std), DIMENSION(:,:), INTENT(in) :: val_put !! 2D integer array to stored
LOGICAL, OPTIONAL :: is_grid !! Parameter present indicates a setvar for a grid variable
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE (0,*) "i21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
val_tmp(:,:) = val_put(:,:)
IF ( ALL(var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:,:) = val_tmp(:,:)
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE i22setvar_p
!! Interface for scalar to scalar real
SUBROUTINE r0setvar_p (var, val_exp, key_wd, val_put)
REAL(r_std), INTENT(inout) :: var !! Real scalar to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), INTENT(in) :: val_put !! Initial value to stored
REAL(r_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE (0,*) "r0setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( var==val_exp ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var = val_tmp
END IF
END SUBROUTINE r0setvar_p
!! Interface for initialising an 1D real array with a scalar real.
SUBROUTINE r10setvar_p (var, val_exp, key_wd, val_put)
REAL(r_std), DIMENSION(:), INTENT(inout) :: var !! 1D real array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), INTENT(in) :: val_put !! Scalar value to stored
REAL(r_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE (0,*) "r10setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:) == val_exp ) ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:) = val_tmp
END IF
END SUBROUTINE r10setvar_p
!! Interface for initialising an 1D array real with an other 1D array real.
SUBROUTINE r11setvar_p (var, val_exp, key_wd, val_put, is_grid)
REAL(r_std), DIMENSION(:), INTENT(inout) :: var !! 1D real array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), DIMENSION(:), INTENT(in) :: val_put !! 1D integer array to stored
LOGICAL, OPTIONAL :: is_grid !! Parameter present indicates a setvar for a grid variable
REAL(r_std), ALLOCATABLE,DIMENSION(:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE (0,*) "r11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
ALLOCATE(val_tmp(SIZE(val_put)))
val_tmp(:) = val_put(:)
IF ( ALL( var(:) == val_exp ) ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:) = val_tmp (:)
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE r11setvar_p
!! Interface for initialising an 2D array real with a scalar real.
SUBROUTINE r20setvar_p (var, val_exp, key_wd, val_put)
! interface for scalar to 2D array real
REAL(r_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D integer array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), INTENT(in) :: val_put !! Scalar value to stored
REAL(r_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE (0,*) "r20setvar :", key_wd, val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:,:) == val_exp ) ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:,:) = val_tmp
END IF
END SUBROUTINE r20setvar_p
!! Interface for initialising an 2D array real with an 1D array real.
!! Row or column depending size of 1D array to stored.
!!
!! example: 1D 1.,2.,3. 2D is 1., 2., 3.,
!! 1., 2., 3.
!!
!!
!! example: 1D 1.,2.,3. 2D is 1., 1.,
!! 2., 2.,
!! 3., 3.
!!
SUBROUTINE r21setvar_p (var, val_exp, key_wd, val_put, is_grid)
! interface for 1D array to 2D array real
REAL(r_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D real array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), DIMENSION(:), INTENT(in) :: val_put !! 1D real array to stored
LOGICAL, OPTIONAL :: is_grid !! Parameter present indicates a setvar for a grid variable
REAL(r_std), ALLOCATABLE,DIMENSION(:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
! test if the 1D array dimension is compatible with first or second
! dimension of the 2D array
IF (long_print_setvar_p) WRITE (0,*) "r21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
ALLOCATE(val_tmp(SIZE(val_put)))
val_tmp(:) = val_put(:)
IF (SIZE(val_put)==SIZE(var,1)) THEN
!
! example: 1D 1.,2.,3. 2D is 1., 2., 3.,
! 1., 2., 3.
!
IF ( ALL( var(:,:) == val_exp ) .AND. is_key <= 0 ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
END IF
ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN
!
! example: 1D 1.,2.,3. 2D is 1., 1.,
! 2., 2.,
! 3., 3.
!
IF ( ALL( var(:,:) == val_exp ) .AND. is_key <= 0 ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
END IF
ELSE
WRITE (0,*) ' incompatible dimension var and val_put'
WRITE (0,*) ' var ', SIZE(var,1), SIZE(var,2)
WRITE (0,*) ' val_put ', SIZE(val_put)
STOP 'setvar'
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE r21setvar_p
!! Interface for initialising an 2D array real with an other 2D array real.
SUBROUTINE r22setvar_p (var, val_exp, key_wd, val_put, is_grid)
! interface for 2D array to 2D array real
REAL(r_std), DIMENSION(:,:), INTENT(inout) :: var !! 2D real array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), DIMENSION(:,:), INTENT(in) :: val_put !! 2D integer array to stored
LOGICAL, OPTIONAL :: is_grid !! Parameter present indicates a setvar for a grid variable
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE (0,*) "r22setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
val_tmp(:,:) = val_put(:,:)
IF ( ALL( var(:,:) == val_exp ) .AND. is_key <= 0 ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:,:) = val_tmp(:,:)
END IF
DEALLOCATE(val_tmp)
END SUBROUTINE r22setvar_p
!! Interface for initialising an 3D array real with a scalar real.
SUBROUTINE r30setvar_p (var, val_exp, key_wd, val_put)
! interface for scalar to 3D array real
REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: var !! 3D integer array to modify
REAL(r_std), INTENT(in) :: val_exp !! Exceptional value
CHARACTER(LEN=*), INTENT(in) :: key_wd !! The Key word we will look for
REAL(r_std), INTENT(in) :: val_put !! Scalar value to stored
REAL(r_std) :: val_tmp
INTEGER(i_std) :: is_key
is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
IF (long_print_setvar_p) WRITE(numout,*) 'r30setvar',val_exp, val_put
val_tmp = val_put
IF ( ALL( var(:,:,:) == val_exp ) .AND. is_key <= 0 ) THEN
IF ( is_key <= 0 ) THEN
CALL getin_p(key_wd, val_tmp)
ENDIF
var(:,:,:) = val_tmp
END IF
END SUBROUTINE r30setvar_p
END MODULE sechiba_io_p
ORCHIDEE/src_sechiba/thermosoil.f90 0000754 0103600 0005670 00000077321 11164403473 016711 0 ustar acamlmd lmdjus !!
!! This module computes soil thermodynamic
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.13 $, $Date: 2007/06/12 20:06:12 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/thermosoil.f90,v 1.13 2007/06/12 20:06:12 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE thermosoil
! routines called : restput, restget
!
USE ioipsl
!
! modules used :
USE constantes
USE constantes_soil
USE sechiba_io
USE grid
USE parallel
IMPLICIT NONE
! public routines :
! thermosoil_main
PRIVATE
PUBLIC :: thermosoil_main,thermosoil_clear
!
! variables used inside thermosoil module : declaration and initialisation
!
LOGICAL, SAVE :: l_first_thermosoil=.TRUE. !! Initialisation has to be done one time
CHARACTER(LEN=80), SAVE :: file_ext !! Extention for I/O filename
CHARACTER(LEN=80) , SAVE :: var_name !! To store variables names for I/O
REAL(r_std), SAVE :: lambda, cstgrnd, lskin, fz1, zalph
! two dimensions array allocated, computed, saved and got in thermosoil module
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: ptn !! Different levels soil temperature
! one dimension array allocated, computed and used in thermosoil module exclusively
REAL(r_std), SAVE, DIMENSION (ngrnd) :: zz !!
REAL(r_std), SAVE, DIMENSION (ngrnd) :: zz_coef
REAL(r_std), SAVE, DIMENSION (ngrnd) :: dz1 !!
REAL(r_std), SAVE, DIMENSION (ngrnd) :: dz2 !!
! one dimension array allocated, computed and used in thermosoil module exclusively
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: z1 !!
! two dimensions arrays allocated, computed and used in thermosoil module exclusively
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: cgrnd !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dgrnd !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: pcapa !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: pkappa !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: zdz1 !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: zdz2 !!
!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: pcapa_en !! Capacity used for energy_incr calculation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: ptn_beg !! Temperature at the beginning of the time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: temp_sol_beg !! Surface temperature at the beginning of the timestep
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: surfheat_incr !! Change in soil heat
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: coldcont_incr !! Change in snow cold content
!!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: wetdiag !! Soil weetness on the thermodynamical levels
!!
CONTAINS
!! Main routine for *thermosoil* module.
!!
!! Algorithm:
!! - call thermosoil_var_init to initialise variables
!! - call thermosoil_coef for coefficient
!! - call thermosoil_profile for soil profiling
!!
!! @call thermosoil_var_init
!! @call thermosoil_coef
!! @call thermosoil_profile
!!
SUBROUTINE thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexgrnd, &
& temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std),INTENT (in) :: rest_id,hist_id !! _Restart_ file and history file identifier
INTEGER(i_std),INTENT (in) :: hist2_id !! history file 2 identifier
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for _restart_ file to write
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std),DIMENSION (kjpindex*ngrnd), INTENT (in) :: indexgrnd !! Indeces of the points on the 3D map
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: snow !! Snow quantity
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: soilcap !! Soil capacity
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: soilflx
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in) :: shumdiag !! Diagnostic of relative humidity
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: stempdiag !! diagnostic temp profile
!
! do initialisation
!
IF (l_first_thermosoil) THEN
IF (long_print) WRITE (numout,*) ' l_first_thermosoil : call thermosoil_init '
!
! do needed allocation
!
CALL thermosoil_init (kjit, ldrestart_read, kjpindex, index, rest_id)
!
! computes some physical constantes and array depending soil level depth
!
CALL thermosoil_var_init (kjpindex, zz, zz_coef, dz1, dz2, pkappa, pcapa, pcapa_en, shumdiag, stempdiag)
!
! computes cgrd and dgrd coefficient from previous time step (restart)
!
CALL thermosoil_coef (kjpindex, dtradia, temp_sol_new, snow, ptn, soilcap, soilflx, zz, dz1, dz2, z1, zdz1,&
& zdz2, cgrnd, dgrnd, pcapa, pcapa_en, pkappa)
CALL thermosoil_energy (kjpindex, temp_sol_new, soilcap, .TRUE.)
RETURN
ENDIF
!
! prepares restart file for the next simulation
!
IF (ldrestart_write) THEN
IF (long_print) WRITE (numout,*) ' we have to complete restart file with THERMOSOIL variables'
var_name= 'ptn'
CALL restput_p(rest_id, var_name, nbp_glo, ngrnd, 1, kjit, ptn, 'scatter', nbp_glo, index_g)
RETURN
END IF
!
! Put the soil wetnesss diagnostic on the levels of the soil temprature
!
CALL thermosoil_humlev(kjpindex, shumdiag)
!
! computes profile with previous cgrd and dgrd coefficient
!
CALL thermosoil_profile (kjpindex, temp_sol_new, ptn, stempdiag)
CALL thermosoil_energy (kjpindex, temp_sol_new, soilcap, .FALSE.)
!
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'ptn', kjit, ptn, kjpindex*ngrnd, indexgrnd)
ELSE
CALL histwrite(hist_id, 'SoilTemp', kjit, ptn, kjpindex*ngrnd, indexgrnd)
CALL histwrite(hist_id, 'Qg', kjit, soilflx, kjpindex, index)
CALL histwrite(hist_id, 'DelSurfHeat', kjit, surfheat_incr, kjpindex, index)
CALL histwrite(hist_id, 'DelColdCont', kjit, coldcont_incr, kjpindex, index)
ENDIF
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist2_id, 'ptn', kjit, ptn, kjpindex*ngrnd, indexgrnd)
ELSE
CALL histwrite(hist2_id, 'SoilTemp', kjit, ptn, kjpindex*ngrnd, indexgrnd)
CALL histwrite(hist2_id, 'Qg', kjit, soilflx, kjpindex, index)
CALL histwrite(hist2_id, 'DelSurfHeat', kjit, surfheat_incr, kjpindex, index)
CALL histwrite(hist2_id, 'DelColdCont', kjit, coldcont_incr, kjpindex, index)
ENDIF
ENDIF
!
! computes cgrd and dgrd coefficient
!
CALL thermosoil_coef (kjpindex, dtradia, temp_sol_new, snow, ptn, soilcap, soilflx, zz, dz1, dz2, z1, zdz1,&
& zdz2, cgrnd, dgrnd, pcapa, pcapa_en, pkappa)
IF (long_print) WRITE (numout,*) ' thermosoil_main done '
END SUBROUTINE thermosoil_main
!! Initialisation for *thermosoil* module.
!! - does dynamic allocation for local arrays
!! - reads _restart_ file or set initial values to a raisonable value
!!
SUBROUTINE thermosoil_init(kjit, ldrestart_read, kjpindex, index, rest_id)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjit !! Time step number
LOGICAL,INTENT (in) :: ldrestart_read !! Logical for restart file to read
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std), INTENT (in) :: rest_id !! _Restart_ file identifier
! input fields
! output fields
! local declaration
INTEGER(i_std) :: ier
! initialisation
IF (l_first_thermosoil) THEN
l_first_thermosoil=.FALSE.
ELSE
WRITE (numout,*) ' l_first_thermosoil false . we stop '
STOP 'thermosoil_init'
ENDIF
! two dimensions array allocation
ALLOCATE (ptn(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in ptn allocation. We stop. We need ',kjpindex,' fois ',ngrnd,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
! one dimension array allocation
ALLOCATE (z1(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in z1 allocation. We STOP. We need ',kjpindex,' words '
STOP 'thermosoil_init'
END IF
! two dimension array allocation
ALLOCATE (cgrnd(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in cgrnd allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
ALLOCATE (dgrnd(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in dgrnd allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
ALLOCATE (pcapa(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in pcapa allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
ALLOCATE (pkappa(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in pkappa allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
ALLOCATE (zdz1(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in zdz1 allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
ALLOCATE (zdz2(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in zdz2 allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
ALLOCATE (surfheat_incr(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in surfheat_incr allocation. We STOP. We need ',kjpindex,' words = '&
& , kjpindex
STOP 'thermosoil_init'
END IF
ALLOCATE (coldcont_incr(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in coldcont_incr allocation. We STOP. We need ',kjpindex,' words = '&
& , kjpindex
STOP 'thermosoil_init'
END IF
ALLOCATE (pcapa_en(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in pcapa_en allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
ALLOCATE (ptn_beg(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in ptn_beg allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
ALLOCATE (temp_sol_beg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in ptn_beg allocation. We STOP. We need ',kjpindex,' words = '&
& , kjpindex
STOP 'thermosoil_init'
END IF
ALLOCATE (wetdiag(kjpindex,ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in wetdiag allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words = '&
& , kjpindex*ngrnd
STOP 'thermosoil_init'
END IF
!
! open restart input file done by sechiba_init
! and read data from restart input file for THERMOSOIL process
IF (ldrestart_read) THEN
IF (long_print) WRITE (numout,*) ' we have to READ a restart file for THERMOSOIL variables'
var_name= 'ptn'
CALL ioconf_setatt('UNITS', 'K')
CALL ioconf_setatt('LONG_NAME','Soil Temperature profile')
CALL restget_p (rest_id, var_name, nbp_glo, ngrnd, 1, kjit, .TRUE., ptn, "gather", nbp_glo, index_g)
!
! change restart If they were not found in the restart file
!
!Config Key = THERMOSOIL_TPRO
!Config Desc = Initial soil temperature profile if not found in restart
!Config Def = 280.
!Config Help = The initial value of the temperature profile in the soil if
!Config its value is not found in the restart file. This should only
!Config be used if the model is started without a restart file. Here
!Config we only require one value as we will assume a constant
!Config throughout the column.
!
CALL setvar_p (ptn, val_exp,'THERMOSOIL_TPRO',280._r_std)
ENDIF
IF (long_print) WRITE (numout,*) ' thermosoil_init done '
END SUBROUTINE thermosoil_init
!! Function for distributing the levels
!!
SUBROUTINE thermosoil_clear()
l_first_thermosoil=.TRUE.
IF ( ALLOCATED (ptn)) DEALLOCATE (ptn)
IF ( ALLOCATED (z1)) DEALLOCATE (z1)
IF ( ALLOCATED (cgrnd)) DEALLOCATE (cgrnd)
IF ( ALLOCATED (dgrnd)) DEALLOCATE (dgrnd)
IF ( ALLOCATED (pcapa)) DEALLOCATE (pcapa)
IF ( ALLOCATED (pkappa)) DEALLOCATE (pkappa)
IF ( ALLOCATED (zdz1)) DEALLOCATE (zdz1)
IF ( ALLOCATED (zdz2)) DEALLOCATE (zdz2)
IF ( ALLOCATED (pcapa_en)) DEALLOCATE (pcapa_en)
IF ( ALLOCATED (ptn_beg)) DEALLOCATE (ptn_beg)
IF ( ALLOCATED (temp_sol_beg)) DEALLOCATE (temp_sol_beg)
IF ( ALLOCATED (surfheat_incr)) DEALLOCATE (surfheat_incr)
IF ( ALLOCATED (coldcont_incr)) DEALLOCATE (coldcont_incr)
IF ( ALLOCATED (wetdiag)) DEALLOCATE (wetdiag)
END SUBROUTINE thermosoil_clear
!!
!!
FUNCTION fz(rk) RESULT (fz_result)
! interface
! input value
REAL(r_std), INTENT(in) :: rk
! output value
REAL(r_std) :: fz_result
fz_result = fz1 * (zalph ** rk - un) / (zalph - un)
END FUNCTION fz
!! Thermosoil's variables initialisation
!!
SUBROUTINE thermosoil_var_init(kjpindex, zz, zz_coef, dz1, dz2, pkappa, pcapa, pcapa_en, shumdiag, stempdiag)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
! output fields
REAL(r_std), DIMENSION (ngrnd), INTENT(out) :: zz !!
REAL(r_std), DIMENSION (ngrnd), INTENT(out) :: zz_coef
REAL(r_std), DIMENSION (ngrnd), INTENT(out) :: dz1 !!
REAL(r_std), DIMENSION (ngrnd), INTENT(out) :: dz2 !! tailles des couches
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: pcapa !!
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: pcapa_en
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: pkappa !!
REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (in) :: shumdiag !! Diagnostic humidity profile
REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (out) :: stempdiag !! Diagnostic temp profile
! local declaration
INTEGER(i_std) :: ier, ji, jg
REAL(r_std) :: sum
!
! 0. initialisation
!
cstgrnd=SQRT(one_day / pi)
lskin = SQRT(so_cond / so_capa * one_day / pi)
fz1 = 0.3_r_std * cstgrnd
zalph = deux
!
! 1. Computing the depth of the Temperature level, using a
! non dimentional variable x = z/lskin, lskin beeing
! the skin depth
!
DO jg=1,ngrnd
!!! This needs to be solved soon. Either we allow CPP options in SECHIBA or the VPP
!!! fixes its compiler !
!!!#ifdef VPP5000
dz2(jg) = fz(REAL(jg,r_std)-undemi+undemi) - fz(REAL(jg-1,r_std)-undemi+undemi)
!!!#else
!!! dz2(jg) = fz(REAL(jg,r_std)) - fz(REAL(jg-1,r_std))
!!!#endif
ENDDO
!
! 1.2 The undimentional depth is computed.
! ------------------------------------
DO jg=1,ngrnd
zz(jg) = fz(REAL(jg,r_std) - undemi)
zz_coef(jg) = fz(REAL(jg,r_std)-undemi+undemi)
ENDDO
!
! 1.3 Converting to meters.
! --------------------
DO jg=1,ngrnd
zz(jg) = zz(jg) / cstgrnd * lskin
zz_coef(jg) = zz_coef(jg) / cstgrnd * lskin
dz2(jg) = dz2(jg) / cstgrnd * lskin
ENDDO
!
! 1.4 Computing some usefull constants.
! --------------------------------
DO jg=1,ngrnd-1
dz1(jg) = un / (zz(jg+1) - zz(jg))
ENDDO
lambda = zz(1) * dz1(1)
!
! 1.5 Get the wetness profice on this grid
! ------------------------------------
!
CALL thermosoil_humlev(kjpindex, shumdiag)
!
! 1.6 Thermal conductivity at all levels.
! ----------------------------------
DO jg = 1,ngrnd
DO ji = 1,kjpindex
pkappa(ji,jg) = so_cond_dry + wetdiag(ji,jg)*(so_cond_wet - so_cond_dry)
pcapa(ji,jg) = so_capa_dry + wetdiag(ji,jg)*(so_capa_wet - so_capa_dry)
pcapa_en(ji,jg) = so_capa_dry + wetdiag(ji,jg)*(so_capa_wet - so_capa_dry)
ENDDO
ENDDO
!
! 2. Diagnostics.
! -----------
WRITE (numout,*) 'diagnostic des niveaux dans le sol'
WRITE (numout,*) 'niveaux intermediaires et pleins'
sum = zero
DO jg=1,ngrnd
sum = sum + dz2(jg)
WRITE (numout,*) zz(jg),sum
ENDDO
!
! 3. Compute the diagnostic temperature profile
!
CALL thermosoil_diaglev(kjpindex, stempdiag)
!
!
IF (long_print) WRITE (numout,*) ' thermosoil_var_init done '
END SUBROUTINE thermosoil_var_init
!! Computation of cgrnd and dgrnd coefficient at the t time-step.
!!
!! Needs previous time step values.
!!
SUBROUTINE thermosoil_coef (kjpindex, dtradia, temp_sol_new, snow, ptn, soilcap, soilflx, zz, dz1, dz2, z1, zdz1,&
& zdz2, cgrnd, dgrnd, pcapa, pcapa_en, pkappa)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std), DIMENSION (kjpindex), INTENT (in) :: temp_sol_new !!
REAL(r_std), DIMENSION (kjpindex), INTENT (in) :: snow !!
REAL(r_std), DIMENSION (ngrnd), INTENT(in) :: zz !!
REAL(r_std), DIMENSION (ngrnd), INTENT(in) :: dz1 !!
REAL(r_std), DIMENSION (ngrnd), INTENT(in) :: dz2 !!
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT (in) :: ptn
! output fields
REAL(r_std), DIMENSION (kjpindex), INTENT (out) :: soilcap !!
REAL(r_std), DIMENSION (kjpindex), INTENT (out) :: soilflx !!
REAL(r_std), DIMENSION (kjpindex), INTENT (out) :: z1 !!
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: pcapa !!
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: pcapa_en !!
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: pkappa !!
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: cgrnd !!
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: dgrnd !!
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: zdz1 !!
REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out) :: zdz2 !!
! local declaration
INTEGER(i_std) :: ji, jg
REAL(r_std), DIMENSION(kjpindex) :: snow_h, zx1, zx2
!
! objet: computation of cgrnd and dgrnd coefficient at the t time-step.
! ------
!
! ---------------------------------------------------------------
! Computation of the Cgrd and Dgrd coefficient for the next step:
! ---------------------------------------------------------------
!
DO ji = 1,kjpindex
snow_h(ji) = snow(ji) / sn_dens
!
! Traitement special pour le premiere couche
!
IF ( snow_h(ji) .GT. zz_coef(1) ) THEN
pcapa(ji,1) = sn_capa
pcapa_en(ji,1) = sn_capa
pkappa(ji,1) = sn_cond
ELSE IF ( snow_h(ji) .GT. zero ) THEN
pcapa_en(ji,1) = sn_capa
zx1(ji) = snow_h(ji) / zz_coef(1)
zx2(ji) = ( zz_coef(1) - snow_h(ji)) / zz_coef(1)
pcapa(ji,1) = zx1(ji) * sn_capa + zx2(ji) * so_capa_wet
pkappa(ji,1) = un / ( zx1(ji) / sn_cond + zx2(ji) / so_cond_wet )
ELSE
pcapa(ji,1) = so_capa_dry + wetdiag(ji,1)*(so_capa_wet - so_capa_dry)
pkappa(ji,1) = so_cond_dry + wetdiag(ji,1)*(so_cond_wet - so_cond_dry)
pcapa_en(ji,1) = so_capa_dry + wetdiag(ji,1)*(so_capa_wet - so_capa_dry)
ENDIF
!
DO jg = 2, ngrnd - 2
IF ( snow_h(ji) .GT. zz_coef(jg) ) THEN
pcapa(ji,jg) = sn_capa
pkappa(ji,jg) = sn_cond
pcapa_en(ji,jg) = sn_capa
ELSE IF ( snow_h(ji) .GT. zz_coef(jg-1) ) THEN
zx1(ji) = (snow_h(ji) - zz_coef(jg-1)) / (zz_coef(jg) - zz_coef(jg-1))
zx2(ji) = ( zz_coef(jg) - snow_h(ji)) / (zz_coef(jg) - zz_coef(jg-1))
pcapa(ji,jg) = zx1(ji) * sn_capa + zx2(ji) * so_capa_wet
pkappa(ji,jg) = un / ( zx1(ji) / sn_cond + zx2(ji) / so_cond_wet )
pcapa_en(ji,jg) = sn_capa
ELSE
pcapa(ji,jg) = so_capa_dry + wetdiag(ji,jg)*(so_capa_wet - so_capa_dry)
pkappa(ji,jg) = so_cond_dry + wetdiag(ji,jg)*(so_cond_wet - so_cond_dry)
pcapa_en(ji,jg) = so_capa_dry + wetdiag(ji,jg)*(so_capa_wet - so_capa_dry)
ENDIF
ENDDO
!
!
ENDDO
!
DO jg=1,ngrnd
DO ji=1,kjpindex
zdz2(ji,jg)=pcapa(ji,jg) * dz2(jg)/dtradia
ENDDO
ENDDO
!
DO jg=1,ngrnd-1
DO ji=1,kjpindex
zdz1(ji,jg) = dz1(jg) * pkappa(ji,jg)
ENDDO
ENDDO
!
DO ji = 1,kjpindex
z1(ji) = zdz2(ji,ngrnd) + zdz1(ji,ngrnd-1)
cgrnd(ji,ngrnd-1) = zdz2(ji,ngrnd) * ptn(ji,ngrnd) / z1(ji)
dgrnd(ji,ngrnd-1) = zdz1(ji,ngrnd-1) / z1(ji)
ENDDO
DO jg = ngrnd-1,2,-1
DO ji = 1,kjpindex
z1(ji) = un / (zdz2(ji,jg) + zdz1(ji,jg-1) + zdz1(ji,jg) * (un - dgrnd(ji,jg)))
cgrnd(ji,jg-1) = (ptn(ji,jg) * zdz2(ji,jg) + zdz1(ji,jg) * cgrnd(ji,jg)) * z1(ji)
dgrnd(ji,jg-1) = zdz1(ji,jg-1) * z1(ji)
ENDDO
ENDDO
! ---------------------------------------------------------
! computation of the surface diffusive flux from ground and
! calorific capacity of the ground:
! ---------------------------------------------------------
DO ji = 1,kjpindex
soilflx(ji) = zdz1(ji,1) * (cgrnd(ji,1) + (dgrnd(ji,1)-1.) * ptn(ji,1))
soilcap(ji) = (zdz2(ji,1) * dtradia + dtradia * (un - dgrnd(ji,1)) * zdz1(ji,1))
z1(ji) = lambda * (un - dgrnd(ji,1)) + un
soilcap(ji) = soilcap(ji) / z1(ji)
soilflx(ji) = soilflx(ji) + &
& soilcap(ji) * (ptn(ji,1) * z1(ji) - lambda * cgrnd(ji,1) - temp_sol_new(ji)) / dtradia
ENDDO
IF (long_print) WRITE (numout,*) ' thermosoil_coef done '
END SUBROUTINE thermosoil_coef
!! Computation of : the ground temperature evolution
!!
SUBROUTINE thermosoil_profile (kjpindex, temp_sol_new, ptn, stempdiag)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol_new !! New soil temperature
! modified fields
REAL(r_std),DIMENSION (kjpindex,ngrnd), INTENT (inout) :: ptn !! Different levels soil temperature
! output fields
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out) :: stempdiag !! Diagnostoc profile
! local declaration
INTEGER(i_std) :: ji, jg
!
! objet: computation of : the ground temperature evolution
! ------
!
! Method: implicit time integration
! -------
! Consecutives ground temperatures are related by:
! T(k+1) = C(k) + D(k)*T(k) (1)
! the coefficients C and D are computed at the t-dt time-step.
! Routine structure:
! -new temperatures are computed using (1)
!
!
! surface temperature
DO ji = 1,kjpindex
ptn(ji,1) = (lambda * cgrnd(ji,1) + temp_sol_new(ji)) / (lambda * (un - dgrnd(ji,1)) + un)
ENDDO
! other temperatures
DO jg = 1,ngrnd-1
DO ji = 1,kjpindex
ptn(ji,jg+1) = cgrnd(ji,jg) + dgrnd(ji,jg) * ptn(ji,jg)
ENDDO
ENDDO
CALL thermosoil_diaglev(kjpindex, stempdiag)
IF (long_print) WRITE (numout,*) ' thermosoil_profile done '
END SUBROUTINE thermosoil_profile
!!
!!
!! Diagnostic soil temperature profile on new levels
!!
!!
SUBROUTINE thermosoil_diaglev(kjpindex, stempdiag)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
!
! modified fields
!
! output fields
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out) :: stempdiag !! Diagnostoc profile
!
! local variable
!
INTEGER(i_std) :: ji, jd, jg
REAL(r_std) :: lev_diag, prev_diag, lev_prog, prev_prog
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: intfact
!
LOGICAL, PARAMETER :: check=.FALSE.
!
!
IF ( .NOT. ALLOCATED(intfact)) THEN
!
ALLOCATE(intfact(nbdl, ngrnd))
!
prev_diag = 0.0
DO jd = 1, nbdl
lev_diag = diaglev(jd)
prev_prog = 0.0
DO jg = 1, ngrnd
IF ( jg == ngrnd .AND. (prev_prog + dz2(jg)) < lev_diag ) THEN
!! Just make sure we cover the deepest layers
lev_prog = lev_diag
ELSE
lev_prog = prev_prog + dz2(jg)
ENDIF
intfact(jd,jg) = MAX(MIN(lev_diag,lev_prog)-MAX(prev_diag, prev_prog), 0.0)/(lev_diag-prev_diag)
prev_prog = lev_prog
ENDDO
prev_diag = lev_diag
ENDDO
!
IF ( check ) THEN
WRITE(numout,*) 'thermosoil_diagev -- thermosoil_diaglev -- thermosoil_diaglev --'
DO jd = 1, nbdl
WRITE(numout,*) jd, '-', intfact(jd,1:ngrnd)
ENDDO
WRITE(numout,*) "SUM -- SUM -- SUM SUM -- SUM -- SUM"
DO jd = 1, nbdl
WRITE(numout,*) jd, '-', SUM(intfact(jd,1:ngrnd))
ENDDO
WRITE(numout,*) 'thermosoil_diaglev -- thermosoil_diaglev -- thermosoil_diaglev --'
ENDIF
!
ENDIF
stempdiag(:,:) = 0.
DO jg = 1, ngrnd
DO jd = 1, nbdl
DO ji = 1, kjpindex
stempdiag(ji,jd) = stempdiag(ji,jd) + ptn(ji,jg)*intfact(jd,jg)
ENDDO
ENDDO
ENDDO
END SUBROUTINE thermosoil_diaglev
!!
!!
!! Put soil wetness on the temperature levels
!!
!!
SUBROUTINE thermosoil_humlev(kjpindex, shumdiag)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
!
! modified fields
!
! output fields
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in) :: shumdiag !! Diagnostoc profile
!
! local variable
!
INTEGER(i_std) :: ji, jd, jg
REAL(r_std) :: lev_diag, prev_diag, lev_prog, prev_prog
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: intfactw
!
LOGICAL, PARAMETER :: check=.FALSE.
!
!
IF ( .NOT. ALLOCATED(intfactw)) THEN
!
ALLOCATE(intfactw(ngrnd, nbdl))
!
prev_diag = 0.0
DO jd = 1, ngrnd
lev_diag = prev_diag + dz2(jd)
prev_prog = 0.0
DO jg = 1, nbdl
IF ( jg == nbdl .AND. diaglev(jg) < lev_diag ) THEN
!! Just make sure we cover the deepest layers
lev_prog = lev_diag
ELSE
lev_prog = diaglev(jg)
ENDIF
intfactw(jd,jg) = MAX(MIN(lev_diag,lev_prog)-MAX(prev_diag, prev_prog), 0.0)/(lev_diag-prev_diag)
prev_prog = lev_prog
ENDDO
prev_diag = lev_diag
ENDDO
!
IF ( check ) THEN
WRITE(numout,*) 'thermosoil_humlev -- thermosoil_humlev -- thermosoil_humlev --'
DO jd = 1, ngrnd
WRITE(numout,*) jd, '-', intfactw(jd,1:nbdl)
ENDDO
WRITE(numout,*) "SUM -- SUM -- SUM SUM -- SUM -- SUM"
DO jd = 1, ngrnd
WRITE(numout,*) jd, '-', SUM(intfactw(jd,1:nbdl))
ENDDO
WRITE(numout,*) 'thermosoil_humlev -- thermosoil_humlev -- thermosoil_humlev --'
ENDIF
!
ENDIF
wetdiag(:,:) = 0.
DO jg = 1, nbdl
DO jd = 1, ngrnd
DO ji = 1, kjpindex
wetdiag(ji,jd) = wetdiag(ji,jd) + shumdiag(ji,jg)*intfactw(jd,jg)
ENDDO
ENDDO
ENDDO
END SUBROUTINE thermosoil_humlev
SUBROUTINE thermosoil_energy(kjpindex, temp_sol_new, soilcap, first_call)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
LOGICAL, INTENT (in) :: first_call !!
! input fields
!
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: soilcap !! Soil capacity
!
! modified fields
!
! output fields
!
! local variable
!
INTEGER(i_std) :: ji, jg
!
!
IF (first_call) THEN
DO ji = 1, kjpindex
surfheat_incr(ji) = zero
coldcont_incr(ji) = zero
temp_sol_beg(ji) = temp_sol_new(ji)
!
DO jg = 1, ngrnd
ptn_beg(ji,jg) = ptn(ji,jg)
ENDDO
!
ENDDO
RETURN
ENDIF
DO ji = 1, kjpindex
surfheat_incr(ji) = zero
coldcont_incr(ji) = zero
ENDDO
!
! Sum up the energy content of all layers in the soil.
!
DO ji = 1, kjpindex
!
IF (pcapa_en(ji,1) .LE. sn_capa) THEN
!
! Verify the energy conservation in the surface layer
!
coldcont_incr(ji) = soilcap(ji) * (temp_sol_new(ji) - temp_sol_beg(ji))
surfheat_incr(ji) = zero
ELSE
!
! Verify the energy conservation in the surface layer
!
surfheat_incr(ji) = soilcap(ji) * (temp_sol_new(ji) - temp_sol_beg(ji))
coldcont_incr(ji) = zero
ENDIF
ENDDO
ptn_beg(:,:) = ptn(:,:)
temp_sol_beg(:) = temp_sol_new(:)
END SUBROUTINE thermosoil_energy
END MODULE thermosoil
ORCHIDEE/src_sechiba/slowproc.f90 0000754 0103600 0005670 00000504420 11164403473 016367 0 ustar acamlmd lmdjus !
! Daily update of leaf area index etc.
!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/slowproc.f90,v 1.34 2008/03/21 14:22:02 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
!
MODULE slowproc
! modules used:
USE defprec
USE constantes
USE constantes_veg
USE constantes_co2
USE ioipsl
USE sechiba_io
USE interpol_help
USE stomate
USE stomate_constants
USE grid
USE parallel
! USE Write_Field_p
IMPLICIT NONE
PRIVATE
PUBLIC slowproc_main,slowproc_clear
! To use OLD or NEW iterpollation schemes :
INTERFACE slowproc_interlai
MODULE PROCEDURE slowproc_interlai_OLD, slowproc_interlai_NEW
END INTERFACE
INTERFACE slowproc_interpol
MODULE PROCEDURE slowproc_interpol_OLD, slowproc_interpol_NEW
END INTERFACE
INTERFACE slowproc_interpol_g
MODULE PROCEDURE slowproc_interpol_OLD_g, slowproc_interpol_NEW_g
END INTERFACE
!
! variables used inside slowproc module : declaration and initialisation
!
LOGICAL, SAVE :: l_first_slowproc = .TRUE.!! Initialisation has to be done one time
REAL(r_std), SAVE :: day_counter !! Counter to verify day change
REAL(r_std), SAVE :: dt_slow !! time step of slow processes and STOMATE
!
REAL(r_std), SAVE :: clayfraction_default = 0.2
REAL(r_std), SAVE :: extcoef !! Extinction coefficient for bare soil with LAI
LOGICAL, SAVE :: land_use = .FALSE. ! Land Use
REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: veget_lastyear ! last veget
!
LOGICAL, SAVE :: read_lai = .FALSE. ! Lai Map
LOGICAL, SAVE :: old_lai = .FALSE. ! Old Lai Map interpolation
LOGICAL, SAVE :: impveg = .FALSE.
LOGICAL, SAVE :: old_veget = .FALSE. ! Old veget Map interpolation
!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: clayfraction
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: laimap
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: soilclass_default
!
CONTAINS
SUBROUTINE slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
IndexLand, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
t2m, t2m_min, temp_sol, stempdiag, &
humrel, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, frac_bare, height, veget, frac_nobio, njsc, totfrac_nobio, qsintmax, &
rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: kjpij !! Total size of the un-compressed grid
INTEGER(i_std),INTENT (in) :: kjpindex !! Domain size
REAL(r_std),INTENT (in) :: dtradia !! Time step
REAL(r_std),INTENT (in) :: date0 !! Initial date
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for _restart_ file to write
LOGICAL, INTENT(in) :: ldforcing_write !! Logical for _forcing_ file to write
LOGICAL, INTENT(in) :: ldcarbon_write !! Logical for _carbon_forcing_ file to write
INTEGER(i_std),INTENT (in) :: rest_id,hist_id !! _Restart_ file and _history_ file identifier
INTEGER(i_std),INTENT (in) :: hist2_id !! _history_ file 2 identifier
INTEGER(i_std),INTENT (in) :: rest_id_stom !! STOMATE's _Restart_ file file identifier
INTEGER(i_std),INTENT (in) :: hist_id_stom !! STOMATE's _history_ file file identifier
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: IndexLand !! Indeces of the points on the map
INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in) :: indexveg !! Indeces of the points on the 3D map
REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geogr. coordinates (latitude,longitude) (degrees)
INTEGER(i_std), DIMENSION (kjpindex,8), INTENT(in) :: neighbours !! neighoring grid points if land
REAL(r_std), DIMENSION (kjpindex,2), INTENT(in) :: resolution !! size in x an y of the grid (m)
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: contfrac !! Fraction of continent in the grid
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in) :: humrel !! Relative humidity ("moisture stress")
REAL(r_std), DIMENSION(kjpindex), INTENT(in) :: t2m !! 2 m air temperature (K)
REAL(r_std), DIMENSION(kjpindex), INTENT(in) :: t2m_min !! min. 2 m air temp. during forcing time step (K)
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol !! Surface temperature
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in) :: stempdiag !! Soil temperature
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in) :: shumdiag !! Relative soil moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: litterhumdiag !! Litter humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_snow !! Snow precipitation
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: gpp !! GPP (gC/(m**2 of total ground)/time step)
! output scalar
! output fields
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: co2_flux !! CO2 flux in gC/m**2 of average ground/second
! modified scalar
! modified fields
INTEGER(i_std), DIMENSION(kjpindex), INTENT(inout) :: njsc !! Soil type map to be created from the input map
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: lai !! Surface foliaire
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: frac_bare !! Bare soil fraction for each tile
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: height !! height (m)
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout):: frac_nobio !! Fraction of ice, lakes, cities etc. in the mesh
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: totfrac_nobio !! Total fraction of ice+lakes+cities etc. in the mesh
REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(inout):: soiltile !! fraction of soil type
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: reinf_slope !! slope coef for reinfiltration
REAL(r_std),DIMENSION (kjpindex,nvm,npco2), INTENT (inout):: assim_param!! min+max+opt temps, vcmax, vjmax for photosynthesis
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: deadleaf_cover !! fraction of soil covered by dead leaves
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: qsintmax !! Maximum water on vegetation for interception
! local declaration
INTEGER(i_std), SAVE :: lcanop !! soil level used for LAI
REAL(r_std) :: tmp_day(1)
CHARACTER(LEN=80) :: var_name !! To store variables names for I/O
INTEGER(i_std) :: yy, mm, dd
REAL(r_std) :: in_julian
REAL(r_std) :: ss
REAL(r_std), DIMENSION(kjpindex,nvm) :: resp_maint !! autotrophic resp. (gC/(m**2 of total ground)/time step)
REAL(r_std), DIMENSION(kjpindex) :: resp_hetero !! heterotrophic resp. (gC/(m**2 of total ground)/time step)
REAL(r_std), DIMENSION(kjpindex,nvm) :: resp_growth !! growth resp. (gC/(m**2 of total ground)/time step)
!
INTEGER(i_std) , SAVE :: veget_update !! update frequency in timesteps for landuse
INTEGER(i_std) , SAVE :: veget_year !! first year for landuse
INTEGER(i_std) , SAVE :: veget_year_add !! nb years to update veget map.
!
! do initialisation
!
IF (l_first_slowproc) THEN
!
! 1.1 allocation, file definitions. Restart file read for Sechiba. Set flags.
!
IF (long_print) WRITE (numout,*) ' l_first_slowproc : call slowproc_init '
CALL slowproc_init (kjit, ldrestart_read, dtradia, date0, kjpindex, IndexLand, lalo, neighbours, resolution, contfrac, &
& rest_id, read_lai, lai, frac_bare, frac_nobio, totfrac_nobio, soiltile, reinf_slope, veget, njsc, height, lcanop,&
& veget_update, veget_year, veget_year_add)
!
resp_maint = zero
resp_hetero = zero
resp_growth = zero
!
! 1.2 check time step
!
IF ( dt_slow .LT. dtradia ) THEN
WRITE(numout,*) 'slow_processes: time step smaller than forcing time step.'
STOP 'slowproc_main'
ENDIF
IF ( control%stomate_watchout .OR. control%ok_stomate ) THEN
!
! 1.3 call STOMATE for initialization
!
CALL stomate_main (kjit, kjpij, kjpindex, dtradia, dt_slow, &
ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
IndexLand, lalo, neighbours, resolution, contfrac, totfrac_nobio, clayfraction, &
t2m, t2m_min, temp_sol, stempdiag, &
humrel, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, height, veget, veget, qsintmax, &
hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux,resp_maint,resp_hetero,resp_growth)
!
ENDIF
!
IF ( .NOT. control%ok_stomate ) THEN
!
! 1.4 initialize some variables
! STOMATE diagnoses some variables for SECHIBA: height, deadleaf_cover, etc.
! IF SECHIBA is not coupled to STOMATE, then we must set these values otherwise.
!
CALL slowproc_derivvar (kjpindex, veget, lai, &
qsintmax, deadleaf_cover, assim_param, height)
ENDIF
RETURN
ENDIF
!
! Land USE for next year
IF ( (land_use) .AND. (veget_update .GT. 0) ) THEN
! if next iteration is divisibled by veget_update
IF ( mod(kjit+1, veget_update) .le. min_sechiba) THEN
!
veget_year=veget_year+veget_year_add
WRITE(numout,*) 'We are updating veget for year =' , veget_year
!
! Save veget
!
veget_lastyear(:,:) = veget(:,:)
!
CALL slowproc_update(kjpindex, lalo, neighbours, resolution, contfrac, &
& veget, frac_nobio, veget_year)
ENDIF
ENDIF
!
! prepares restart file for the next simulation
!
IF (ldrestart_write) THEN
IF (long_print) WRITE (numout,*) ' we have to complete restart file with SLOWPROC variables '
tmp_day(1) = day_counter
var_name= 'day_counter'
IF (is_root_prc) CALL restput (rest_id, var_name, 0 , 0, 0, kjit, tmp_day)
var_name= 'veget'
CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, veget, 'scatter', nbp_glo, index_g)
!
var_name= 'lai'
CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, lai, 'scatter', nbp_glo, index_g)
!
var_name= 'frac_bare'
CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, frac_bare, 'scatter', nbp_glo, index_g)
!
var_name= 'frac_nobio'
CALL restput_p (rest_id, var_name, nbp_glo, nnobio, 1, kjit, frac_nobio, 'scatter', nbp_glo, index_g)
!
var_name= 'soiltile_frac'
CALL restput_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, soiltile, 'scatter', nbp_glo, index_g)
!
var_name= 'njsc'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, REAL(njsc, r_std), 'scatter', nbp_glo, index_g)
!
var_name= 'reinf_slope'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, reinf_slope, 'scatter', nbp_glo, index_g)
!
var_name= 'clay_frac'
CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, clayfraction, 'scatter', nbp_glo, index_g)
!
! The height of the vegetation could in principle be recalculated at the beginning of the run.
! However, this is very tedious, as many special cases have to be taken into account. This variable
! is therefore saved in the restart file.
var_name= 'height'
CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, height, 'scatter', nbp_glo, index_g)
!
IF (read_lai) THEN
var_name= 'laimap'
CALL restput_p (rest_id, var_name, nbp_glo, nvm, 12, kjit, laimap)
ENDIF
!
! call STOMATE to write RESTART files
!
IF ( control%stomate_watchout .OR. control%ok_stomate ) THEN
CALL stomate_main (kjit, kjpij, kjpindex, dtradia, dt_slow, &
ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
IndexLand, lalo, neighbours, resolution, contfrac, totfrac_nobio, clayfraction, &
t2m, t2m_min, temp_sol, stempdiag, &
humrel, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, height, veget, veget, qsintmax, &
hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux,resp_maint,resp_hetero,resp_growth)
ENDIF
RETURN
END IF
IF ( control%stomate_watchout .OR. control%ok_stomate ) THEN
!
! 1 call STOMATE, either because we want to keep track of long-term variables or
! because STOMATE is activated
!
CALL stomate_main (kjit, kjpij, kjpindex, dtradia, dt_slow, &
ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
IndexLand, lalo, neighbours, resolution, contfrac, totfrac_nobio, clayfraction, &
t2m, t2m_min, temp_sol, stempdiag, &
humrel, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, height, veget, veget, qsintmax, &
hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux,resp_maint,resp_hetero,resp_growth)
IF ( .NOT. almaoutput .AND. control%ok_stomate ) THEN
CALL histwrite(hist_id, 'maint_resp', kjit, resp_maint, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'hetero_resp', kjit, resp_hetero, kjpindex, IndexLand)
CALL histwrite(hist_id, 'growth_resp', kjit, resp_growth, kjpindex*nvm, indexveg)
ENDIF
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput .AND. control%ok_stomate ) THEN
CALL histwrite(hist2_id, 'maint_resp', kjit, resp_maint, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'hetero_resp', kjit, resp_hetero, kjpindex, IndexLand)
CALL histwrite(hist2_id, 'growth_resp', kjit, resp_growth, kjpindex*nvm, indexveg)
ENDIF
ENDIF
ENDIF
IF ( .NOT. control%ok_stomate ) THEN
!
! 2 STOMATE is not activated: we have to guess lai etc.
!
!
! 2.1 update day counter
!
day_counter = day_counter + dtradia
!
! 2.2 test if we have work to do
!
IF ( NINT(day_counter) .GE. NINT(dt_slow) ) THEN
!
day_counter = zero
! 2.2.1 do daily processes if necessary
!
IF (long_print) WRITE (numout,*) 'slowproc_main : We update the daily variables'
! 2.2.2 updates lai
in_julian = itau2date(kjit, date0, dtradia)
CALL ju2ymds(in_julian, yy, mm, dd, ss)
!
CALL slowproc_lai (kjpindex, lcanop,stempdiag, &
lalo,resolution,lai,frac_bare,mm,dd,read_lai,laimap)
!
! 2.2.3 verify veget obsolete?
CALL slowproc_veget (kjpindex, lai, frac_nobio, veget)
! ajout
! totfrac_nobio(:) = zero
! DO jv = 1, nnobio
! totfrac_nobio(:) = totfrac_nobio(:) + frac_nobio(:,jv)
! ENDDO
! 2.2.4 updates qsintmax and other derived variables
CALL slowproc_derivvar (kjpindex, veget, lai, &
qsintmax, deadleaf_cover, assim_param, height)
END IF
!
! 2.3 some output fields
!
co2_flux(:) = zero
ENDIF
IF (long_print) WRITE (numout,*) ' slowproc_main done '
END SUBROUTINE slowproc_main
!!
!!
!!
SUBROUTINE slowproc_init (kjit, ldrestart_read, dtradia, date0, kjpindex, IndexLand, lalo, neighbours, resolution, contfrac, &
& rest_id, read_lai, lai, frac_bare, frac_nobio, totfrac_nobio, soiltile, &
& reinf_slope, veget, njsc, height, lcanop, &
& veget_update, veget_year, veget_year_add)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjit !! Time step number
LOGICAL, INTENT (in) :: ldrestart_read !! Logical for _restart_ file to read
REAL(r_std),INTENT (in) :: dtradia !! Time step
REAL(r_std), INTENT (in) :: date0 !! intial date
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std), INTENT (in) :: rest_id !! _Restart_ file identifier
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: IndexLand !! Indeces of the points on the map
REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geogr. coordinates (latitude,longitude) (degrees)
INTEGER(i_std), DIMENSION (kjpindex,8), INTENT(in) :: neighbours !! neighoring grid points if land
REAL(r_std), DIMENSION (kjpindex,2), INTENT(in) :: resolution !! size in x an y of the grid (m)
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: contfrac !! Fraction of continent in the grid
! output scalar
INTEGER(i_std), INTENT(out) :: lcanop !! soil level used for LAI
INTEGER(i_std), INTENT(out) :: veget_update !! update frequency in timesteps for landuse
INTEGER(i_std), INTENT(out) :: veget_year !! first year for landuse
INTEGER(i_std), INTENT(out) :: veget_year_add !! nb years to update veget map.
! output fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: lai !! Surface foliere
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: frac_bare !! Bare soil fraction for each tile
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: frac_nobio !! Fraction of ice,lakes,cities, ...
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: totfrac_nobio !! Total fraction of ice+lakes+cities+...
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: height !! Height of vegetation
REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(out) :: soiltile !! fraction of soil type subvar for hydrological processes
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: reinf_slope !! slope coef for reinfiltration
INTEGER(i_std), DIMENSION(kjpindex), INTENT(out) :: njsc !! Soil type map to be created from the input map
! local declaration
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: tmp_real
REAL(r_std) :: tmp_day(1)
REAL(r_std) :: zcanop !! soil depth taken for canopy
INTEGER(i_std) :: vtmp(1)
REAL(r_std), DIMENSION(nbdl) :: zsoil !! soil depths at diagnostic levels
CHARACTER(LEN=30) :: veget_str !! update frequency for landuse
INTEGER(i_std) :: l !! Index
CHARACTER(LEN=80) :: var_name !! To store variables names for I/O
INTEGER(i_std) :: ji, jv, ier, jst
LOGICAL :: get_slope
LOGICAL, INTENT(out) :: read_lai
REAL(r_std) :: frac_nobio1 !! temporary
REAL(r_std) :: stempdiag_bid !! only needed for an initial LAI
!! if there is no restart file
REAL(r_std), DIMENSION(kjpindex,nbdl) :: stempdiag2_bid !! matrix to store stempdiag_bid
REAL(r_std), DIMENSION (kjpindex,nscm) :: soilclass !! fraction of soil type
REAL(r_std) :: in_julian
INTEGER(i_std) :: yy, mm, dd
REAL(r_std) :: ss
!
REAL(r_std),DIMENSION (nbp_glo,nnobio) :: frac_nobio_g !! Fraction of ice, lakes, cities etc. in the mesh (global)
REAL(r_std),DIMENSION (nbp_glo,nvm) :: veget_g !! Fraction of vegetation type (globa)
!
! 1 allocation
!
ALLOCATE (tmp_real(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmp_real allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'slowproc_init'
END IF
tmp_real(:) = undef_sechiba
ALLOCATE (clayfraction(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in clayfraction allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'slowproc_init'
END IF
clayfraction(:)=undef_sechiba
ALLOCATE (soilclass_default(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nstm words = ',nscm
STOP 'hydrol_init'
END IF
soilclass_default(:)=undef_sechiba
ier=-1
ALLOCATE(veget_lastyear(kjpindex, nvm), STAT=ier)
IF (ier/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of veget_lastyear : ",ier
STOP
ENDIF
!
! Save veget
!
veget_lastyear(:,1) = un
veget_lastyear(:,2:nvm) = zero
!
! 2 read restart file
!
var_name= 'day_counter'
CALL ioconf_setatt('UNITS', 'd')
CALL ioconf_setatt('LONG_NAME','Fraction of computed day')
IF (is_root_prc) &
CALL restget (rest_id, var_name, 0 , 0 , 0, kjit, .TRUE., tmp_day)
CALL bcast(tmp_day(1))
day_counter = tmp_day(1)
! get restart value if none were found in the restart file
!
!Config Key = SECHIBA_DAY
!Config Desc = Time within the day simulated
!Config Def = 0.0
!Config Help = This is the time spent simulating the current day. This variable is
!Config prognostic as it will trigger all the computations which are
!Config only done once a day.
!
CALL setvar_p (day_counter, val_exp, 'SECHIBA_DAY', 0.0_r_std)
!
!Config Key = LAI_MAP
!Config Desc = Read the LAI map
!Config Def = n
!Config Help = It is possible to read a 12 month LAI map which will
!Config then be interpolated to daily values as needed.
!
read_lai = .FALSE.
CALL getin_p('LAI_MAP',read_lai)
!
!Config Key = EXT_COEF
!Config Desc = Extinction coefficient for bare soil with LAI
!Config If =
!Config Def = 0.5
!Config Help = will impact frac_bare
!
extcoef = 3.
CALL getin_p('EXT_COEF',extcoef)
!
var_name= 'veget'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Vegetation fraction')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., veget, "gather", nbp_glo, index_g)
!
frac_nobio(:,:) = val_exp
var_name= 'frac_nobio'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Special soil type fraction')
CALL restget_p (rest_id, var_name, nbp_glo, nnobio, 1, kjit, .TRUE., frac_nobio, "gather", nbp_glo, index_g)
!
!Config Key = LAND_USE
!Config Desc = Read a land_use vegetation map
!Config Def = n
!Config Help = pft values are needed, max time axis is 293
!
land_use = .FALSE.
CALL getin_p('LAND_USE',land_use)
IF (land_use) THEN
!
!Config Key = VEGET_YEAR
!Config Desc = Read a land_use vegetation map
!Config If = LAND_USE
!Config Def = 282
!Config Help = First year for landuse (pft map)
!
veget_year=282
CALL getin_p('VEGET_YEAR', veget_year)
!
!Config Key = VEGET_UPDATE
!Config Desc = Update vegetation frequency
!Config If = LAND_USE
!Config Def = 0Y
!Config Help = The veget datas will be update each this time step.
!
veget_update=0
WRITE(veget_str,'(a)') '0Y'
CALL getin_p('VEGET_UPDATE', veget_str)
! A VERIFIER : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!MM modif TAG 1.4 (IOIPSL 3.0 ?)
! in_julian = itau2date(kjit, date0,dtradia)
! call tlen2itau(veget_str,dtradia,in_julian,veget_update)
in_julian = itau2date(kjit, date0,dtradia)
call tlen2itau(veget_str,dtradia,in_julian,veget_update)
WRITE(numout,*) "slowproc_init : veget_update(in_julian) = ",veget_update
call tlen2itau(veget_str,dtradia,date0,veget_update)
WRITE(numout,*) "slowproc_init : veget_update(date0) = ",veget_update
!
!MM modif TAG 1.4 :
! ALLOCATE (vegetmap(kjpindex,nvm,293),stat=ier)
! IF (ier.NE.0) THEN
! WRITE (numout,*) ' error in vegetmap allocation. We stop. We need kjpindex*nvm*12 words = ',kjpindex*nvm*293
! STOP 'slowproc_init'
! END IF
! vegetmap(:,:,:) = val_exp
! !
! var_name= 'vegetmap'
! CALL ioconf_setatt('UNITS', '-')
! CALL ioconf_setatt('LONG_NAME','veget frac read')
! CALL restget (rest_id, var_name, kjpindex, nvm, 293, kjit, .TRUE., vegetmap) !
! !
! ALLOCATE (frac_nobiomap(kjpindex,nnobio,293),stat=ier)
! IF (ier.NE.0) THEN
! WRITE (numout,*) ' error in frac_nobiomap allocation. We stop. We need kjpindex*nnobio*12 words = ',kjpindex*nnobio*293
! WRITE (numout,*) ' error in frac_nobiomap allocation. We stop. We need kjpindex*nnobio*12 words = ',kjpindex*nnobio
! STOP 'slowproc_init'
! END IF
! frac_nobiomap(:,:,:) = val_exp
! !
! var_name= 'frac_nobiomap'
! CALL ioconf_setatt('UNITS', '-')
! CALL ioconf_setatt('LONG_NAME','Nobio fraction read')
! CALL restget (rest_id, var_name, kjpindex, nnobio, 293, kjit, .TRUE., frac_nobiomap)
! !
l=INDEX(TRIM(veget_str),'Y')
READ(veget_str(1:(l-1)),"(I2.2)") veget_year_add
WRITE(numout,*) "Update frequency for land use in years :",veget_year_add
ENDIF
!
var_name= 'soiltile_frac'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Fraction of each soil type')
CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., soiltile, "gather", nbp_glo, index_g)
!
var_name= 'clay_frac'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Fraction of clay in each mesh')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., clayfraction, "gather", nbp_glo, index_g)
!
var_name= 'njsc'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Index of soil type')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., tmp_real, "gather", nbp_glo, index_g)
WHERE ( tmp_real .LT. val_exp )
njsc = NINT(tmp_real)
ENDWHERE
!
var_name= 'reinf_slope'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Slope coef for reinfiltration')
CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., reinf_slope, "gather", nbp_glo, index_g)
!
var_name= 'lai'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Leaf area index')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., lai, "gather", nbp_glo, index_g)
!
var_name= 'frac_bare'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Bare soil fraction')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., frac_bare, "gather", nbp_glo, index_g)
!
! The height of the vegetation could in principle be recalculated at the beginning of the run.
! However, this is very tedious, as many special cases have to be taken into account. This variable
! is therefore saved in the restart file.
var_name= 'height'
CALL ioconf_setatt('UNITS', 'm')
CALL ioconf_setatt('LONG_NAME','Height of vegetation')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., height, "gather", nbp_glo, index_g)
!
IF (read_lai)THEN
!
ALLOCATE (laimap(kjpindex,nvm,12),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in laimap allocation. We stop. We need kjpindex*nvm*12 words = ',kjpindex*nvm*12
STOP 'slowproc_init'
END IF
laimap(:,:,:) = val_exp
!
var_name= 'laimap'
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Leaf area index read')
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 12, kjit, .TRUE., laimap)
!
ENDIF
!
!Config Key = SECHIBA_ZCANOP
!Config Desc = Soil level (m) used for canopy development (if STOMATE disactivated)
!Config Def = 0.5
!Config Help = The temperature at this soil depth is used to determine the LAI when
!Config STOMATE is not activated.
!
zcanop = 0.5_r_std
CALL setvar_p (zcanop, val_exp, 'SECHIBA_ZCANOP', 0.5_r_std)
!MM, T. d'O. : before in constantes_soil :
! diaglev = &
! & (/ 0.001, 0.004, 0.01, 0.018, 0.045, &
! & 0.092, 0.187, 0.375, 0.750, 1.5, &
! & 2.0 /)
! Place here because it is used in sechiba and stomate (then in teststomate)
! to be in sechiba when teststomate will have disapeared.
!MM Problem here with dpu which depends on soil type
DO jv = 1, nbdl-1
! first 2.0 is dpu
! second 2.0 is average
diaglev(jv) = dpu_cste/(2**(nbdl-1) -1) * ( ( 2**(jv-1) -1) + ( 2**(jv) -1) ) / 2.0
ENDDO
diaglev(nbdl) = dpu_cste
! depth at center of the levels
zsoil(1) = diaglev(1) / 2.
DO l = 2, nbdl
!!MG Erreur!!
! zsoil(l) = ( diaglev(l) - diaglev(l-1) ) / 2.
zsoil(l) = ( diaglev(l) + diaglev(l-1) ) / 2.
ENDDO
! index of this level
vtmp = MINLOC ( ABS ( zcanop - zsoil(:) ) )
lcanop = vtmp(1)
!
! Interception reservoir coefficient
!
!Config Key = 'SECHIBA_QSINT'
!Config Desc = Interception reservoir coefficient
!Config Def = 0.1
!Config Help = Transforms leaf area index into size of interception reservoir
!Config for slowproc_derivvar or stomate
qsintcst = 0.1
CALL getin_p('SECHIBA_QSINT', qsintcst)
WRITE(numout, *)' SECHIBA_QSINT, qsintcst = ', qsintcst
!Config Key = 'PREF_SOIL_VEG'
!Config Desc = The soil tile number for each vegetation
!Config Def = 0.1
!Config Help = Gives the number of the soil tile on which we will
!Config put each vegetation. This allows to divide the hydrological column
pref_soil_veg = (/ 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3 /)
CALL getin_p('PREF_SOIL_VEG', pref_soil_veg)
WRITE(numout, *)' PREF_SOIL_VEG, pref_soil_veg = ', pref_soil_veg
!
! Time step of STOMATE and LAI update
!
!Config Key = DT_SLOW
!Config Desc = Time step of STOMATE and other slow processes
!Config Def = 86400.
!Config Help = Time step (s) of regular update of vegetation
!Config cover, LAI etc. This is also the time step
!Config of STOMATE.
dt_slow = one_day
CALL getin_p('DT_SLOW', dt_slow)
!
!Config Key = SLOWPROC_LAI_TEMPDIAG
!Config Desc = Temperature used for the initial guess of LAI
!Config Def = 280.
!Config Help = If there is no LAI in the restart file, we may need
!Config a temperature that is used to guess the initial LAI.
!
stempdiag_bid = 280.
CALL getin_p('SLOWPROC_LAI_TEMPDIAG',stempdiag_bid)
!
!
! get restart value if none were found in the restart file
!
!Config Key = AGRICULTURE
!Config Desc = agriculture allowed?
!Config Def = y
!Config Help = With this variable, you can determine
!Config whether agriculture is allowed
!
agriculture = .TRUE.
CALL getin_p('AGRICULTURE', agriculture)
IF ( .NOT. agriculture .AND. land_use ) THEN
CALL ipslerr (2,'slowproc_init', &
& 'Problem with agriculture desactivated and Land Use activated.',&
& 'Are you sure ??', &
& '(check your parameters).')
ENDIF
!Config Key = SLOWPROC_LAI_OLD_INTERPOL
!Config Desc = Flag to use old "interpolation" of LAI
!Config If = LAI_MAP
!Config Def = FALSE
!Config Help = If you want to recover the old (ie orchidee_1_2 branch)
!Config "interpolation" of LAI map.
!
old_lai = .FALSE.
CALL getin_p('SLOWPROC_LAI_OLD_INTERPOL',old_lai)
!
!Config Key = IMPOSE_VEG
!Config Desc = Should the vegetation be prescribed
!Config Def = n
!Config Help = This flag allows the user to impose a vegetation distribution
!Config and its characterisitcs. It is espacially interesting for 0D
!Config simulations. On the globe it does not make too much sense as
!Config it imposes the same vegetation everywhere
!
impveg = .FALSE.
CALL getin_p('IMPOSE_VEG', impveg)
!
IF ( impveg ) THEN
!
! We are on a point and thus we can read the information from the run.def
!
!Config Key = SECHIBA_VEG
!Config Desc = Vegetation distribution within the mesh (0-dim mode)
!Config If = IMPOSE_VEG
!Config Def = 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0
!Config Help = The fraction of vegetation is read from the restart file. If
!Config it is not found there we will use the values provided here.
!
CALL setvar_p (veget, val_exp, 'SECHIBA_VEG', veget_ori_fixed_test_1)
!
!Config Key = SECHIBA_FRAC_NOBIO
!Config Desc = Fraction of other surface types within the mesh (0-dim mode)
!Config If = IMPOSE_VEG
!Config Def = 0.0
!Config Help = The fraction of ice, lakes, etc. is read from the restart file. If
!Config it is not found there we will use the values provided here.
!Config For the moment, there is only ice.
!
! laisser ca tant qu'il n'y a que la glace. Pb avec setvar?
frac_nobio1 = frac_nobio(1,1)
CALL setvar_p (frac_nobio1, val_exp, 'SECHIBA_FRAC_NOBIO', frac_nobio_fixed_test_1)
frac_nobio(:,:) = frac_nobio1
! CALL setvar (frac_nobio, val_exp, 'SECHIBA_FRAC_NOBIO', frac_nobio_fixed_test_1)
!
!Config Key = SECHIBA_LAI
!Config Desc = LAI for all vegetation types (0-dim mode)
!Config Def = 0., 8., 8., 4., 4.5, 4.5, 4., 4.5, 4., 2., 2., 2., 2.
!Config If = IMPOSE_VEG
!Config Help = The maximum LAI used in the 0dim mode. The values should be found
!Config in the restart file. The new values of LAI will be computed anyway
!Config at the end of the current day. The need for this variable is caused
!Config by the fact that the model may stop during a day and thus we have not
!Config yet been through the routines which compute the new surface conditions.
!
CALL setvar_p (lai, val_exp, 'SECHIBA_LAI', llaimax)
!Config Key = SOIL_FRACTIONS
!Config Desc = Fraction of the 3 soil types (0-dim mode)
!Config Def = 0.28, 0.52, 0.20
!Config If = IMPOSE_VEG
!Config Help = Determines the fraction for the 3 soil types
!Config in the mesh in the following order : sand loam and clay.
!
CALL setvar_p (soilclass, val_exp, 'SOIL_FRACTIONS', soilclass_default)
!Config Key = CLAY_FRACTION
!Config Desc = Fraction of the clay fraction (0-dim mode)
!Config Def = 0.2
!Config If = IMPOSE_VEG
!Config Help = Determines the fraction of clay in the grid box.
!
CALL setvar_p (clayfraction, val_exp, 'CLAY_FRACTION', clayfraction_default)
!
!Config Key = REINF_SLOPE
!Config Desc = Slope coef for reinfiltration
!Config Def = 0
!Config If = IMPOSE_VEG
!Config Help = Determines the reinfiltration ratio in the grid box due to flat areas
!
CALL setvar_p (reinf_slope, val_exp, 'SLOPE', slope_default)
!Config Key = SLOWPROC_HEIGHT
!Config Desc = Height for all vegetation types (m)
!Config Def = 0., 30., 30., 20., 20., 20., 15., 15., 15., .5, .6, 1.0, 1.0
!Config If = IMPOSE_VEG
!Config Help = The height used in the 0dim mode. The values should be found
!Config in the restart file. The new values of height will be computed anyway
!Config at the end of the current day. The need for this variable is caused
!Config by the fact that the model may stop during a day and thus we have not
!Config yet been through the routines which compute the new surface conditions.
!
CALL setvar_p (height, val_exp, 'SLOWPROC_HEIGHT', height_presc)
soilclass=val_exp
CALL setvar (soilclass, val_exp, 'SOIL_FRACTIONS', soilclass_default)
njsc(:) = 0
soiltile(:,:) = zero
DO ji = 1, kjpindex
njsc(ji) = MAXLOC(soilclass(ji,:),1)
soiltile(:,1) = SUM(frac_nobio(ji,:))
ENDDO
DO jv = 1, nvm
jst = pref_soil_veg(jv)
DO ji = 1, kjpindex
soiltile(ji,jst) = soiltile(ji,jst) + veget(ji,jv)
ENDDO
ENDDO
ELSE
!Config Key = SLOWPROC_VEGET_OLD_INTERPOL
!Config Desc = Flag to use old "interpolation" of vegetation map.
!Config If = NOT IMPOSE_VEG
!Config Def = FALSE
!Config Help = If you want to recover the old (ie orchidee_1_2 branch)
!Config "interpolation" of vegetation map.
!
old_veget = .FALSE.
CALL getin_p('SLOWPROC_VEGET_OLD_INTERPOL',old_veget)
!
! We are in the full 2-D case thus we need to do the interpolation if the potential vegetation
! is not available
!
IF ( ALL( veget(:,:) .EQ. val_exp ) .OR. ALL( frac_nobio(:,:) .EQ. val_exp ) ) THEN
IF ( .NOT. land_use ) THEN
! The interpolation of vegetation has changed.
IF (is_root_prc) THEN
IF ( .NOT. old_veget ) THEN
! NEW slowproc interpol :
CALL slowproc_interpol_g(nbp_glo, lalo_g, neighbours_g, resolution_g, contfrac_g, veget_g, frac_nobio_g)
ELSE
! OLD slowproc interpol :
CALL slowproc_interpol_g(nbp_glo, lalo_g, neighbours_g, resolution_g, veget_g, frac_nobio_g)
ENDIF
ENDIF
CALL scatter(veget_g,veget)
CALL scatter(frac_nobio_g, frac_nobio)
!
IF ( control%ok_dgvm ) THEN
!
! If we are dealing with dynamic vegetation then all
! natural PFTs should be set to veget = 0
! And in case no agriculture is desired, agriculture PFTS should be
! set to 0 as well
IF (agriculture) THEN
veget(:,2:nvm-2) = 0.0
DO ji = 1, kjpindex
veget(ji,1) = 1. - SUM(veget(ji,nvm-1:nvm)) &
- SUM(frac_nobio(ji,:))
ENDDO
ELSE
veget(:,:) = 0.0
DO ji = 1, kjpindex
veget(ji,1) = 1.0 - SUM(frac_nobio(ji,:))
ENDDO
ENDIF
ENDIF
ELSE
! If restart doesn't contain veget, then it is the first computation
!MM modif TAG 1.4 :
! CALL slowproc_update(kjpindex, lalo, resolution, vegetmap, frac_nobiomap)
CALL slowproc_update(kjpindex, lalo, neighbours, resolution, contfrac, &
& veget, frac_nobio, veget_year, init=.TRUE.)
!MM modif TAG 1.4 :
! veget(:,:)=vegetmap(:,:,veget_year)
! frac_nobio(:,:)=frac_nobiomap(:,:,veget_year)
ENDIF
!
ENDIF
!
IF (read_lai) THEN
!
! In case the LAI map was not found in the restart then we need to recompute it
!
IF ( ALL( laimap(:,:,:) .EQ. val_exp) ) THEN
! The interpolation of LAI has changed.
IF ( .NOT. old_lai ) THEN
! NEW slowproc interlai :
CALL slowproc_interlai (kjpindex, lalo, resolution, neighbours, contfrac, laimap)
ELSE
! OLD slowproc interlai :
CALL slowproc_interlai(kjpindex, lalo, resolution, laimap)
ENDIF
!
! Compute the current LAI just to be sure
!
in_julian = itau2date(kjit, date0, dtradia)
CALL ju2ymds(in_julian, yy, mm, dd, ss)
!
stempdiag2_bid(1:kjpindex,1:nbdl) = stempdiag_bid
CALL slowproc_lai (kjpindex, lcanop, stempdiag2_bid, &
lalo,resolution,lai,frac_bare,mm,dd,read_lai,laimap)
!
day_counter = dt_slow + 1
!
ENDIF
!
ENDIF
!
IF ( MINVAL(lai) .EQ. MAXVAL(lai) .AND. MAXVAL(lai) .EQ. val_exp) THEN
!
! Get a first guess at the LAI
!
IF ( read_lai ) THEN
IF ( ALL( laimap(:,:,:) .EQ. val_exp) ) THEN
! The interpolation of LAI has changed.
IF ( .NOT. old_lai ) THEN
! NEW slowproc interlai :
CALL slowproc_interlai (kjpindex, lalo, resolution, neighbours, contfrac, laimap)
ELSE
! OLD slowproc interlai :
CALL slowproc_interlai(kjpindex, lalo, resolution, laimap)
ENDIF
ENDIF
!
in_julian = itau2date(kjit, date0, dtradia)
CALL ju2ymds(in_julian, yy, mm, dd, ss)
ENDIF
!
stempdiag2_bid(1:kjpindex,1:nbdl) = stempdiag_bid
CALL slowproc_lai (kjpindex, lcanop, stempdiag2_bid, &
lalo,resolution,lai,frac_bare,mm,dd,read_lai,laimap)
! Make sure that we redo the computation when we will be back in slowproc_main
day_counter = dt_slow + 1
ENDIF
IF ( MINVAL(height) .EQ. MAXVAL(height) .AND. MAXVAL(height) .EQ. val_exp) THEN
! Impose height
DO jv = 1, nvm
height(:,jv) = height_presc(jv)
ENDDO
! Have a first guess at the vegetation fraction
CALL slowproc_veget (kjpindex, lai, frac_nobio, veget)
! Make sure that we redo the computation when we will be back in slowproc_main
day_counter = dt_slow + 1
ENDIF
IF ( MINVAL(soiltile) .EQ. MAXVAL(soiltile) .AND. MAXVAL(soiltile) .EQ. val_exp .OR.&
& MINVAL(njsc) .EQ. MAXVAL(njsc) .AND. MAXVAL(njsc) .EQ. undef_int .OR.&
& MINVAL(clayfraction) .EQ. MAXVAL(clayfraction) .AND. MAXVAL(clayfraction) .EQ. val_exp) THEN
CALL slowproc_soilt(kjpindex, lalo, neighbours, resolution, contfrac, soilclass, clayfraction)
! Soiltiles are only used in hydrol, but we fix them in here because some time it might depend
! on a changing vegetation (but then some adaptation should be made to hydrol) and be also used
! in the other modules to perform separated energy balances
njsc(:) = 0
soiltile(:,:) = zero
DO ji = 1, kjpindex
njsc(ji) = MAXLOC(soilclass(ji,:),1)
soiltile(:,1) = SUM(frac_nobio(ji,:))
ENDDO
DO jv = 1, nvm
jst = pref_soil_veg(jv)
DO ji = 1, kjpindex
soiltile(ji,jst) = soiltile(ji,jst) + veget(ji,jv)
ENDDO
ENDDO
! Avoid soiltile < 0.01
DO jst = 1, nstm
DO ji = 1, kjpindex
IF (soiltile(ji,jst) .LT. 0.01) THEN
soiltile(ji,MAXLOC(soiltile(ji,:),1)) = soiltile(ji,MAXLOC(soiltile(ji,:),1)) + soiltile(ji,jst)
soiltile(ji,jst) = zero
ENDIF
ENDDO
ENDDO
ENDIF
get_slope = .FALSE.
CALL getin_p('GET_SLOPE',get_slope)
IF ( MINVAL(reinf_slope) .EQ. MAXVAL(reinf_slope) .AND. MAXVAL(reinf_slope) .EQ. val_exp .OR. get_slope) THEN
CALL slowproc_slope(kjpindex, lalo, neighbours, resolution, contfrac, reinf_slope)
ENDIF
ENDIF
!
! calculate total fraction of the mesh that is covered by particular surface types: ice, lakes, ...
!
totfrac_nobio(:) = zero
DO jv = 1, nnobio
totfrac_nobio(:) = totfrac_nobio(:) + frac_nobio(:,jv)
ENDDO
l_first_slowproc = .FALSE.
DEALLOCATE(tmp_real)
END SUBROUTINE slowproc_init
!!
!! Clear Memory
!!
SUBROUTINE slowproc_clear
l_first_slowproc = .TRUE.
IF (ALLOCATED (clayfraction)) DEALLOCATE (clayfraction)
IF (ALLOCATED (veget_lastyear)) DEALLOCATE (veget_lastyear)
IF (ALLOCATED (laimap)) DEALLOCATE (laimap)
IF ( ALLOCATED (soilclass_default)) DEALLOCATE (soilclass_default)
CALL stomate_clear
!
END SUBROUTINE slowproc_clear
!!
!! Derive some variables
!!
SUBROUTINE slowproc_derivvar (kjpindex, veget, lai, &
qsintmax, deadleaf_cover, assim_param, height)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
! input fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: lai !! Surface foliere
! output scalar
! output fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: qsintmax !! Maximum water on vegetation for interception
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: deadleaf_cover!! fraction of soil covered by dead leaves
REAL(r_std), DIMENSION (kjpindex,nvm,npco2), INTENT (out) :: assim_param !! min+max+opt temps & vmax for photosynthesis
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: height !! height (m)
!
! local declaration
!
INTEGER(i_std) :: ji, jv
!
! 1 Assimilation parameters
!
DO jv = 1, nvm
assim_param(:,jv,itmin) = co2_tmin_fix(jv) + tp_00
assim_param(:,jv,itopt) = co2_topt_fix(jv) + tp_00
assim_param(:,jv,itmax) = co2_tmax_fix(jv) + tp_00
assim_param(:,jv,ivcmax) = vcmax_fix(jv)
assim_param(:,jv,ivjmax) = vjmax_fix(jv)
ENDDO
!
! 2 fraction of soil covered by dead leaves
!
deadleaf_cover(:) = zero
!
! 3 height
!
DO jv = 1, nvm
height(:,jv) = height_presc(jv)
ENDDO
!
! 4 qsintmax
!
qsintmax(:,:) = qsintcst * veget(:,:) * lai(:,:)
! Ajout Nathalie - Juillet 2006
qsintmax(:,1) = zero
END SUBROUTINE slowproc_derivvar
!!
!!
!!
SUBROUTINE slowproc_mean (npts, n_dim2, dt_tot, dt, ldmean, field_in, field_mean)
! Accumulates field_in over a period of dt_tot.
! Has to be called at every time step (dt).
! Mean value is calculated if ldmean=.TRUE.
! field_mean must be initialized outside of this routine!
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! 2nd dimension (1 or npft)
INTEGER(i_std), INTENT(in) :: n_dim2
! Time step of STOMATE (days)
REAL(r_std), INTENT(in) :: dt_tot
! Time step in days
REAL(r_std), INTENT(in) :: dt
! Calculate mean ?
LOGICAL, INTENT(in) :: ldmean
! Daily field
REAL(r_std), DIMENSION(npts,n_dim2), INTENT(in) :: field_in
! 0.2 modified field
! Annual field
REAL(r_std), DIMENSION(npts,n_dim2), INTENT(inout) :: field_mean
! =========================================================================
!
! 1 accumulation
!
field_mean(:,:) = field_mean(:,:) + field_in(:,:) * dt
!
! 2 mean fields
!
IF (ldmean) THEN
field_mean(:,:) = field_mean(:,:) / dt_tot
ENDIF
END SUBROUTINE slowproc_mean
!!
!!
!!
SUBROUTINE slowproc_long (npts, n_dim2, dt, tau, field_inst, field_long)
! Calculates a temporally smoothed field (field_long) from instantaneous
! input fields.
! Time constant tau determines the strength of the smoothing.
! For tau -> infty, field_long becomes the true mean value of field_inst (but
! the spinup becomes infinietly long, too).
! field_long must be initialized outside of this routine!
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! 2nd dimension (1 or npft)
INTEGER(i_std), INTENT(in) :: n_dim2
! Time step
REAL(r_std), INTENT(in) :: dt
! Integration time constant (has to have same unit as dt!)
REAL(r_std), INTENT(in) :: tau
! Instantaneous field
REAL(r_std), DIMENSION(npts,n_dim2), INTENT(in) :: field_inst
! 0.2 modified field
! Long-term field
REAL(r_std), DIMENSION(npts,n_dim2), INTENT(inout) :: field_long
! =========================================================================
!
! 1 test coherence
!
IF ( ( tau .LT. dt ) .OR. ( dt .LE. 0. ) .OR. ( tau .LE. 0. ) ) THEN
WRITE(numout,*) 'slowproc_long: Problem with time steps'
WRITE(numout,*) 'dt=',dt
WRITE(numout,*) 'tau=',tau
ENDIF
!
! 2 integration
!
field_long(:,:) = ( field_inst(:,:)*dt + field_long(:,:)*(tau-dt) ) / tau
END SUBROUTINE slowproc_long
!!
!!
!!
SUBROUTINE slowproc_veget (kjpindex, lai, frac_nobio, veget)
!
! 0. Declarations
!
! 0.1 Input
INTEGER(i_std), INTENT(in) :: kjpindex
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: lai
! 0.2 Modified
REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(inout) :: frac_nobio
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(inout) :: veget
! 0.4 Local
REAL(r_std), DIMENSION(kjpindex) :: fracsum
INTEGER(i_std) :: nbad
INTEGER(i_std) :: ji, jv
! Test Nathalie
REAL(r_std) :: SUMveg
!!$ REAL(r_std) :: trans_veg
!
! 1. Sum up veget and frac_nobio and test if sum is equal to 1
!
!
! 1.1 Sum up
!
fracsum(:) = 0.
DO jv = 1, nnobio
DO ji = 1, kjpindex
fracsum(ji) = fracsum(ji) + frac_nobio(ji,jv)
ENDDO
ENDDO
DO jv = 1, nvm
DO ji = 1, kjpindex
fracsum(ji) = fracsum(ji) + veget(ji,jv)
ENDDO
ENDDO
!
! 1.2 stop if there is a severe problem, that is an error above 0.01%
! The rest will be scaled
!
nbad = COUNT( ABS(fracsum(:)-un) .GT. 0.0001 )
IF ( nbad .GT. 0 ) THEN
WRITE(numout,*) 'Problem with total surface areas.'
DO ji = 1, kjpindex
IF ( ABS(fracsum(ji)-un) .GT. 0.0001 ) THEN
WRITE(numout,*) 'Point :', ji
WRITE(numout,*) ' frac_nobio :', frac_nobio(ji,:)
WRITE(numout,*) ' Veget :', veget(ji,:)
WRITE(numout,*) ' Fracsum :', fracsum(ji), EPSILON(un)
WRITE(numout,*) ' The error is :', un - ( SUM(frac_nobio(ji,:)) + SUM(veget(ji,:)) )
STOP 'slowproc_veget'
ENDIF
ENDDO
ENDIF
!
! 1.3 correction at places where the problem is surely precision-related
!
nbad = COUNT( ABS(fracsum(:)-un) .GT. EPSILON(un) )
!
IF ( nbad .GT. 0 ) THEN
!
IF ( long_print ) THEN
WRITE(numout,*) 'WARNING! scaling frac_nobio and veget at', nbad, ' points'
ENDIF
!
DO jv = 1, nnobio
DO ji = 1, kjpindex
IF ( ABS(fracsum(ji)-un) .GT. EPSILON(un) ) THEN
frac_nobio(ji,jv) = frac_nobio(ji,jv)/fracsum(ji)
ENDIF
ENDDO
ENDDO
!
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( ABS(fracsum(ji)-un) .GT. EPSILON(un) ) THEN
veget(ji,jv) = veget(ji,jv)/fracsum(ji)
ENDIF
ENDDO
ENDDO
!
ENDIF
END SUBROUTINE slowproc_veget
!!
!!
!!
SUBROUTINE slowproc_lai (kjpindex,lcanop,stempdiag,lalo,resolution,lai,frac_bare,mm,dd,read_lai,laimap)
!
! 0. Declarations
!
! 0.1 Input
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std), INTENT(in) :: lcanop !! soil level used for LAI
INTEGER(i_std), INTENT(in) :: mm, dd
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in) :: stempdiag !! Soil temperature
REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geogr. coordinates (latitude,longitude) (degrees)
REAL(r_std), DIMENSION (kjpindex,2), INTENT(in) :: resolution !! size in x an y of the grid (m)
REAL(r_std), DIMENSION(kjpindex,nvm,12), INTENT(in) :: laimap !! LAI lue
LOGICAL, INTENT(in) :: read_lai
! 0.2 Output
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out) :: lai !! LAI
REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out) :: frac_bare !! Bare fraction for each tile
! 0.3 Local
INTEGER(i_std) :: ji,jv
! Test Nathalie. On impose LAI PFT 1 a 0
! On boucle sur 2,nvm au lieu de 1,nvm
lai(: ,1) = 0.0
DO jv = 2,nvm
!!$ DO jv = 1,nvm
SELECT CASE (type_of_lai(jv))
CASE ("mean ")
!
! 1. do the interpolation between laimax and laimin
!
IF ( .NOT. read_lai ) THEN
lai(:,jv) = undemi * (llaimax(jv) + llaimin(jv))
ELSE
DO ji = 1,kjpindex
lai(ji,jv) = MAXVAL(laimap(ji,jv,:))
ENDDO
ENDIF
!
CASE ("inter")
!
! 2. do the interpolation between laimax and laimin
!
IF ( .NOT. read_lai ) THEN
DO ji = 1,kjpindex
!MG
! lai(ji,jv) = llaimin(jv) + tempfunc(stempdiag(ji,lcanop)) * (llaimax(jv) - llaimin(jv))
lai(ji,jv) = llaimin(jv) + (un - MAX(MIN((ltempmax(jv)-stempdiag(ji,lcanop))/ &
& (ltempmax(jv)-ltempmin(jv)), un), zero)**2) * (llaimax(jv) - llaimin(jv))
ENDDO
ELSE
IF (mm .EQ. 1 ) THEN
IF (dd .LE. 15) THEN
lai(:,jv) = laimap(:,jv,12)*(1-(dd+15)/30.) + laimap(:,jv,1)*((dd+15)/30.)
ELSE
lai(:,jv) = laimap(:,jv,1)*(1-(dd-15)/30.) + laimap(:,jv,2)*((dd-15)/30.)
ENDIF
ELSE IF (mm .EQ. 12) THEN
IF (dd .LE. 15) THEN
lai(:,jv) = laimap(:,jv,11)*(1-(dd+15)/30.) + laimap(:,jv,12)*((dd+15)/30.)
ELSE
lai(:,jv) = laimap(:,jv,12)*(1-(dd-15)/30.) + laimap(:,jv,1)*((dd-15)/30.)
ENDIF
ELSE
IF (dd .LE. 15) THEN
lai(:,jv) = laimap(:,jv,mm-1)*(1-(dd+15)/30.) + laimap(:,jv,mm)*((dd+15)/30.)
ELSE
lai(:,jv) = laimap(:,jv,mm)*(1-(dd-15)/30.) + laimap(:,jv,mm+1)*((dd-15)/30.)
ENDIF
ENDIF
ENDIF
!
CASE default
!
! 3. Problem
!
WRITE (numout,*) 'This kind of lai choice is not possible. '// &
' We stop with type_of_lai ',jv,' = ', type_of_lai(jv)
STOP 'slowproc_lai'
END SELECT
ENDDO
frac_bare(:,:) = zero
frac_bare(:,1) = un
IF (extcoef .LT. 100) THEN
DO jv=2,nvm
frac_bare(:,jv) = EXP(-extcoef * lai(:,jv))
ENDDO
ENDIF
END SUBROUTINE slowproc_lai
!!
!! Interpolate the LAI map to the grid of the model
!MM TAG 1.6 model !
!!
SUBROUTINE slowproc_interlai_OLD(nbpt, lalo, resolution, laimap)
!
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
!
! 0.2 OUTPUT
!
REAL(r_std), INTENT(out) :: laimap(nbpt,nvm,12) ! lai read variable and re-dimensioned
!
! 0.3 LOCAL
!
REAL(r_std), PARAMETER :: R_Earth = 6378000., min_sechiba=1.E-8
!
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, ijml, i, j, ik, lml, tml, fid, ib, jb,ip, jp, vid, ai,iki,jkj
REAL(r_std) :: lev(1), date, dt, coslat, pi
INTEGER(i_std) :: itau(1)
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: mask_lu
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_lu, lon_lu, mask
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful
REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: laimaporig
REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:) :: laimap_lu
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lon_up, lon_low, lat_up, lat_low
INTEGER, DIMENSION(nbpt) :: n_origlai
INTEGER, DIMENSION(nbpt) :: n_found
REAL(r_std), DIMENSION(nbpt,nvm) :: frac_origlai
CHARACTER(LEN=80) :: meter
REAL(r_std) :: prog, sumf
LOGICAL :: found
INTEGER :: idi,jdi, ilast, jlast, jj, ii, jv, inear, iprog
REAL(r_std) :: domaine_lon_min, domaine_lon_max, domaine_lat_min, domaine_lat_max
!
pi = 4. * ATAN(1.)
!
!Config Key = LAI_FILE
!Config Desc = Name of file from which the vegetation map is to be read
!Config If = !LAI_MAP
!Config Def = ../surfmap/lai2D.nc
!Config Help = The name of the file to be opened to read the LAI
!Config map is to be given here. Usualy SECHIBA runs with a 5kmx5km
!Config map which is derived from a Nicolas VIOVY one.
!
filename = 'lai2D.nc'
CALL getin_p('LAI_FILE',filename)
!
IF (is_root_prc) CALL flininfo(filename, iml, jml, lml, tml, fid)
CALL bcast(iml)
CALL bcast(jml)
CALL bcast(lml)
CALL bcast(tml)
!
!
ALLOCATE(lon_lu(iml))
ALLOCATE(lat_lu(jml))
ALLOCATE(laimap_lu(iml,jml,nvm,tml))
ALLOCATE(mask_lu(iml,jml))
!
WRITE(numout,*) 'slowproc_interlai : Reading the LAI file'
!
IF (is_root_prc) THEN
CALL flinget(fid, 'longitude', iml, 0, 0, 0, 1, 1, lon_lu)
CALL flinget(fid, 'latitude', jml, 0, 0, 0, 1, 1, lat_lu)
CALL flinget(fid, 'LAI', iml, jml, nvm, tml, 1, 12, laimap_lu)
CALL flinget(fid, 'mask', iml, jml, 0, 0, 0, 1, mask_lu)
!
CALL flinclo(fid)
ENDIF
CALL bcast(lon_lu)
CALL bcast(lat_lu)
CALL bcast(laimap_lu)
CALL bcast(mask_lu)
!
WRITE(numout,*) 'slowproc_interlai : ', lon_lu(1), lon_lu(iml),lat_lu(1), lat_lu(jml)
!
!
ijml=iml*jml
ALLOCATE(lon_ful(ijml))
ALLOCATE(lat_ful(ijml))
ALLOCATE(laimaporig(ijml,nvm,tml))
ALLOCATE(mask(ijml))
DO i=1,iml
DO j=1,jml
iki=(j-1)*iml+i
lon_ful(iki)=lon_lu(i)
lat_ful(iki)=lat_lu(j)
laimaporig(iki,:,:)=laimap_lu(i,j,:,:)
mask(iki)=mask_lu(i,j)
ENDDO
ENDDO
!
WHERE ( laimaporig(:,:,:) .LT. 0 )
laimaporig(:,:,:) = 0.
ENDWHERE
!
!
ALLOCATE(lon_up(nbpt))
ALLOCATE(lon_low(nbpt))
ALLOCATE(lat_up(nbpt))
ALLOCATE(lat_low(nbpt))
!
DO ib =1, nbpt
!
! We find the 4 limits of the grid-box. As we transform the resolution of the model
! into longitudes and latitudes we do not have the problem of periodicity.
! coslat is a help variable here !
!
coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
!
lon_up(ib) = lalo(ib,2) + resolution(ib,1)/(2.0*coslat)
lon_low(ib) = lalo(ib,2) - resolution(ib,1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
!
lat_up(ib) = lalo(ib,1) + resolution(ib,2)/(2.0*coslat)
lat_low(ib) = lalo(ib,1) - resolution(ib,2)/(2.0*coslat)
!
!
!
ENDDO
lon_up = NINT( lon_up * 1E6 ) * 1E-6
lon_low = NINT( lon_low * 1E6 ) * 1E-6
lat_up = NINT( lat_up * 1E6 ) * 1E-6
lat_low = NINT( lat_low * 1E6 ) * 1E-6
!
! Get the limits of the integration domaine so that we can speed up the calculations
!
domaine_lon_min = MINVAL(lon_low)
domaine_lon_max = MAXVAL(lon_up)
domaine_lat_min = MINVAL(lat_low)
domaine_lat_max = MAXVAL(lat_up)
!
!!$ WRITE(*,*) 'DOMAINE lon :', domaine_lon_min, domaine_lon_max
!!$ WRITE(*,*) 'DOMAINE lat :', domaine_lat_min, domaine_lat_max
!
! Ensure that the fine grid covers the whole domain
WHERE ( lon_ful(:) .LT. domaine_lon_min )
lon_ful(:) = lon_ful(:) + 360.
ENDWHERE
!
WHERE ( lon_ful(:) .GT. domaine_lon_max )
lon_ful(:) = lon_ful(:) - 360.
ENDWHERE
lon_ful = NINT( lon_ful * 1E6 ) * 1E-6
lat_ful = NINT( lat_ful * 1E6 ) * 1E-6
!
WRITE(numout,*) 'Interpolating the lai map :'
WRITE(numout,'(2a40)')'0%--------------------------------------', &
& '------------------------------------100%'
!
ilast = 1
n_origlai(:) = 0
laimap(:,:,:) = 0.
!
DO ip=1,ijml
!
! Give a progress meter
!
! prog = ip/float(ijml)*79.
! IF ( ABS(prog - NINT(prog)) .LT. 1/float(ijml)*79. ) THEN
! meter(NINT(prog)+1:NINT(prog)+1) = 'x'
! WRITE(numout, advance="no", FMT='(a)') ACHAR(13)
! WRITE(numout, advance="no", FMT='(a80)') meter
! ENDIF
iprog = NINT(float(ip)/float(ijml)*79.) - NINT(float(ip-1)/float(ijml)*79.)
IF ( iprog .NE. 0 ) THEN
WRITE(numout,'(a1,$)') 'y'
ENDIF
!
! Only start looking for its place in the smaler grid if we are within the domaine
! That should speed up things !
!
IF ( ( lon_ful(ip) .GE. domaine_lon_min ) .AND. &
( lon_ful(ip) .LE. domaine_lon_max ) .AND. &
( lat_ful(ip) .GE. domaine_lat_min ) .AND. &
( lat_ful(ip) .LE. domaine_lat_max ) ) THEN
!
! look for point on GCM grid which this point on fine grid belongs to.
! First look at the point on the model grid where we arrived just before. There is
! a good chace that neighbouring points on the fine grid fall into the same model
! grid box.
!
IF ( ( lon_ful(ip) .GE. lon_low(ilast) ) .AND. &
( lon_ful(ip) .LT. lon_up(ilast) ) .AND. &
( lat_ful(ip) .GE. lat_low(ilast) ) .AND. &
( lat_ful(ip) .LT. lat_up(ilast) ) ) THEN
!
! We were lucky
!
IF (mask(ip) .GT. 0) THEN
n_origlai(ilast) = n_origlai(ilast) + 1
DO i=1,nvm
DO j=1,12
laimap(ilast,i,j) = laimap(ilast,i,j) + laimaporig(ip,i,j)
ENDDO
ENDDO
ENDIF
!
ELSE
!
! Otherwise, look everywhere.
! Begin close to last grid point.
!
found = .FALSE.
idi = 1
!
DO WHILE ( (idi .LT. nbpt) .AND. ( .NOT. found ) )
!
! forward and backward
!
DO ii = 1,2
!
IF ( ii .EQ. 1 ) THEN
ib = ilast - idi
ELSE
ib = ilast + idi
ENDIF
!
IF ( ( ib .GE. 1 ) .AND. ( ib .LE. nbpt ) ) THEN
IF ( ( lon_ful(ip) .GE. lon_low(ib) ) .AND. &
( lon_ful(ip) .LT. lon_up(ib) ) .AND. &
( lat_ful(ip) .GE. lat_low(ib) ) .AND. &
( lat_ful(ip) .LT. lat_up(ib) ) ) THEN
!
IF (mask(ip) .gt. 0) THEN
DO i=1,nvm
DO j=1,12
laimap(ib,i,j) = laimap(ib,i,j) + laimaporig(ip,i,j)
ENDDO
ENDDO
n_origlai(ib) = n_origlai(ib) + 1
ENDIF
ilast = ib
found = .TRUE.
!
ENDIF
ENDIF
!
ENDDO
!
idi = idi + 1
!
ENDDO
!
ENDIF ! lucky/not lucky
!
ENDIF ! in the domain
ENDDO
! determine fraction of LAI points in each box of the coarse grid
DO ip=1,nbpt
IF ( n_origlai(ip) .GT. 0 ) THEN
DO jv =1,nvm
laimap(ip,jv,:) = laimap(ip,jv,:)/REAL(n_origlai(ip),r_std)
ENDDO
ELSE
!
! Now we need to handle some exceptions
!
IF ( lalo(ip,1) .LT. -56.0) THEN
! Antartica
DO jv =1,nvm
laimap(ip,jv,:) = 0.
ENDDO
!
ELSE IF ( lalo(ip,1) .GT. 70.0) THEN
! Artica
DO jv =1,nvm
laimap(ip,jv,:) = 0.
ENDDO
!
ELSE IF ( lalo(ip,1) .GT. 55.0 .AND. lalo(ip,2) .GT. -65.0 .AND. lalo(ip,2) .LT. -20.0) THEN
! Greenland
DO jv =1,nvm
laimap(ip,jv,:) = 0.
ENDDO
!
ELSE
!
WRITE(numout,*) 'PROBLEM, no point in the lai map found for this grid box'
WRITE(numout,*) 'Longitude range : ', lon_low(ip), lon_up(ip)
WRITE(numout,*) 'Latitude range : ', lat_low(ip), lat_up(ip)
!
WRITE(numout,*) 'Looking for nearest point on the lai map file'
CALL slowproc_nearest (ijml, lon_ful, lat_ful, &
lalo(ip,2), lalo(ip,1), inear)
WRITE(numout,*) 'Coordinates of the nearest point, ',inear,' :', &
lon_ful(inear),lat_ful(inear)
!
DO jv =1,nvm
laimap(ip,jv,:) = laimaporig(inear,jv,:)
ENDDO
ENDIF
ENDIF
ENDDO
!
WRITE(numout,*) 'slowproc_interlai : Interpolation Done'
!
!
!
DEALLOCATE(lon_up)
DEALLOCATE(lon_low)
DEALLOCATE(lat_up)
DEALLOCATE(lat_low)
DEALLOCATE(lat_ful)
DEALLOCATE(lon_ful)
DEALLOCATE(lat_lu)
DEALLOCATE(lon_lu)
DEALLOCATE(laimap_lu)
DEALLOCATE(laimaporig)
DEALLOCATE(mask_lu)
DEALLOCATE(mask)
!
RETURN
!
END SUBROUTINE slowproc_interlai_OLD
!!
!! Interpolate the LAI map to the grid of the model
!!
SUBROUTINE slowproc_interlai_NEW(nbpt, lalo, resolution, neighbours, contfrac, laimap)
!
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
!
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box.
!
! 0.2 OUTPUT
!
REAL(r_std), INTENT(out) :: laimap(nbpt,nvm,12) ! lai read variable and re-dimensioned
!
! 0.3 LOCAL
!
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, it, jj, jv
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_lu, lon_lu
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat, lon
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index
REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:) :: laimap_lu
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
!
REAL(r_std) :: totarea
INTEGER(i_std) :: idi, nbvmax
CHARACTER(LEN=30) :: callsign
!
LOGICAL :: ok_interpol = .FALSE. ! optionnal return of aggregate_2d
!
INTEGER :: ALLOC_ERR
!
!Config Key = LAI_FILE
!Config Desc = Name of file from which the vegetation map is to be read
!Config If = LAI_MAP
!Config Def = ../surfmap/lai2D.nc
!Config Help = The name of the file to be opened to read the LAI
!Config map is to be given here. Usualy SECHIBA runs with a 5kmx5km
!Config map which is derived from a Nicolas VIOVY one.
!
filename = 'lai2D.nc'
CALL getin_p('LAI_FILE',filename)
!
IF (is_root_prc) CALL flininfo(filename, iml, jml, lml, tml, fid)
CALL bcast(iml)
CALL bcast(jml)
CALL bcast(lml)
CALL bcast(tml)
!
!
ALLOC_ERR=-1
ALLOCATE(lon_lu(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lon_lu : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lat_lu(jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lat_lu : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(laimap_lu(iml,jml,nvm,tml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of laimap_lu : ",ALLOC_ERR
STOP
ENDIF
!
!
IF (is_root_prc) THEN
CALL flinget(fid, 'longitude', iml, 0, 0, 0, 1, 1, lon_lu)
CALL flinget(fid, 'latitude', jml, 0, 0, 0, 1, 1, lat_lu)
CALL flinget(fid, 'LAI', iml, jml, nvm, tml, 1, 12, laimap_lu)
!
WHERE (laimap_lu(:,:,:,:) < zero )
laimap_lu(:,:,:,:) = zero
ENDWHERE
!
CALL flinclo(fid)
ENDIF
CALL bcast(lon_lu)
CALL bcast(lat_lu)
CALL bcast(laimap_lu)
!
ALLOC_ERR=-1
ALLOCATE(lon(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lon : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lat(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lat : ",ALLOC_ERR
STOP
ENDIF
!
DO ip=1,iml
lat(ip,:) = lat_lu(:)
ENDDO
DO jp=1,jml
lon(:,jp) = lon_lu(:)
ENDDO
!
ALLOC_ERR=-1
ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of mask : ",ALLOC_ERR
STOP
ENDIF
!
! Consider all points a priori
!
!!$ mask(:,:) = 1
mask(:,:) = 0
!
DO ip=1,iml
DO jp=1,jml
!
! Exclude the points where there is never a LAI value. It is probably
! an ocean point.
!
!!$ IF (ABS(SUM(laimap_lu(ip,jp,:,:))) < EPSILON(laimap_lu) ) THEN
!!$ mask(ip,jp) = 0
!!$ ENDIF
!
IF ( ANY(laimap_lu(ip,jp,:,:) < 20.) ) THEN
mask(ip,jp) = 1
ENDIF
!
ENDDO
ENDDO
!
nbvmax = 20
!
callsign = 'LAI map'
!
DO WHILE ( .NOT. ok_interpol )
WRITE(numout,*) "Projection arrays for ",callsign," : "
WRITE(numout,*) "nbvmax = ",nbvmax
!
ALLOC_ERR=-1
ALLOCATE(sub_index(nbpt, nbvmax, 2), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
STOP
ENDIF
sub_index(:,:,:)=0
ALLOC_ERR=-1
ALLOCATE(sub_area(nbpt, nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
STOP
ENDIF
sub_area(:,:)=zero
!
CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
& iml, jml, lon, lat, mask, callsign, &
& nbvmax, sub_index, sub_area, ok_interpol)
!
IF ( .NOT. ok_interpol ) THEN
DEALLOCATE(sub_area)
DEALLOCATE(sub_index)
ENDIF
!
nbvmax = nbvmax * 2
ENDDO
!
laimap(:,:,:) = zero
!
DO ib=1,nbpt
idi = COUNT(sub_area(ib,:) > zero)
IF ( idi > 0 ) THEN
totarea = zero
DO jj=1,idi
ip = sub_index(ib,jj,1)
jp = sub_index(ib,jj,2)
DO jv=1,nvm
DO it=1,12
laimap(ib,jv,it) = laimap(ib,jv,it) + laimap_lu(ip,jp,jv,it)*sub_area(ib,jj)
ENDDO
ENDDO
totarea = totarea + sub_area(ib,jj)
ENDDO
!
! Normalize
!
laimap(ib,:,:) = laimap(ib,:,:)/totarea
!!$ IF ( ANY( laimap(ib,:,:) > 10 ) ) THEN
!!$ WRITE(numout,*) "For point ",ib
!!$ WRITE(numout,*) lalo(ib,1), lalo(ib,2)
!!$ WRITE(numout,*) "For ib=",ib," we have LAI ",laimap(ib,:,1:idi)
!!$ WRITE(numout,*) "Detail of projection :"
!!$ WRITE(numout,*) sub_area(ib,1:idi)
!!$ WRITE(numout,*) "Total for projection :" ,totarea
!!$ ENDIF
!
ELSE
WRITE(numout,*) 'On point ', ib, ' no points where found for interpolating the LAI map.'
WRITE(numout,*) 'Location : ', lalo(ib,2), lalo(ib,1)
DO jv=1,nvm
laimap(ib,jv,:) = (llaimax(jv)+llaimin(jv))/deux
ENDDO
WRITE(numout,*) 'Solved by putting the average LAI for the PFT all year long'
ENDIF
ENDDO
!
WRITE(numout,*) 'slowproc_interlai : Interpolation Done'
!
!
!
DEALLOCATE(lat_lu)
DEALLOCATE(lon_lu)
DEALLOCATE(lon)
DEALLOCATE(lat)
DEALLOCATE(laimap_lu)
DEALLOCATE(mask)
DEALLOCATE(sub_area)
DEALLOCATE(sub_index)
!
RETURN
!
END SUBROUTINE slowproc_interlai_NEW
!!
!! Interpolate a vegetation map (by pft)
!!
!MM modif TAG 1.4 :
! SUBROUTINE slowproc_update(nbpt, lalo, resolution, vegetmap, frac_nobiomap)
SUBROUTINE slowproc_update(nbpt, lalo, neighbours, resolution, contfrac, vegetmax, frac_nobio, veget_year, init)
!
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs
! to be interpolated
REAL(r_std), DIMENSION(nbpt,2), INTENT(in) :: lalo ! Vector of latitude and longitudes (beware of the order !)
!MM modif TAG 1.4 : add grid variables for aggregate
INTEGER(i_std), DIMENSION(nbpt,8), INTENT(in) :: neighbours ! Vector of neighbours for each grid point
! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
REAL(r_std), DIMENSION(nbpt,2), INTENT(in) :: resolution ! The size in km of each grid-box in X and Y
REAL(r_std), DIMENSION(nbpt), INTENT(in) :: contfrac ! Fraction of continent in the grid
!
INTEGER(i_std), INTENT(in) :: veget_year ! first year for landuse
LOGICAL, OPTIONAL, INTENT(in) :: init ! initialisation : in case of dgvm, it forces update of all PFTs
!
! 0.2 OUTPUT
!
!MM modif TAG 1.4 : suppression of all time axis reading and interpolation, replaced by each year 2D reading.
! REAL(r_std), INTENT(inout) :: vegetmap(nbpt,nvm,293) ! vegetfrac read variable and re-dimensioned
! REAL(r_std), INTENT(inout) :: frac_nobiomap(nbpt,nnobio,293) ! Fraction of the mesh which is covered by ice, lakes, ...
REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:) :: vegmap ! last coord is time with only one value = 1
REAL(r_std), INTENT(inout) :: vegetmax(nbpt,nvm) ! max vegetfrac read variable and re-dimensioned
REAL(r_std), INTENT(out) :: frac_nobio(nbpt,nnobio) ! Fraction of the mesh which is covered by ice, lakes, ...
!
! 0.3 LOCAL
!
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, inobio, jv
INTEGER(i_std) :: nb_coord,nb_var, nb_gat,nb_dim
REAL(r_std) :: date, dt
INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: itau
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_lu, lon_lu
INTEGER,DIMENSION(flio_max_var_dims) :: l_d_w, i_d_w
LOGICAL :: exv, l_ex
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_ful, lon_ful
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
!
REAL(r_std) :: sumf, err, norm
REAL(r_std) :: totarea
INTEGER(i_std) :: idi, nbvmax
CHARACTER(LEN=30) :: callsign
!
LOGICAL :: ok_interpol = .FALSE. ! optionnal return of aggregate_2d
!
! for DGVM case :
REAL(r_std) :: sum_veg ! sum of vegets
REAL(r_std) :: sum_nobio ! sum of nobios
REAL(r_std) :: sumvAnthro_old, sumvAnthro ! last an new sum of antrhopic vegets
REAL(r_std) :: rapport ! (S-B) / (S-A)
LOGICAL :: partial_update ! if TRUE, partialy update PFT (only anthropic ones)
! e.g. in case of DGVM and not init (optional parameter)
!
LOGICAL, PARAMETER :: debug = .FALSE.
!
INTEGER :: ALLOC_ERR
!
!Config Key = VEGETATION_FILE
!Config Desc = Name of file from which the vegetation map is to be read
!Config If = LAND_USE
!Config Def = pft_new.nc
!Config Help = The name of the file to be opened to read a vegetation
!Config map (in pft) is to be given here.
!
filename = 'pft_new.nc'
CALL getin_p('VEGETATION_FILE',filename)
!
IF (is_root_prc) THEN
IF (debug) THEN
WRITE(numout,*) "Entering slowproc_update. Debug mode."
WRITE (*,'(/," --> fliodmpf")')
CALL fliodmpf (TRIM(filename))
WRITE (*,'(/," --> flioopfd")')
ENDIF
CALL flioopfd (TRIM(filename),fid,nb_dim=nb_coord,nb_var=nb_var,nb_gat=nb_gat)
IF (debug) THEN
WRITE (*,'(" Number of coordinate in the file : ",I2)') nb_coord
WRITE (*,'(" Number of variables in the file : ",I2)') nb_var
WRITE (*,'(" Number of global attributes in the file : ",I2)') nb_gat
ENDIF
ENDIF
CALL bcast(nb_coord)
CALL bcast(nb_var)
CALL bcast(nb_gat)
IF (is_root_prc) &
CALL flioinqv (fid,v_n="time_counter",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w)
CALL bcast(l_d_w)
tml=l_d_w(1)
WRITE(numout,*) "tml =",tml
IF (is_root_prc) &
CALL flioinqv (fid,v_n="lon",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w)
CALL bcast(l_d_w)
iml=l_d_w(1)
WRITE(numout,*) "iml =",iml
IF (is_root_prc) &
CALL flioinqv (fid,v_n="lat",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w)
CALL bcast(l_d_w)
jml=l_d_w(1)
WRITE(numout,*) "jml =",jml
IF (is_root_prc) &
CALL flioinqv (fid,v_n="veget",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w)
CALL bcast(l_d_w)
lml=l_d_w(1)
IF (lml /= nvm) &
CALL ipslerr (3,'slowproc_update', &
& 'Problem with vegetation file for Land Use','lml /= nvm', &
& '(number of pft must be equal)')
!
ALLOC_ERR=-1
ALLOCATE(lat_lu(jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lat_lu : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lon_lu(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lon_lu : ",ALLOC_ERR
STOP
ENDIF
IF (tml > 0) THEN
ALLOC_ERR=-1
ALLOCATE(itau(tml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of itau : ",ALLOC_ERR
STOP
ENDIF
ENDIF
!
IF (is_root_prc) THEN
IF (tml > 0) THEN
CALL fliogstc (fid, t_axis=itau,x_axis=lon_lu,y_axis=lat_lu)
ELSE
CALL fliogstc (fid, x_axis=lon_lu,y_axis=lat_lu)
ENDIF
ENDIF
IF (tml > 0) THEN
CALL bcast(itau)
ENDIF
CALL bcast(lon_lu)
CALL bcast(lat_lu)
!
ALLOC_ERR=-1
ALLOCATE(lat_ful(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lat_ful : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lon_ful(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lon_ful : ",ALLOC_ERR
STOP
ENDIF
!
DO ip=1,iml
lon_ful(ip,:)=lon_lu(ip)
ENDDO
DO jp=1,jml
lat_ful(:,jp)=lat_lu(jp)
ENDDO
!
!
WRITE(numout,*) 'Reading the LAND USE vegetation file'
!
ALLOC_ERR=-1
ALLOCATE(vegmap(iml,jml,nvm,1), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of vegmap : ",ALLOC_ERR
STOP
ENDIF
!
!!$ CALL flinopen &
!!$ & (filename, .FALSE., iml, jml, lml, lon_ful, lat_ful, &
!!$ & lev_ful, tml, itau, date, dt, fid)
!=> FATAL ERROR FROM ROUTINE flinopen
! --> No time axis found
!MM modif TAG 1.4 :
! CALL flinget(fid, 'lon', iml, 0, 0, 0, 1, 1, lon_lu)
! CALL flinget(fid, 'lat', jml, 0, 0, 0, 1, 1, lat_lu)
! CALL flinget(fid, 'maxvegetfrac', iml, jml, nvm, tml, 1, 293, vegmap_lu)
!FATAL ERROR FROM ROUTINE flinopen
! --> No variable lon
! We get only the right year
!!$ CALL flinget(fid, 'maxvegetfrac', iml, jml, nvm, tml, veget_year, veget_year, vegmap)
!!$ !
!!$ CALL flinclo(fid)
IF (is_root_prc) &
CALL flioinqv (fid,"maxvegetfrac",exv,nb_dims=nb_dim,len_dims=l_d_w,id_dims=i_d_w)
CALL bcast(exv)
CALL bcast(nb_dim)
CALL bcast(l_d_w)
CALL bcast(i_d_w)
IF (exv) THEN
IF (debug) THEN
WRITE (*,'(" Number of dimensions : ",I2)') nb_dim
WRITE (*,'(" Dimensions :",/,5(1X,I7,:))') l_d_w(1:nb_dim)
WRITE (*,'(" Identifiers :",/,5(1X,I7,:))') i_d_w(1:nb_dim)
ENDIF
!
IF (is_root_prc) THEN
CALL fliogetv (fid,"maxvegetfrac", vegmap, start=(/ 1, 1, 1, veget_year /), count=(/ iml, jml, nvm, 1 /))
CALL flioclo (fid)
ENDIF
CALL bcast(vegmap)
ELSE
CALL ipslerr (3,'slowproc_update', &
& 'Problem with vegetation file for Land Use.', &
& "Variable maxvegetfrac doesn't exist.", &
& '(verify your land use file.)')
ENDIF
!
! Mask of permitted variables.
!
ALLOC_ERR=-1
ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of mask : ",ALLOC_ERR
STOP
ENDIF
!
mask(:,:) = 0
DO ip=1,iml
DO jp=1,jml
sum_veg=SUM(vegmap(ip,jp,:,1))
IF ( sum_veg .GE. min_sechiba .AND. sum_veg .LE. 1.-1.e-7) THEN
mask(ip,jp) = 1
IF (debug) THEN
WRITE(numout,*) "update : SUM(vegmap(",ip,jp,")) = ",sum_veg
ENDIF
ELSEIF ( sum_veg .GT. 1.-1.e-7 .AND. sum_veg .LE. 2.) THEN
! normalization
vegmap(ip,jp,:,1) = vegmap(ip,jp,:,1) / sum_veg
mask(ip,jp) = 1
IF (debug) THEN
WRITE(numout,*) "update : SUM(vegmap(",ip,jp,"))_c = ",SUM(vegmap(ip,jp,:,1))
ENDIF
ENDIF
ENDDO
ENDDO
!
!
! The number of maximum vegetation map points in the GCM grid should
! also be computed and not imposed here.
!
nbvmax = 200
!
callsign="Land Use Vegetation map"
!
DO WHILE ( .NOT. ok_interpol )
WRITE(numout,*) "Projection arrays for ",callsign," : "
WRITE(numout,*) "nbvmax = ",nbvmax
!
ALLOC_ERR=-1
ALLOCATE(sub_index(nbpt, nbvmax,2), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
STOP
ENDIF
sub_index(:,:,:)=0
ALLOC_ERR=-1
ALLOCATE(sub_area(nbpt, nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
STOP
ENDIF
sub_area(:,:)=zero
!
CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
& iml, jml, lon_ful, lat_ful, mask, callsign, &
& nbvmax, sub_index, sub_area, ok_interpol)
!
IF ( .NOT. ok_interpol ) THEN
DEALLOCATE(sub_area)
DEALLOCATE(sub_index)
ENDIF
!
nbvmax = nbvmax * 2
ENDDO
!
! Compute the logical for partial (only anthropic) PTFs update
IF (PRESENT(init)) THEN
partial_update = control%ok_dgvm .AND. .NOT. init
ELSE
partial_update = control%ok_dgvm
ENDIF
!
IF ( .NOT. partial_update ) THEN
!
vegetmax(:,:)=zero
!
DO ib = 1, nbpt
idi=1
sumf=0.
DO WHILE ( sub_area(ib,idi) > zero )
ip = sub_index(ib,idi,1)
jp = sub_index(ib,idi,2)
vegetmax(ib,:) = vegetmax(ib,:) + vegmap(ip,jp,:,1)*sub_area(ib,idi)
sumf=sumf + sub_area(ib,idi)
idi = idi +1
ENDDO
!!$ !
!!$ ! Limit the smalest vegetation fraction to 0.5%
!!$ !
!!$ DO jv = 1, nvm
!!$ IF ( vegetmax(ib,jv) .LT. min_vegfrac ) THEN
!!$ vegetmax(ib,jv) = zero
!!$ ENDIF
!!$ ENDDO
!
! Normalize
!
IF (sumf > min_sechiba) THEN
vegetmax(ib,:) = vegetmax(ib,:) / sumf
ELSE
WRITE(numout,*) "No land point in the map for point ",ib,",(",lalo(ib,1),",",lalo(ib,2),")"
CALL ipslerr (2,'slowproc_update', &
& 'Problem with vegetation file for Land Use.', &
& "No land point in the map for point", &
& 'Keep old values. (verify your land use file.)')
!!$ CALL slowproc_nearest (iml, lon_ful, lat_ful, &
!!$ lalo(ib,2), lalo(ib,1), inear)
vegetmax(ib,:) = veget_lastyear(ib,:)
ENDIF
ENDDO
ELSE
DO ib = 1, nbpt
! last veget for this point
sum_veg=SUM(veget_lastyear(ib,:))
!
!MM A CHANGER avec le MERGE !! jv=2,nvm => notation STOMATE=1:nvm-1
DO jv = 2, nvm
! If the DGVM is activated, only anthropiques PFT are utpdated
!MM A CHANGER avec le MERGE !! natural(jv-1)=1,nvm-1 => notation STOMATE=1:nvm-1
IF ( .NOT. natural(jv-1) ) THEN
vegetmax(ib,jv) = zero
ENDIF
ENDDO
!
idi=1
sumf=0.
DO WHILE ( sub_area(ib,idi) > zero )
ip = sub_index(ib,idi,1)
jp = sub_index(ib,idi,2)
! If the DGVM is activated, only anthropic PFTs are utpdated
!MM A CHANGER avec le MERGE !! jv=2,nvm
DO jv = 2, nvm
IF ( .NOT. natural(jv-1) ) THEN
vegetmax(ib,jv) = vegetmax(ib,jv) + vegmap(ip,jp,jv,1)*sub_area(ib,idi)
ENDIF
ENDDO
sumf=sumf + sub_area(ib,idi)
idi = idi +1
ENDDO
!!$ !
!!$ ! Limit the smalest vegetation fraction to 0.5%
!!$ !
!!$!MM A CHANGER avec le MERGE !! jv=2,nvm
!!$ DO jv = 2, nvm
!!$ ! On anthropic and natural PFTs ?
!!$ IF ( vegetmax(ib,jv) .LT. min_vegfrac ) THEN
!!$ vegetmax(ib,jv) = zero
!!$ ENDIF
!!$ ENDDO
!
! Normalize
!
! Proposition de Pierre :
! apres modification de la surface des PFTs anthropiques,
! on doit conserver la proportion des PFTs naturels.
! ie la somme des végets est conservée
! et PFT naturel / (somme des végets - somme des végets anthropiques)
! est conservée.
! Sum vegetmax = old (sum vegetmax Naturel) + (sum vegetmax Anthropic)
! = new (sum vegetmax Naturel) + (sum vegetmax Anthropic)
! a / (S-A) = e / (S-B) ; b/(S-A) = f/(S-B)
IF (sumf > min_sechiba) THEN
sumvAnthro_old = zero
sumvAnthro = zero
DO jv = 2, nvm
!MM A CHANGER avec le MERGE !! natural(jv-1)=1,nvm-1 => notation STOMATE=1:nvm-1
IF ( .NOT. natural(jv-1) ) THEN
vegetmax(ib,jv) = vegetmax(ib,jv) / sumf
sumvAnthro = sumvAnthro + veget_lastyear(ib,jv)
sumvAnthro_old = sumvAnthro_old + veget_lastyear(ib,jv)
ENDIF
ENDDO
! conservation :
rapport = ( sum_veg - sumvAnthro ) / ( sum_veg - sumvAnthro_old )
vegetmax(ib,1) = veget_lastyear(ib,1) * rapport
DO jv = 2, nvm
!MM A CHANGER avec le MERGE !! natural(jv-1)=1,nvm-1 => notation STOMATE=1:nvm-1
IF ( .NOT. natural(jv-1) ) THEN
vegetmax(ib,jv) = veget_lastyear(ib,jv) * rapport
ENDIF
ENDDO
! test
IF ( ABS( SUM(vegetmax(ib,:)) - sum_veg ) > EPSILON(un) ) THEN
WRITE(numout,*) "No conservation of sum of veget for point ",ib,",(",lalo(ib,1),",",lalo(ib,2),")"
WRITE(numout,*) "last sum of veget ",sum_veg," new sum of veget ",SUM(vegetmax(ib,:))," error : ",&
& SUM(vegetmax(ib,:)) - sum_veg
WRITE(numout,*) "Anthropic modificaztions : last ",sumvAnthro_old," new ",sumvAnthro
CALL ipslerr (3,'slowproc_update', &
& 'No conservation of sum of vegetmax', &
& "The sum of vegetmax is different after reading Land Use map.", &
& '(verify the dgvm case model.)')
ENDIF
ELSE
WRITE(numout,*) "No land point in the map for point ",ib,",(",lalo(ib,1),",",lalo(ib,2),")"
! CALL ipslerr (3,'slowproc_update', &
CALL ipslerr (2,'slowproc_update', &
& 'Problem with vegetation file for Land Use.', &
& "No land point in the map for point", &
& '(verify your land use file.)')
vegetmax(ib,:) = veget_lastyear(ib,:)
ENDIF
ENDDO
ENDIF
!
frac_nobio(:,:) = un
!
!MM
! Work only for one nnobio !! (ie ice)
DO inobio=1,nnobio
DO jv=1,nvm
!
DO ib = 1, nbpt
frac_nobio(ib,inobio) = frac_nobio(ib,inobio) - vegetmax(ib,jv)
ENDDO
ENDDO
!
ENDDO
!
DO ib = 1, nbpt
!MM
! We really need that ??
sum_veg = SUM(vegetmax(ib,:))
sum_nobio = SUM(frac_nobio(ib,:))
IF (sum_nobio < 0.) THEN
frac_nobio(ib,:) = zero
vegetmax(ib,1) = vegetmax(ib,1) - sum_nobio
ENDIF
sumf = sum_veg + sum_nobio
IF (sumf > min_sechiba) THEN
vegetmax(ib,:) = vegetmax(ib,:) / sumf
frac_nobio(ib,:) = frac_nobio(ib,:) / sumf
norm=SUM(vegetmax(ib,:))+SUM(frac_nobio(ib,:))
err=norm-un
IF (debug) &
WRITE(numout,*) "ib ",ib," SUM(vegetmax(ib,:)+frac_nobio(ib,:))-1., sumf",err,sumf
IF (abs(err) > 0) THEN
IF ( SUM(frac_nobio(ib,:)) > min_sechiba ) THEN
frac_nobio(ib,1) = frac_nobio(ib,1) - err
ELSE
vegetmax(ib,1) = vegetmax(ib,1) - err
ENDIF
norm=SUM(vegetmax(ib,:))+SUM(frac_nobio(ib,:))
err=norm-un
IF (debug) &
WRITE(numout,*) "ib ",ib," SUM(vegetmax(ib,:)+frac_nobio(ib,:))-1.",err
ENDIF
ELSE
WRITE(numout,*) "No vegetation nor frac_nobio for point ",ib,",(",lalo(ib,1),",",lalo(ib,2),")"
WRITE(numout,*)"Replaced by bare_soil !! "
vegetmax(ib,1) = un
vegetmax(ib,2:nvm) = zero
frac_nobio(ib,:) = zero
!!$ CALL ipslerr (3,'slowproc_update', &
!!$ & 'Problem with vegetation file for Land Use.', &
!!$ & "No vegetation nor frac_nobio for point ", &
!!$ & '(verify your land use file.)')
ENDIF
ENDDO
!
WRITE(numout,*) 'slowproc_update : Interpolation Done'
!
DEALLOCATE(vegmap)
DEALLOCATE(lat_lu,lon_lu)
DEALLOCATE(lat_ful,lon_ful)
DEALLOCATE(mask)
DEALLOCATE(sub_index,sub_area)
!
RETURN
!
END SUBROUTINE slowproc_update
!!
!! Interpolate the IGBP vegetation map to the grid of the model
!MM TAG 1.6 model !
!!
SUBROUTINE slowproc_interpol_OLD(nbpt, lalo, neighbours, resolution, veget, frac_nobio )
!
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point
! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
!
! 0.2 OUTPUT
!
REAL(r_std), INTENT(out) :: veget(nbpt,nvm) ! Vegetation fractions
REAL(r_std), INTENT(out) :: frac_nobio(nbpt,nnobio) ! Fraction of the mesh which is covered by ice, lakes, ...
!
! 0.3 LOCAL
!
REAL(r_std), PARAMETER :: R_Earth = 6378000., min_sechiba=1.E-8
INTEGER(i_std), PARAMETER :: nolson = 94 ! Number of Olson classes
!
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, vid
REAL(r_std) :: lev(1), date, dt, coslat, pi
INTEGER(i_std) :: itau(1)
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful, vegmap
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lon_up, lon_low, lat_up, lat_low
INTEGER, DIMENSION(nbpt,nolson) :: n_origveg
INTEGER, DIMENSION(nbpt) :: n_found
REAL(r_std), DIMENSION(nbpt,nolson) :: frac_origveg
REAL(r_std) :: vegcorr(nolson,nvm)
REAL(r_std) :: nobiocorr(nolson,nnobio)
CHARACTER(LEN=80) :: meter
REAL(r_std) :: prog, sumf
LOGICAL :: found
INTEGER :: idi, ilast, ii, jv, inear, iprog
REAL(r_std) :: domaine_lon_min, domaine_lon_max, domaine_lat_min, domaine_lat_max
!
pi = 4. * ATAN(1.)
!
CALL get_vegcorr (nolson,vegcorr,nobiocorr)
!
!Config Key = VEGETATION_FILE
!Config Desc = Name of file from which the vegetation map is to be read
!Config If = !IMPOSE_VEG
!Config Def = ../surfmap/carteveg5km.nc
!Config Help = The name of the file to be opened to read the vegetation
!Config map is to be given here. Usualy SECHIBA runs with a 5kmx5km
!Config map which is derived from the IGBP one. We assume that we have
!Config a classification in 87 types. This is Olson modified by Viovy.
!
filename = '../surfmap/carteveg5km.nc'
CALL getin_p('VEGETATION_FILE',filename)
!
if (is_root_prc) CALL flininfo(filename, iml, jml, lml, tml, fid)
CALL bcast(iml)
CALL bcast(jml)
CALL bcast(lml)
CALL bcast(tml)
!
!
ALLOCATE(lat_ful(iml))
ALLOCATE(lon_ful(iml))
ALLOCATE(vegmap(iml))
!
WRITE(numout,*) 'Reading the vegetation file'
!
IF (is_root_prc) THEN
CALL flinget(fid, 'longitude', iml, jml, lml, tml, 1, 1, lon_ful)
CALL flinget(fid, 'latitude', iml, jml, lml, tml, 1, 1, lat_ful)
CALL flinget(fid, 'vegetation_map', iml, jml, lml, tml, 1, 1, vegmap)
!
CALL flinclo(fid)
ENDIF
CALL bcast(lon_ful)
CALL bcast(lat_ful)
CALL bcast(vegmap)
!
IF (MAXVAL(vegmap) .LT. nolson) THEN
WRITE(*,*) 'WARNING -- WARNING'
WRITE(*,*) 'The vegetation map has to few vegetation types.'
WRITE(*,*) 'If you are lucky it will work but please check'
ELSE IF ( MAXVAL(vegmap) .GT. nolson) THEN
WRITE(*,*) 'More vegetation types in file than the code can'
WRITE(*,*) 'deal with.: ', MAXVAL(vegmap), nolson
STOP 'slowproc_interpol'
ENDIF
!
ALLOCATE(lon_up(nbpt))
ALLOCATE(lon_low(nbpt))
ALLOCATE(lat_up(nbpt))
ALLOCATE(lat_low(nbpt))
!
DO ib =1, nbpt
!
! We find the 4 limits of the grid-box. As we transform the resolution of the model
! into longitudes and latitudes we do not have the problem of periodicity.
! coslat is a help variable here !
!
coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
!
lon_up(ib) = lalo(ib,2) + resolution(ib,1)/(2.0*coslat)
lon_low(ib) = lalo(ib,2) - resolution(ib,1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
!
lat_up(ib) = lalo(ib,1) + resolution(ib,2)/(2.0*coslat)
lat_low(ib) = lalo(ib,1) - resolution(ib,2)/(2.0*coslat)
!
!
veget(ib,:) = 0.0
frac_nobio (ib,:) = 0.0
!
ENDDO
!
! Get the limits of the integration domaine so that we can speed up the calculations
!
domaine_lon_min = MINVAL(lon_low)
domaine_lon_max = MAXVAL(lon_up)
domaine_lat_min = MINVAL(lat_low)
domaine_lat_max = MAXVAL(lat_up)
!
!!$ WRITE(*,*) 'DOMAINE lon :', domaine_lon_min, domaine_lon_max
!!$ WRITE(*,*) 'DOMAINE lat :', domaine_lat_min, domaine_lat_max
!
! Ensure that the fine grid covers the whole domain
WHERE ( lon_ful(:) .LT. domaine_lon_min )
lon_ful(:) = lon_ful(:) + 360.
ENDWHERE
!
WHERE ( lon_ful(:) .GT. domaine_lon_max )
lon_ful(:) = lon_ful(:) - 360.
ENDWHERE
!
WRITE(numout,*) 'Interpolating the vegetation map :'
WRITE(numout,'(2a40)')'0%--------------------------------------', &
& '------------------------------------100%'
!
ilast = 1
n_origveg(:,:) = 0
!
DO ip=1,iml
!
! Give a progress meter
!
! prog = ip/float(iml)*79.
! IF ( ABS(prog - NINT(prog)) .LT. 1/float(iml)*79. ) THEN
! meter(NINT(prog)+1:NINT(prog)+1) = 'x'
! WRITE(numout, advance="no", FMT='(a)') ACHAR(13)
! WRITE(numout, advance="no", FMT='(a80)') meter
! ENDIF
iprog = NINT(float(ip)/float(iml)*79.) - NINT(float(ip-1)/float(iml)*79.)
IF ( iprog .NE. 0 ) THEN
WRITE(numout,'(a1,$)') 'x'
ENDIF
!
! Only start looking for its place in the smaler grid if we are within the domaine
! That should speed up things !
!
IF ( ( lon_ful(ip) .GE. domaine_lon_min ) .AND. &
( lon_ful(ip) .LE. domaine_lon_max ) .AND. &
( lat_ful(ip) .GE. domaine_lat_min ) .AND. &
( lat_ful(ip) .LE. domaine_lat_max ) ) THEN
!
! look for point on GCM grid which this point on fine grid belongs to.
! First look at the point on the model grid where we arrived just before. There is
! a good chace that neighbouring points on the fine grid fall into the same model
! grid box.
!
!
! THERE IS A BUG HERE !!! IF THE GCM GRID SITS ON THE DATE LINE WE WILL HAVE FOR INSTANCE
! LON_LOW = -182 AND LON_UP = -178. THUS WE WILL ONLY PICK UP HALF THE POINTS NEEDED.
!
IF ( ( lon_ful(ip) .GT. lon_low(ilast) ) .AND. &
( lon_ful(ip) .LT. lon_up(ilast) ) .AND. &
( lat_ful(ip) .GT. lat_low(ilast) ) .AND. &
( lat_ful(ip) .LT. lat_up(ilast) ) ) THEN
!
! We were lucky
!
n_origveg(ilast,NINT(vegmap(ip))) = n_origveg(ilast,NINT(vegmap(ip))) + 1
!
ELSE
!
! Otherwise, look everywhere.
! Begin close to last grid point.
!
found = .FALSE.
idi = 1
!
DO WHILE ( (idi .LT. nbpt) .AND. ( .NOT. found ) )
!
! forward and backward
!
DO ii = 1,2
!
IF ( ii .EQ. 1 ) THEN
ib = ilast - idi
ELSE
ib = ilast + idi
ENDIF
!
IF ( ( ib .GE. 1 ) .AND. ( ib .LE. nbpt ) ) THEN
IF ( ( lon_ful(ip) .GT. lon_low(ib) ) .AND. &
( lon_ful(ip) .LT. lon_up(ib) ) .AND. &
( lat_ful(ip) .GT. lat_low(ib) ) .AND. &
( lat_ful(ip) .LT. lat_up(ib) ) ) THEN
!
n_origveg(ib,NINT(vegmap(ip))) = n_origveg(ib,NINT(vegmap(ip))) + 1
ilast = ib
found = .TRUE.
!
ENDIF
ENDIF
!
ENDDO
!
idi = idi + 1
!
ENDDO
!
ENDIF ! lucky/not lucky
!
ENDIF ! in the domain
ENDDO
!
! Now we know how many points of which Olson type from the fine grid fall
! into each box of the (coarse) model grid: n_origveg(nbpt,nolson)
!
!
! determine number of points of the fine grid which fall into each box of the
! coarse grid
!
DO ib = 1, nbpt
n_found(ib) = SUM( n_origveg(ib,:) )
ENDDO
!
! determine fraction of Olson vegetation type in each box of the coarse grid
!
DO vid = 1, nolson
WHERE ( n_found(:) .GT. 0 )
frac_origveg(:,vid) = REAL(n_origveg(:,vid),r_std) / REAL(n_found(:),r_std)
ELSEWHERE
frac_origveg(:,vid) = 0.
ENDWHERE
ENDDO
!
! now finally calculate coarse vegetation map
! Find which model vegetation corresponds to each Olson type
!
DO vid = 1, nolson
!
DO jv = 1, nvm
veget(:,jv) = veget(:,jv) + frac_origveg(:,vid) * vegcorr(vid,jv)
ENDDO
!
DO jv = 1, nnobio
frac_nobio(:,jv) = frac_nobio(:,jv) + frac_origveg(:,vid) * nobiocorr(vid,jv)
ENDDO
!
ENDDO
!
!
WRITE(numout,*)
WRITE(numout,*) 'Interpolation Done'
!
! Clean up the point of the map
!
DO ib = 1, nbpt
!
! Let us see if all points found something in the 5km map !
!
IF ( n_found(ib) .EQ. 0 ) THEN
!
! Now we need to handle some exceptions
!
IF ( lalo(ib,1) .LT. -56.0) THEN
! Antartica
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE IF ( lalo(ib,1) .GT. 70.0) THEN
! Artica
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN
! Greenland
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE
!
WRITE(numout,*) 'PROBLEM, no point in the 5km map found for this grid box'
WRITE(numout,*) 'Longitude range : ', lon_low(ib), lon_up(ib)
WRITE(numout,*) 'Latitude range : ', lat_low(ib), lat_up(ib)
!
WRITE(numout,*) 'Looking for nearest point on the 5 km map'
CALL slowproc_nearest (iml, lon_ful, lat_ful, &
lalo(ib,2), lalo(ib,1), inear)
WRITE(numout,*) 'Coordinates of the nearest point:', &
lon_ful(inear),lat_ful(inear)
!
DO jv = 1, nvm
veget(ib,jv) = vegcorr(NINT(vegmap(inear)),jv)
ENDDO
!
DO jv = 1, nnobio
frac_nobio(ib,jv) = nobiocorr(NINT(vegmap(inear)),jv)
ENDDO
!
ENDIF
!
ENDIF
!
!
! Limit the smalest vegetation fraction to 0.5%
!
DO vid = 1, nvm
IF ( veget(ib,vid) .LT. min_vegfrac ) THEN
veget(ib,vid) = 0.0
ENDIF
ENDDO
!
sumf = SUM(frac_nobio(ib,:))+SUM(veget(ib,:))
frac_nobio(ib,:) = frac_nobio(ib,:)/sumf
veget(ib,:) = veget(ib,:)/sumf
!
!
ENDDO
!
DEALLOCATE(lon_up)
DEALLOCATE(lon_low)
DEALLOCATE(lat_up)
DEALLOCATE(lat_low)
DEALLOCATE(lat_ful)
DEALLOCATE(lon_ful)
DEALLOCATE(vegmap)
!
RETURN
!
END SUBROUTINE slowproc_interpol_OLD
!!
!! Interpolate the IGBP vegetation map to the grid of the model
!!
SUBROUTINE slowproc_interpol_NEW(nbpt, lalo, neighbours, resolution, contfrac, veget, frac_nobio )
!
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point
! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std),DIMENSION (nbpt), INTENT (in) :: contfrac !! Fraction of continent in the grid
!
! 0.2 OUTPUT
!
REAL(r_std), INTENT(out) :: veget(nbpt,nvm) ! Vegetation fractions
REAL(r_std), INTENT(out) :: frac_nobio(nbpt,nnobio) ! Fraction of the mesh which is covered by ice, lakes, ...
!
LOGICAL :: ok_interpol = .FALSE. ! optionnal return of aggregate_vec
!
! 0.3 LOCAL
!
INTEGER(i_std), PARAMETER :: nolson = 94 ! Number of Olson classes
!
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, vid
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful, vegmap
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
INTEGER(i_std),ALLOCATABLE, DIMENSION(:,:) :: sub_index
REAL(r_std), DIMENSION(nbpt,nolson) :: n_origveg
REAL(r_std), DIMENSION(nbpt) :: n_found
REAL(r_std), DIMENSION(nbpt,nolson) :: frac_origveg
REAL(r_std) :: vegcorr(nolson,nvm)
REAL(r_std) :: nobiocorr(nolson,nnobio)
CHARACTER(LEN=40) :: callsign
REAL(r_std) :: sumf, resol_lon, resol_lat
INTEGER(i_std) :: idi, jv, inear, nbvmax
!
INTEGER :: ALLOC_ERR
!
n_origveg(:,:) = zero
n_found(:) = zero
!
CALL get_vegcorr (nolson,vegcorr,nobiocorr)
!
!Config Key = VEGETATION_FILE
!Config Desc = Name of file from which the vegetation map is to be read
!Config If = !IMPOSE_VEG
!Config If = !LAND_USE
!Config Def = ../surfmap/carteveg5km.nc
!Config Help = The name of the file to be opened to read the vegetation
!Config map is to be given here. Usualy SECHIBA runs with a 5kmx5km
!Config map which is derived from the IGBP one. We assume that we have
!Config a classification in 87 types. This is Olson modified by Viovy.
!
filename = '../surfmap/carteveg5km.nc'
CALL getin_p('VEGETATION_FILE',filename)
!
if (is_root_prc) CALL flininfo(filename, iml, jml, lml, tml, fid)
CALL bcast(iml)
CALL bcast(jml)
CALL bcast(lml)
CALL bcast(tml)
!
!
ALLOC_ERR=-1
ALLOCATE(lat_ful(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lat_ful : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lon_ful(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lon_ful : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(vegmap(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of vegmap : ",ALLOC_ERR
STOP
ENDIF
!
WRITE(numout,*) 'Reading the OLSON type vegetation file'
!
IF (is_root_prc) THEN
CALL flinget(fid, 'longitude', iml, jml, lml, tml, 1, 1, lon_ful)
CALL flinget(fid, 'latitude', iml, jml, lml, tml, 1, 1, lat_ful)
CALL flinget(fid, 'vegetation_map', iml, jml, lml, tml, 1, 1, vegmap)
!
CALL flinclo(fid)
ENDIF
CALL bcast(lon_ful)
CALL bcast(lat_ful)
CALL bcast(vegmap)
!
IF (MAXVAL(vegmap) .LT. nolson) THEN
WRITE(numout,*) 'WARNING -- WARNING'
WRITE(numout,*) 'The vegetation map has to few vegetation types.'
WRITE(numout,*) 'If you are lucky it will work but please check'
ELSE IF ( MAXVAL(vegmap) .GT. nolson) THEN
WRITE(numout,*) 'More vegetation types in file than the code can'
WRITE(numout,*) 'deal with.: ', MAXVAL(vegmap), nolson
STOP 'slowproc_interpol'
ENDIF
!
! Some assumptions on the vegetation file. This information should be
! be computed or read from the file.
! It is the reolution in meters of the grid of the vegetation file.
!
resol_lon = 5000.
resol_lat = 5000.
!
! The number of maximum vegetation map points in the GCM grid should
! also be computed and not imposed here.
nbvmax = iml/nbpt
!
callsign="Vegetation map"
!
DO WHILE ( .NOT. ok_interpol )
WRITE(numout,*) "Projection arrays for ",callsign," : "
WRITE(numout,*) "nbvmax = ",nbvmax
!
ALLOC_ERR=-1
ALLOCATE(sub_index(nbpt, nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
STOP
ENDIF
sub_index(:,:)=0
ALLOC_ERR=-1
ALLOCATE(sub_area(nbpt, nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
STOP
ENDIF
sub_area(:,:)=zero
!
CALL aggregate_p (nbpt, lalo, neighbours, resolution, contfrac, &
& iml, lon_ful, lat_ful, resol_lon, resol_lat, callsign, &
& nbvmax, sub_index, sub_area, ok_interpol)
!
IF ( .NOT. ok_interpol ) THEN
DEALLOCATE(sub_area)
DEALLOCATE(sub_index)
!
nbvmax = nbvmax * 2
ELSE
!
DO ib = 1, nbpt
idi=1
DO WHILE ( sub_area(ib,idi) > zero )
ip = sub_index(ib,idi)
n_origveg(ib,NINT(vegmap(ip))) = n_origveg(ib,NINT(vegmap(ip))) + sub_area(ib,idi)
n_found(ib) = n_found(ib) + sub_area(ib,idi)
idi = idi +1
ENDDO
ENDDO
!
ENDIF
ENDDO
!
! Now we know how many points of which Olson type from the fine grid fall
! into each box of the (coarse) model grid: n_origveg(nbpt,nolson)
!
!
! determine fraction of Olson vegetation type in each box of the coarse grid
!
DO vid = 1, nolson
WHERE ( n_found(:) .GT. 0 )
frac_origveg(:,vid) = n_origveg(:,vid) / n_found(:)
ELSEWHERE
frac_origveg(:,vid) = 0.
ENDWHERE
ENDDO
!
! now finally calculate coarse vegetation map
! Find which model vegetation corresponds to each Olson type
!
veget(:,:) = zero
frac_nobio(:,:) = zero
!
DO vid = 1, nolson
!
DO jv = 1, nvm
veget(:,jv) = veget(:,jv) + frac_origveg(:,vid) * vegcorr(vid,jv)
ENDDO
!
DO jv = 1, nnobio
frac_nobio(:,jv) = frac_nobio(:,jv) + frac_origveg(:,vid) * nobiocorr(vid,jv)
ENDDO
!
ENDDO
!
WRITE(numout,*) 'slowproc_interpol : Interpolation Done'
!
! Clean up the point of the map
!
DO ib = 1, nbpt
!
! Let us see if all points found something in the 5km map !
!
IF ( n_found(ib) .EQ. 0 ) THEN
!
! Now we need to handle some exceptions
!
IF ( lalo(ib,1) .LT. -56.0) THEN
! Antartica
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE IF ( lalo(ib,1) .GT. 70.0) THEN
! Artica
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN
! Greenland
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE
!
WRITE(numout,*) 'PROBLEM, no point in the 5km map found for this grid box',ib
WRITE(numout,*) 'Longitude range : ', lalo(ib,2)
WRITE(numout,*) 'Latitude range : ', lalo(ib,1)
!
WRITE(numout,*) 'Looking for nearest point on the 5 km map'
CALL slowproc_nearest (iml, lon_ful, lat_ful, &
lalo(ib,2), lalo(ib,1), inear)
WRITE(numout,*) 'Coordinates of the nearest point:', &
lon_ful(inear),lat_ful(inear)
!
DO jv = 1, nvm
veget(ib,jv) = vegcorr(NINT(vegmap(inear)),jv)
ENDDO
!
DO jv = 1, nnobio
frac_nobio(ib,jv) = nobiocorr(NINT(vegmap(inear)),jv)
ENDDO
!
ENDIF
!
ENDIF
!
!
! Limit the smalest vegetation fraction to 0.5%
!
DO vid = 1, nvm
IF ( veget(ib,vid) .LT. min_vegfrac ) THEN
veget(ib,vid) = 0.0
ENDIF
ENDDO
!
sumf = SUM(frac_nobio(ib,:))+SUM(veget(ib,:))
frac_nobio(ib,:) = frac_nobio(ib,:)/sumf
veget(ib,:) = veget(ib,:)/sumf
!
!
ENDDO
!
DEALLOCATE(vegmap)
DEALLOCATE(lat_ful, lon_ful)
DEALLOCATE(sub_index)
DEALLOCATE(sub_area)
!
RETURN
!
END SUBROUTINE slowproc_interpol_NEW
!!
!! Interpolate the IGBP vegetation map to the grid of the model
!MM TAG 1.6 model !
!!
SUBROUTINE slowproc_interpol_OLD_g(nbpt, lalo, neighbours, resolution, veget, frac_nobio )
!
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point
! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
!
! 0.2 OUTPUT
!
REAL(r_std), INTENT(out) :: veget(nbpt,nvm) ! Vegetation fractions
REAL(r_std), INTENT(out) :: frac_nobio(nbpt,nnobio) ! Fraction of the mesh which is covered by ice, lakes, ...
!
! 0.3 LOCAL
!
REAL(r_std), PARAMETER :: R_Earth = 6378000., min_sechiba=1.E-8
INTEGER(i_std), PARAMETER :: nolson = 94 ! Number of Olson classes
!
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, vid
REAL(r_std) :: lev(1), date, dt, coslat, pi
INTEGER(i_std) :: itau(1)
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful, vegmap
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lon_up, lon_low, lat_up, lat_low
INTEGER, DIMENSION(nbpt,nolson) :: n_origveg
INTEGER, DIMENSION(nbpt) :: n_found
REAL(r_std), DIMENSION(nbpt,nolson) :: frac_origveg
REAL(r_std) :: vegcorr(nolson,nvm)
REAL(r_std) :: nobiocorr(nolson,nnobio)
CHARACTER(LEN=80) :: meter
REAL(r_std) :: prog, sumf
LOGICAL :: found
INTEGER :: idi, ilast, ii, jv, inear, iprog
REAL(r_std) :: domaine_lon_min, domaine_lon_max, domaine_lat_min, domaine_lat_max
!
pi = 4. * ATAN(1.)
!
CALL get_vegcorr (nolson,vegcorr,nobiocorr)
!
!Config Key = VEGETATION_FILE
!Config Desc = Name of file from which the vegetation map is to be read
!Config If = !IMPOSE_VEG
!Config Def = ../surfmap/carteveg5km.nc
!Config Help = The name of the file to be opened to read the vegetation
!Config map is to be given here. Usualy SECHIBA runs with a 5kmx5km
!Config map which is derived from the IGBP one. We assume that we have
!Config a classification in 87 types. This is Olson modified by Viovy.
!
filename = '../surfmap/carteveg5km.nc'
CALL getin('VEGETATION_FILE',filename)
!
CALL flininfo(filename, iml, jml, lml, tml, fid)
!
!
ALLOCATE(lat_ful(iml))
ALLOCATE(lon_ful(iml))
ALLOCATE(vegmap(iml))
!
WRITE(numout,*) 'Reading the vegetation file'
!
CALL flinget(fid, 'longitude', iml, jml, lml, tml, 1, 1, lon_ful)
CALL flinget(fid, 'latitude', iml, jml, lml, tml, 1, 1, lat_ful)
CALL flinget(fid, 'vegetation_map', iml, jml, lml, tml, 1, 1, vegmap)
!
CALL flinclo(fid)
!
IF (MAXVAL(vegmap) .LT. nolson) THEN
WRITE(*,*) 'WARNING -- WARNING'
WRITE(*,*) 'The vegetation map has to few vegetation types.'
WRITE(*,*) 'If you are lucky it will work but please check'
ELSE IF ( MAXVAL(vegmap) .GT. nolson) THEN
WRITE(*,*) 'More vegetation types in file than the code can'
WRITE(*,*) 'deal with.: ', MAXVAL(vegmap), nolson
STOP 'slowproc_interpol'
ENDIF
!
ALLOCATE(lon_up(nbpt))
ALLOCATE(lon_low(nbpt))
ALLOCATE(lat_up(nbpt))
ALLOCATE(lat_low(nbpt))
!
DO ib =1, nbpt
!
! We find the 4 limits of the grid-box. As we transform the resolution of the model
! into longitudes and latitudes we do not have the problem of periodicity.
! coslat is a help variable here !
!
coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
!
lon_up(ib) = lalo(ib,2) + resolution(ib,1)/(2.0*coslat)
lon_low(ib) = lalo(ib,2) - resolution(ib,1)/(2.0*coslat)
!
coslat = pi/180. * R_Earth
!
lat_up(ib) = lalo(ib,1) + resolution(ib,2)/(2.0*coslat)
lat_low(ib) = lalo(ib,1) - resolution(ib,2)/(2.0*coslat)
!
!
veget(ib,:) = 0.0
frac_nobio (ib,:) = 0.0
!
ENDDO
!
! Get the limits of the integration domaine so that we can speed up the calculations
!
domaine_lon_min = MINVAL(lon_low)
domaine_lon_max = MAXVAL(lon_up)
domaine_lat_min = MINVAL(lat_low)
domaine_lat_max = MAXVAL(lat_up)
!
!!$ WRITE(*,*) 'DOMAINE lon :', domaine_lon_min, domaine_lon_max
!!$ WRITE(*,*) 'DOMAINE lat :', domaine_lat_min, domaine_lat_max
!
! Ensure that the fine grid covers the whole domain
WHERE ( lon_ful(:) .LT. domaine_lon_min )
lon_ful(:) = lon_ful(:) + 360.
ENDWHERE
!
WHERE ( lon_ful(:) .GT. domaine_lon_max )
lon_ful(:) = lon_ful(:) - 360.
ENDWHERE
!
WRITE(numout,*) 'Interpolating the vegetation map :'
WRITE(numout,'(2a40)')'0%--------------------------------------', &
& '------------------------------------100%'
!
ilast = 1
n_origveg(:,:) = 0
!
DO ip=1,iml
!
! Give a progress meter
!
! prog = ip/float(iml)*79.
! IF ( ABS(prog - NINT(prog)) .LT. 1/float(iml)*79. ) THEN
! meter(NINT(prog)+1:NINT(prog)+1) = 'x'
! WRITE(numout, advance="no", FMT='(a)') ACHAR(13)
! WRITE(numout, advance="no", FMT='(a80)') meter
! ENDIF
iprog = NINT(float(ip)/float(iml)*79.) - NINT(float(ip-1)/float(iml)*79.)
IF ( iprog .NE. 0 ) THEN
WRITE(numout,'(a1,$)') 'x'
ENDIF
!
! Only start looking for its place in the smaler grid if we are within the domaine
! That should speed up things !
!
IF ( ( lon_ful(ip) .GE. domaine_lon_min ) .AND. &
( lon_ful(ip) .LE. domaine_lon_max ) .AND. &
( lat_ful(ip) .GE. domaine_lat_min ) .AND. &
( lat_ful(ip) .LE. domaine_lat_max ) ) THEN
!
! look for point on GCM grid which this point on fine grid belongs to.
! First look at the point on the model grid where we arrived just before. There is
! a good chace that neighbouring points on the fine grid fall into the same model
! grid box.
!
!
! THERE IS A BUG HERE !!! IF THE GCM GRID SITS ON THE DATE LINE WE WILL HAVE FOR INSTANCE
! LON_LOW = -182 AND LON_UP = -178. THUS WE WILL ONLY PICK UP HALF THE POINTS NEEDED.
!
IF ( ( lon_ful(ip) .GT. lon_low(ilast) ) .AND. &
( lon_ful(ip) .LT. lon_up(ilast) ) .AND. &
( lat_ful(ip) .GT. lat_low(ilast) ) .AND. &
( lat_ful(ip) .LT. lat_up(ilast) ) ) THEN
!
! We were lucky
!
n_origveg(ilast,NINT(vegmap(ip))) = n_origveg(ilast,NINT(vegmap(ip))) + 1
!
ELSE
!
! Otherwise, look everywhere.
! Begin close to last grid point.
!
found = .FALSE.
idi = 1
!
DO WHILE ( (idi .LT. nbpt) .AND. ( .NOT. found ) )
!
! forward and backward
!
DO ii = 1,2
!
IF ( ii .EQ. 1 ) THEN
ib = ilast - idi
ELSE
ib = ilast + idi
ENDIF
!
IF ( ( ib .GE. 1 ) .AND. ( ib .LE. nbpt ) ) THEN
IF ( ( lon_ful(ip) .GT. lon_low(ib) ) .AND. &
( lon_ful(ip) .LT. lon_up(ib) ) .AND. &
( lat_ful(ip) .GT. lat_low(ib) ) .AND. &
( lat_ful(ip) .LT. lat_up(ib) ) ) THEN
!
n_origveg(ib,NINT(vegmap(ip))) = n_origveg(ib,NINT(vegmap(ip))) + 1
ilast = ib
found = .TRUE.
!
ENDIF
ENDIF
!
ENDDO
!
idi = idi + 1
!
ENDDO
!
ENDIF ! lucky/not lucky
!
ENDIF ! in the domain
ENDDO
!
! Now we know how many points of which Olson type from the fine grid fall
! into each box of the (coarse) model grid: n_origveg(nbpt,nolson)
!
!
! determine number of points of the fine grid which fall into each box of the
! coarse grid
!
DO ib = 1, nbpt
n_found(ib) = SUM( n_origveg(ib,:) )
ENDDO
!
! determine fraction of Olson vegetation type in each box of the coarse grid
!
DO vid = 1, nolson
WHERE ( n_found(:) .GT. 0 )
frac_origveg(:,vid) = REAL(n_origveg(:,vid),r_std) / REAL(n_found(:),r_std)
ELSEWHERE
frac_origveg(:,vid) = 0.
ENDWHERE
ENDDO
!
! now finally calculate coarse vegetation map
! Find which model vegetation corresponds to each Olson type
!
DO vid = 1, nolson
!
DO jv = 1, nvm
veget(:,jv) = veget(:,jv) + frac_origveg(:,vid) * vegcorr(vid,jv)
ENDDO
!
DO jv = 1, nnobio
frac_nobio(:,jv) = frac_nobio(:,jv) + frac_origveg(:,vid) * nobiocorr(vid,jv)
ENDDO
!
ENDDO
!
!
WRITE(numout,*)
WRITE(numout,*) 'Interpolation Done'
!
! Clean up the point of the map
!
DO ib = 1, nbpt
!
! Let us see if all points found something in the 5km map !
!
IF ( n_found(ib) .EQ. 0 ) THEN
!
! Now we need to handle some exceptions
!
IF ( lalo(ib,1) .LT. -56.0) THEN
! Antartica
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE IF ( lalo(ib,1) .GT. 70.0) THEN
! Artica
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN
! Greenland
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE
!
WRITE(numout,*) 'PROBLEM, no point in the 5km map found for this grid box'
WRITE(numout,*) 'Longitude range : ', lon_low(ib), lon_up(ib)
WRITE(numout,*) 'Latitude range : ', lat_low(ib), lat_up(ib)
!
WRITE(numout,*) 'Looking for nearest point on the 5 km map'
CALL slowproc_nearest (iml, lon_ful, lat_ful, &
lalo(ib,2), lalo(ib,1), inear)
WRITE(numout,*) 'Coordinates of the nearest point:', &
lon_ful(inear),lat_ful(inear)
!
DO jv = 1, nvm
veget(ib,jv) = vegcorr(NINT(vegmap(inear)),jv)
ENDDO
!
DO jv = 1, nnobio
frac_nobio(ib,jv) = nobiocorr(NINT(vegmap(inear)),jv)
ENDDO
!
ENDIF
!
ENDIF
!
!
! Limit the smalest vegetation fraction to 0.5%
!
DO vid = 1, nvm
IF ( veget(ib,vid) .LT. min_vegfrac ) THEN
veget(ib,vid) = 0.0
ENDIF
ENDDO
!
sumf = SUM(frac_nobio(ib,:))+SUM(veget(ib,:))
frac_nobio(ib,:) = frac_nobio(ib,:)/sumf
veget(ib,:) = veget(ib,:)/sumf
!
!
ENDDO
!
DEALLOCATE(lon_up)
DEALLOCATE(lon_low)
DEALLOCATE(lat_up)
DEALLOCATE(lat_low)
DEALLOCATE(lat_ful)
DEALLOCATE(lon_ful)
DEALLOCATE(vegmap)
!
RETURN
!
END SUBROUTINE slowproc_interpol_OLD_g
!!
!! Interpolate the IGBP vegetation map to the grid of the model
!!
SUBROUTINE slowproc_interpol_NEW_g(nbpt, lalo, neighbours, resolution, contfrac, veget, frac_nobio )
!
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point
! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std),DIMENSION (nbpt), INTENT (in) :: contfrac !! Fraction of continent in the grid
!
! 0.2 OUTPUT
!
REAL(r_std), INTENT(out) :: veget(nbpt,nvm) ! Vegetation fractions
REAL(r_std), INTENT(out) :: frac_nobio(nbpt,nnobio) ! Fraction of the mesh which is covered by ice, lakes, ...
!
LOGICAL :: ok_interpol = .FALSE. ! optionnal return of aggregate_vec
!
! 0.3 LOCAL
!
INTEGER(i_std), PARAMETER :: nolson = 94 ! Number of Olson classes
!
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, vid
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful, vegmap
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
INTEGER(i_std),ALLOCATABLE, DIMENSION(:,:) :: sub_index
REAL(r_std), DIMENSION(nbpt,nolson) :: n_origveg
REAL(r_std), DIMENSION(nbpt) :: n_found
REAL(r_std), DIMENSION(nbpt,nolson) :: frac_origveg
REAL(r_std) :: vegcorr(nolson,nvm)
REAL(r_std) :: nobiocorr(nolson,nnobio)
CHARACTER(LEN=40) :: callsign
REAL(r_std) :: sumf, resol_lon, resol_lat
INTEGER(i_std) :: idi, jv, inear, nbvmax
!
INTEGER :: ALLOC_ERR
!
n_origveg(:,:) = zero
n_found(:) = zero
!
CALL get_vegcorr (nolson,vegcorr,nobiocorr)
!
!Config Key = VEGETATION_FILE
!Config Desc = Name of file from which the vegetation map is to be read
!Config If = !IMPOSE_VEG
!Config If = !LAND_USE
!Config Def = ../surfmap/carteveg5km.nc
!Config Help = The name of the file to be opened to read the vegetation
!Config map is to be given here. Usualy SECHIBA runs with a 5kmx5km
!Config map which is derived from the IGBP one. We assume that we have
!Config a classification in 87 types. This is Olson modified by Viovy.
!
filename = '../surfmap/carteveg5km.nc'
CALL getin('VEGETATION_FILE',filename)
!
CALL flininfo(filename, iml, jml, lml, tml, fid)
!
!
ALLOC_ERR=-1
ALLOCATE(lat_ful(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lat_ful : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lon_ful(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lon_ful : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(vegmap(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of vegmap : ",ALLOC_ERR
STOP
ENDIF
!
WRITE(numout,*) 'Reading the OLSON type vegetation file'
!
CALL flinget(fid, 'longitude', iml, jml, lml, tml, 1, 1, lon_ful)
CALL flinget(fid, 'latitude', iml, jml, lml, tml, 1, 1, lat_ful)
CALL flinget(fid, 'vegetation_map', iml, jml, lml, tml, 1, 1, vegmap)
!
CALL flinclo(fid)
!
IF (MAXVAL(vegmap) .LT. nolson) THEN
WRITE(numout,*) 'WARNING -- WARNING'
WRITE(numout,*) 'The vegetation map has to few vegetation types.'
WRITE(numout,*) 'If you are lucky it will work but please check'
ELSE IF ( MAXVAL(vegmap) .GT. nolson) THEN
WRITE(numout,*) 'More vegetation types in file than the code can'
WRITE(numout,*) 'deal with.: ', MAXVAL(vegmap), nolson
STOP 'slowproc_interpol'
ENDIF
!
! Some assumptions on the vegetation file. This information should be
! be computed or read from the file.
! It is the reolution in meters of the grid of the vegetation file.
!
resol_lon = 5000.
resol_lat = 5000.
!
! The number of maximum vegetation map points in the GCM grid should
! also be computed and not imposed here.
nbvmax = iml/nbpt
!
callsign="Vegetation map"
!
DO WHILE ( .NOT. ok_interpol )
WRITE(numout,*) "Projection arrays for ",callsign," : "
WRITE(numout,*) "nbvmax = ",nbvmax
!
ALLOC_ERR=-1
ALLOCATE(sub_index(nbpt, nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
STOP
ENDIF
sub_index(:,:)=0
ALLOC_ERR=-1
ALLOCATE(sub_area(nbpt, nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
STOP
ENDIF
sub_area(:,:)=zero
!
CALL aggregate (nbpt, lalo, neighbours, resolution, contfrac, &
& iml, lon_ful, lat_ful, resol_lon, resol_lat, callsign, &
& nbvmax, sub_index, sub_area, ok_interpol)
!
IF ( .NOT. ok_interpol ) THEN
DEALLOCATE(sub_area)
DEALLOCATE(sub_index)
!
nbvmax = nbvmax * 2
ELSE
!
DO ib = 1, nbpt
idi=1
DO WHILE ( sub_area(ib,idi) > zero )
ip = sub_index(ib,idi)
n_origveg(ib,NINT(vegmap(ip))) = n_origveg(ib,NINT(vegmap(ip))) + sub_area(ib,idi)
n_found(ib) = n_found(ib) + sub_area(ib,idi)
idi = idi +1
ENDDO
ENDDO
!
ENDIF
ENDDO
!
! Now we know how many points of which Olson type from the fine grid fall
! into each box of the (coarse) model grid: n_origveg(nbpt,nolson)
!
!
! determine fraction of Olson vegetation type in each box of the coarse grid
!
DO vid = 1, nolson
WHERE ( n_found(:) .GT. 0 )
frac_origveg(:,vid) = n_origveg(:,vid) / n_found(:)
ELSEWHERE
frac_origveg(:,vid) = 0.
ENDWHERE
ENDDO
!
! now finally calculate coarse vegetation map
! Find which model vegetation corresponds to each Olson type
!
veget(:,:) = zero
frac_nobio(:,:) = zero
!
DO vid = 1, nolson
!
DO jv = 1, nvm
veget(:,jv) = veget(:,jv) + frac_origveg(:,vid) * vegcorr(vid,jv)
ENDDO
!
DO jv = 1, nnobio
frac_nobio(:,jv) = frac_nobio(:,jv) + frac_origveg(:,vid) * nobiocorr(vid,jv)
ENDDO
!
ENDDO
!
WRITE(numout,*) 'slowproc_interpol : Interpolation Done'
!
! Clean up the point of the map
!
DO ib = 1, nbpt
!
! Let us see if all points found something in the 5km map !
!
IF ( n_found(ib) .EQ. 0 ) THEN
!
! Now we need to handle some exceptions
!
IF ( lalo(ib,1) .LT. -56.0) THEN
! Antartica
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE IF ( lalo(ib,1) .GT. 70.0) THEN
! Artica
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN
! Greenland
frac_nobio(ib,:) = 0.0
frac_nobio(ib,iice) = 1.0
veget(ib,:) = 0.0
!
ELSE
!
WRITE(numout,*) 'PROBLEM, no point in the 5km map found for this grid box',ib
WRITE(numout,*) 'Longitude range : ', lalo(ib,2)
WRITE(numout,*) 'Latitude range : ', lalo(ib,1)
!
WRITE(numout,*) 'Looking for nearest point on the 5 km map'
CALL slowproc_nearest (iml, lon_ful, lat_ful, &
lalo(ib,2), lalo(ib,1), inear)
WRITE(numout,*) 'Coordinates of the nearest point:', &
lon_ful(inear),lat_ful(inear)
!
DO jv = 1, nvm
veget(ib,jv) = vegcorr(NINT(vegmap(inear)),jv)
ENDDO
!
DO jv = 1, nnobio
frac_nobio(ib,jv) = nobiocorr(NINT(vegmap(inear)),jv)
ENDDO
!
ENDIF
!
ENDIF
!
!
! Limit the smalest vegetation fraction to 0.5%
!
DO vid = 1, nvm
IF ( veget(ib,vid) .LT. min_vegfrac ) THEN
veget(ib,vid) = 0.0
ENDIF
ENDDO
!
sumf = SUM(frac_nobio(ib,:))+SUM(veget(ib,:))
frac_nobio(ib,:) = frac_nobio(ib,:)/sumf
veget(ib,:) = veget(ib,:)/sumf
!
!
ENDDO
!
DEALLOCATE(vegmap)
DEALLOCATE(lat_ful, lon_ful)
DEALLOCATE(sub_index)
DEALLOCATE(sub_area)
!
RETURN
!
END SUBROUTINE slowproc_interpol_NEW_g
!!
!! looks for nearest grid point on the fine map
!!
SUBROUTINE slowproc_nearest(iml, lon5, lat5, lonmod, latmod, inear)
INTEGER(i_std), INTENT(in) :: iml
REAL(r_std), DIMENSION(iml), INTENT(in) :: lon5, lat5
REAL(r_std), INTENT(in) :: lonmod, latmod
INTEGER(i_std), INTENT(out) :: inear
REAL(r_std) :: pi
REAL(r_std) :: pa, p
REAL(r_std) :: coscolat, sincolat
REAL(r_std) :: cospa, sinpa
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: cosang
INTEGER(i_std) :: i
INTEGER(i_std), DIMENSION(1) :: ineartab
INTEGER :: ALLOC_ERR
ALLOC_ERR=-1
ALLOCATE(cosang(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of cosang : ",ALLOC_ERR
STOP
ENDIF
pi = 4.0 * ATAN(1.0)
pa = pi/2.0 - latmod*pi/180.0 ! dist. entre pole n et point a
cospa = COS(pa)
sinpa = SIN(pa)
DO i = 1, iml
sincolat = SIN( pi/2.0 - lat5(i)*pi/180.0 )
coscolat = COS( pi/2.0 - lat5(i)*pi/180.0 )
p = (lonmod-lon5(i))*pi/180.0 ! angle entre a et b (leurs meridiens)
! dist(i) = ACOS( cospa*coscolat + sinpa*sincolat*COS(p))
cosang(i) = cospa*coscolat + sinpa*sincolat*COS(p)
ENDDO
ineartab = MAXLOC( cosang(:) )
inear = ineartab(1)
DEALLOCATE(cosang)
END SUBROUTINE slowproc_nearest
!!
!! Interpolate the soil type map
!!
SUBROUTINE slowproc_soilt(nbpt, lalo, neighbours, resolution, contfrac, soilclass, clayfraction)
!
!
! This subroutine should read the Zobler map and interpolate to the model grid. The method
! is to get fraction of the three main soiltypes for each grid box.
! The soil fraction are going to be put into the array soilclass in the following order :
! coarse, medium and fine.
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point
! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std), INTENT(in) :: contfrac(nbpt) ! Fraction of land in each grid box.
!
! 0.2 OUTPUT
!
REAL(r_std), INTENT(out) :: soilclass(nbpt, nstm) ! Soil type map to be created from the Zobler map
REAL(r_std), INTENT(out) :: clayfraction(nbpt) ! The fraction of clay as used by STOMATE
!
!
! 0.3 LOCAL
!
INTEGER(i_std) :: nbvmax
!
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt, ilf, nbexp
REAL(r_std) :: lev(1), date, dt
INTEGER(i_std) :: itau(1)
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel, lon_rel, soiltext, soiltext2
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: sub_index
INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: solt, solt2
REAL(r_std) :: sgn
CHARACTER(LEN=30) :: callsign
CHARACTER(LEN=30) :: classif
!
LOGICAL :: ok_interpol = .FALSE. ! optionnal return of aggregate_2d
!
! Number of texture classes in Zobler
!
INTEGER(i_std), PARAMETER :: nzobler = 7
REAL(r_std),ALLOCATABLE :: textfrac_table(:,:)
!
INTEGER :: ALLOC_ERR
!
!
!
! Needs to be a configurable variable
!
!
!Config Key = SOILCLASS_FILE
!Config Desc = Name of file from which soil types are read
!Config Def = ../surfmap/soils_param.nc
!Config If = !IMPOSE_VEG
!Config Help = The name of the file to be opened to read the soil types.
!Config The data from this file is then interpolated to the grid of
!Config of the model. The aim is to get fractions for sand loam and
!Config clay in each grid box. This information is used for soil hydrology
!Config and respiration.
!
filename = '../surfmap/soils_param.nc'
CALL getin_p('SOILCLASS_FILE',filename)
!
!Config Key = SOIL_CLASSIF
!Config Desc = Type of classification used for the map of soil types
!Config Def = zobler
!Config If = !IMPOSE_VEG
!Config Help = The classification used in the file that we use here
!Config = There are three classification supported:
!Config = FAO (3 soil types), Zobler (7) and USDA (12)
!
classif = 'zobler'
CALL getin('SOIL_CLASSIF',classif)
!
IF (is_root_prc) THEN
CALL flininfo(filename,iml, jml, lml, tml, fid)
CALL flinclo(fid)
ENDIF
CALL bcast(iml)
CALL bcast(jml)
CALL bcast(lml)
CALL bcast(tml)
!
! soils_param.nc file is 1° soit texture file.
!
ALLOC_ERR=-1
ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lat_rel : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lon_rel : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of mask : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(soiltext(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of soiltext : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(soiltext2(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of soiltext : ",ALLOC_ERR
STOP
ENDIF
!
IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
CALL bcast(lon_rel)
CALL bcast(lat_rel)
CALL bcast(itau)
CALL bcast(date)
CALL bcast(dt)
!
IF (is_root_prc) CALL flinget(fid, 'soiltext', iml, jml, lml, tml, 1, 1, soiltext)
CALL bcast(soiltext)
!
IF (classif .EQ. "fao2") THEN
IF (is_root_prc) CALL flinget(fid, 'soiltext2', iml, jml, lml, tml, 1, 1, soiltext2)
CALL bcast(soiltext2)
ENDIF
!
IF (is_root_prc) CALL flinclo(fid)
!
nbexp = 0
!
!
! Mask of permitted variables.
!
mask(:,:) = zero
DO ip=1,iml
DO jp=1,jml
IF (soiltext(ip,jp) .GT. min_sechiba) THEN
mask(ip,jp) = un
ENDIF
ENDDO
ENDDO
!
nbvmax = 220
!
callsign = "Soil types"
!
DO WHILE ( .NOT. ok_interpol )
WRITE(numout,*) "Projection arrays for ",callsign," : "
WRITE(numout,*) "nbvmax = ",nbvmax
!
ALLOC_ERR=-1
ALLOCATE(solt(nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of solt : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(solt2(nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of solt : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
STOP
ENDIF
sub_index(:,:,:)=0
ALLOC_ERR=-1
ALLOCATE(sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
STOP
ENDIF
sub_area(:,:)=zero
!
CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
& iml, jml, lon_rel, lat_rel, mask, callsign, &
& nbvmax, sub_index, sub_area, ok_interpol)
!
IF ( .NOT. ok_interpol ) THEN
DEALLOCATE(sub_area)
DEALLOCATE(sub_index)
DEALLOCATE(solt)
DEALLOCATE(solt2)
!
nbvmax = nbvmax * 2
ENDIF
ENDDO
!
! Depending on the selected classification, the interpolation will be different
!
SELECTCASE(classif)
CASE('none')
ALLOCATE(textfrac_table(nscm,ntext))
DO ib=1, nbpt
soilclass(ib,:) = soilclass_default_fao
clayfraction(ib) = clayfraction_default
ENDDO
CASE('zobler')
!
soilclass_default=soilclass_default_fao
!
PRINT *, "Using a soilclass map with Zobler classification"
!
ALLOCATE(textfrac_table(nzobler,ntext))
!
CALL get_soilcorr (nzobler, textfrac_table)
!
!
DO ib =1, nbpt
!
! GO through the point we have found
!
!
fopt = COUNT(sub_area(ib,:) > zero)
!
! Check that we found some points
!
soilclass(ib,:) = 0.0
clayfraction(ib) = 0.0
!
IF ( fopt .EQ. 0) THEN
nbexp = nbexp + 1
soilclass(ib,:) = soilclass_default(:)
clayfraction(ib) = clayfraction_default
ELSE
!
DO ilf = 1,fopt
solt(ilf) = soiltext(sub_index(ib,ilf,1),sub_index(ib,ilf,2))
ENDDO
!
sgn = zero
!
! Compute the average bare soil albedo parameters
!
DO ilf = 1,fopt
!
! We have to take care of two exceptions here : type 6 = glacier and type 0 = ocean
!
IF ( (solt(ilf) .LE. nzobler) .AND. (solt(ilf) .GT. 0) .AND.&
& (solt(ilf) .NE. 6)) THEN
SELECTCASE(solt(ilf))
CASE(1)
soilclass(ib,1) = soilclass(ib,1) + sub_area(ib,ilf)
CASE(2)
soilclass(ib,2) = soilclass(ib,2) + sub_area(ib,ilf)
CASE(3)
soilclass(ib,2) = soilclass(ib,2) + sub_area(ib,ilf)
CASE(4)
soilclass(ib,2) = soilclass(ib,2) + sub_area(ib,ilf)
CASE(5)
soilclass(ib,3) = soilclass(ib,3) + sub_area(ib,ilf)
CASE(7)
soilclass(ib,2) = soilclass(ib,2) + sub_area(ib,ilf)
CASE DEFAULT
WRITE(numout,*) 'We should not be here, an impossible case appeared'
STOP 'slowproc_soilt'
END SELECT
clayfraction(ib) = clayfraction(ib) + &
& textfrac_table(solt(ilf),3) * sub_area(ib,ilf)
sgn = sgn + sub_area(ib,ilf)
ELSE
IF (solt(ilf) .GT. nzobler) THEN
WRITE(numout,*) 'The file contains a soil color class which is incompatible with this program'
STOP 'slowproc_soilt'
ENDIF
ENDIF
!
ENDDO
!
! Normalize the surface
!
IF ( sgn .LT. min_sechiba) THEN
nbexp = nbexp + 1
soilclass(ib,:) = soilclass_default(:)
clayfraction(ib) = clayfraction_default
ELSE
soilclass(ib,:) = soilclass(ib,:)/sgn
clayfraction(ib) = clayfraction(ib)/sgn
ENDIF
!
ENDIF
!
ENDDO
!
CASE("fao")
!
soilclass_default=soilclass_default_fao
!
PRINT *, "Using a soilclass map with fao classification"
!
ALLOCATE(textfrac_table(nscm,ntext))
!
CALL get_soilcorr (nscm, textfrac_table)
!
DO ib =1, nbpt
!
! GO through the point we have found
!
!
fopt = COUNT(sub_area(ib,:) > zero)
!
! Check that we found some points
!
soilclass(ib,:) = 0.0
clayfraction(ib) = 0.0
!
IF ( fopt .EQ. 0) THEN
nbexp = nbexp + 1
soilclass(ib,:) = soilclass_default(:)
clayfraction(ib) = clayfraction_default
ELSE
!
DO ilf = 1,fopt
solt(ilf) = soiltext(sub_index(ib,ilf,1),sub_index(ib,ilf,2))
ENDDO
!
!
! Compute the average bare soil albedo parameters
!
sgn = zero
!
DO ilf = 1,fopt
!
!
!
IF ( (solt(ilf) .LE. nscm) .AND. (solt(ilf) .GT. 0) ) THEN
soilclass(ib,solt(ilf)) = soilclass(ib,solt(ilf)) + sub_area(ib,ilf)
clayfraction(ib) = clayfraction(ib) + textfrac_table(solt(ilf),3) * sub_area(ib,ilf)
sgn = sgn + sub_area(ib,ilf)
ELSE
IF (solt(ilf) .GT. nscm) THEN
WRITE(*,*) 'The file contains a soil color class which is incompatible with this program'
STOP 'slowproc_soilt'
ENDIF
ENDIF
!
ENDDO
!
! Normalize the surface
!
IF ( sgn .LT. min_sechiba) THEN
nbexp = nbexp + 1
soilclass(ib,:) = soilclass_default(:)
clayfraction(ib) = clayfraction_default
ELSE
soilclass(ib,:) = soilclass(ib,:)/sgn
clayfraction(ib) = clayfraction(ib)/sgn
ENDIF
!
ENDIF
!
ENDDO
!
!
CASE("fao2")
!
soilclass_default=soilclass_default_fao2
!
PRINT *, "Using a soilclass map with fao2 classification"
!
ALLOCATE(textfrac_table(nscm,ntext))
!
CALL get_soilcorr (nscm, textfrac_table)
!
DO ib =1, nbpt
!
! GO through the point we have found
!
!
fopt = COUNT(sub_area(ib,:) > zero)
!
! Check that we found some points
!
soilclass(ib,:) = 0.0
clayfraction(ib) = 0.0
!
IF ( fopt .EQ. 0) THEN
nbexp = nbexp + 1
soilclass(ib,:) = soilclass_default(:)
clayfraction(ib) = clayfraction_default
ELSE
!
DO ilf = 1,fopt
solt(ilf) = soiltext(sub_index(ib,ilf,1),sub_index(ib,ilf,2))
solt2(ilf) = soiltext2(sub_index(ib,ilf,1),sub_index(ib,ilf,2))
ENDDO
!
!
! Compute the average bare soil albedo parameters
!
sgn = zero
!
DO ilf = 1,fopt
!
!
!
IF ( (solt(ilf) .LE. nscm) .AND. (solt(ilf) .GT. 0) ) THEN
IF ( solt2(ilf) .GT. solt(ilf)) THEN
soilclass(ib,2*solt(ilf)) = soilclass(ib,2*solt(ilf)) + sub_area(ib,ilf)
ELSE
soilclass(ib,2*solt(ilf)-1) = soilclass(ib,2*solt(ilf)-1) + sub_area(ib,ilf)
ENDIF
clayfraction(ib) = clayfraction(ib) + textfrac_table(solt(ilf),3) * sub_area(ib,ilf)
sgn = sgn + sub_area(ib,ilf)
ELSE
IF (solt(ilf) .GT. nscm) THEN
WRITE(*,*) 'The file contains a soil color class which is incompatible with this program'
STOP 'slowproc_soilt'
ENDIF
ENDIF
!
ENDDO
!
! Normalize the surface
!
IF ( sgn .LT. min_sechiba) THEN
nbexp = nbexp + 1
soilclass(ib,:) = soilclass_default(:)
clayfraction(ib) = clayfraction_default
ELSE
soilclass(ib,:) = soilclass(ib,:)/sgn
clayfraction(ib) = clayfraction(ib)/sgn
ENDIF
!
ENDIF
!
ENDDO
!
!
CASE("usda")
!
soilclass_default=soilclass_default_usda
!
PRINT *, "Using a soilclass map with usda classification"
!
ALLOCATE(textfrac_table(nscm,ntext))
!
CALL get_soilcorr (nscm, textfrac_table)
!
DO ib =1, nbpt
!
! GO through the point we have found
!
!
fopt = COUNT(sub_area(ib,:) > zero)
!
! Check that we found some points
!
soilclass(ib,:) = 0.0
clayfraction(ib) = 0.0
!
IF ( fopt .EQ. 0) THEN
nbexp = nbexp + 1
soilclass(ib,:) = soilclass_default
clayfraction(ib) = clayfraction_default
ELSE
!
DO ilf = 1,fopt
solt(ilf) = soiltext(sub_index(ib,ilf,1),sub_index(ib,ilf,2))
ENDDO
!
!
! Compute the average bare soil albedo parameters
!
sgn = zero
!
DO ilf = 1,fopt
!
!
!
IF ( (solt(ilf) .LE. nscm) .AND. (solt(ilf) .GT. 0) ) THEN
soilclass(ib,solt(ilf)) = soilclass(ib,solt(ilf)) + sub_area(ib,ilf)
clayfraction(ib) = clayfraction(ib) + textfrac_table(solt(ilf),3) * sub_area(ib,ilf)
sgn = sgn + sub_area(ib,ilf)
ELSE
IF (solt(ilf) .GT. nscm) THEN
WRITE(*,*) 'The file contains a soil color class which is incompatible with this program'
STOP 'slowproc_soilt'
ENDIF
ENDIF
!
ENDDO
!
! Normalize the surface
!
IF ( sgn .LT. min_sechiba) THEN
nbexp = nbexp + 1
soilclass(ib,:) = soilclass_default(:)
clayfraction(ib) = clayfraction_default
ELSE
soilclass(ib,:) = soilclass(ib,:)/sgn
clayfraction(ib) = clayfraction(ib)/sgn
ENDIF
!
ENDIF
!
ENDDO
!
CASE DEFAULT
WRITE(*,*) 'A non supported soil type classification has been chosen'
STOP 'slowproc_soilt'
ENDSELECT
!
WRITE(numout,*) 'Interpolation Done'
!
IF ( nbexp .GT. 0 ) THEN
WRITE(numout,*) 'slowproc_soilt : The interpolation of the bare soil albedo had ', nbexp
WRITE(numout,*) 'slowproc_soilt : points without data. This are either coastal points or'
WRITE(numout,*) 'slowproc_soilt : ice covered land.'
WRITE(numout,*) 'slowproc_soilt : The problem was solved by using the default soil types.'
ENDIF
!
DEALLOCATE (lat_rel)
DEALLOCATE (lon_rel)
DEALLOCATE (mask)
DEALLOCATE (sub_area)
DEALLOCATE (sub_index)
DEALLOCATE (soiltext)
DEALLOCATE (soiltext2)
DEALLOCATE (solt)
DEALLOCATE (solt2)
DEALLOCATE (textfrac_table)
!
!
RETURN
!
END SUBROUTINE slowproc_soilt
!
!!
!! Calculate mean slope coef in each model grid box from the slope map
!!
SUBROUTINE slowproc_slope(nbpt, lalo, neighbours, resolution, contfrac, reinf_slope)
!
!
!
! 0.1 INPUT
!
INTEGER(i_std), INTENT(in) :: nbpt ! Number of points for which the data needs to be interpolated
REAL(r_std), INTENT(in) :: lalo(nbpt,2) ! Vector of latitude and longitudes (beware of the order !)
INTEGER(i_std), INTENT(in) :: neighbours(nbpt,8) ! Vector of neighbours for each grid point
! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
REAL(r_std), INTENT(in) :: resolution(nbpt,2) ! The size in km of each grid-box in X and Y
REAL(r_std), INTENT (in) :: contfrac(nbpt) !! Fraction of continent in the grid
!
! 0.2 OUTPUT
!
REAL(r_std), INTENT(out) :: reinf_slope(nbpt) ! slope coef
!
! 0.3 LOCAL
!
!
REAL(r_std) :: slope_noreinf ! Slope above which runoff is maximum
CHARACTER(LEN=80) :: filename
CHARACTER(LEN=30) :: callsign
INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, vid
INTEGER(i_std) :: idi, nbvmax
REAL(r_std) :: slopecoef
INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
INTEGER(i_std),ALLOCATABLE, DIMENSION(:,:,:) :: sub_index
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel, lon_rel, slopemap
REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_lu, lon_lu
REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
!
LOGICAL :: ok_interpol = .FALSE. ! optionnal return of aggregate_2d
!
INTEGER :: ALLOC_ERR
!
!
!
!Config Key = SLOPE_NOREINF
!Config Desc = See slope_noreinf above
!Config If =
!Config Def = 0.5
!Config Help = The slope above which there is no reinfiltration
!
slope_noreinf = 0.5
!
CALL getin_p('SLOPE_NOREINF',slope_noreinf)
!
!Config Key = TOPOGRAPHY_FILE
!Config Desc = Name of file from which the topography map is to be read
!Config If =
!Config Def = ../surfmap/cartepente.nc
!Config Help = The name of the file to be opened to read the orography
!Config map is to be given here. Usualy SECHIBA runs with a 2'
!Config map which is derived from the NGDC one.
!
filename = '../surfmap/cartepente2d_15min.nc'
CALL getin_p('TOPOGRAPHY_FILE',filename)
!
IF (is_root_prc) CALL flininfo(filename, iml, jml, lml, tml, fid)
CALL bcast(iml)
CALL bcast(jml)
CALL bcast(lml)
CALL bcast(tml)
!
ALLOC_ERR=-1
ALLOCATE(lat_lu(jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lat_lu : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lon_lu(iml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lon_lu : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(slopemap(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of slopemap : ",ALLOC_ERR
STOP
ENDIF
!
WRITE(numout,*) 'Reading the topography file'
!
IF (is_root_prc) THEN
CALL flinget(fid, 'longitude', iml, 0, 0, 0, 1, 1, lon_lu)
CALL flinget(fid, 'latitude', jml, 0, 0, 0, 1, 1, lat_lu)
CALL flinget(fid, 'pente', iml, jml, 0, 0, 1, 1, slopemap)
!
CALL flinclo(fid)
ENDIF
CALL bcast(lon_lu)
CALL bcast(lat_lu)
CALL bcast(slopemap)
!
ALLOC_ERR=-1
ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lon_rel : ",ALLOC_ERR
STOP
ENDIF
ALLOC_ERR=-1
ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of lat_rel : ",ALLOC_ERR
STOP
ENDIF
!
DO ip=1,iml
lat_rel(ip,:) = lat_lu(:)
ENDDO
DO jp=1,jml
lon_rel(:,jp) = lon_lu(:)
ENDDO
!
!
! Mask of permitted variables.
!
ALLOC_ERR=-1
ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of mask : ",ALLOC_ERR
STOP
ENDIF
!
mask(:,:) = zero
DO ip=1,iml
DO jp=1,jml
IF (slopemap(ip,jp) .GT. min_sechiba) THEN
mask(ip,jp) = un
ENDIF
ENDDO
ENDDO
!
! nbvmax = 2000
nbvmax = 220
!
callsign="Slope map"
!
DO WHILE ( .NOT. ok_interpol )
WRITE(numout,*) "Projection arrays for ",callsign," : "
WRITE(numout,*) "nbvmax = ",nbvmax
!
ALLOC_ERR=-1
ALLOCATE(sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
STOP
ENDIF
sub_index(:,:,:)=0
ALLOC_ERR=-1
ALLOCATE(sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
IF (ALLOC_ERR/=0) THEN
WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
STOP
ENDIF
sub_area(:,:)=zero
!
CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
& iml, jml, lon_rel, lat_rel, mask, callsign, &
& nbvmax, sub_index, sub_area, ok_interpol)
!
IF ( .NOT. ok_interpol ) THEN
DEALLOCATE(sub_area)
DEALLOCATE(sub_index)
!
nbvmax = nbvmax * 2
ENDIF
ENDDO
!
DO ib = 1, nbpt
idi=1
!-
!- Reinfiltration coefficient due to the slope: Calculation with parameteres maxlope_ro
!-
slopecoef = zero
DO WHILE ( sub_area(ib,idi) > zero )
ip = sub_index(ib,idi,1)
jp = sub_index(ib,idi,2)
!
slopecoef = slopecoef + MIN(slopemap(ip,jp)/slope_noreinf, un) * sub_area(ib,idi)
idi = idi +1
ENDDO
IF ( idi .GT. 1 ) THEN
reinf_slope(ib) = un - slopecoef / SUM(sub_area(ib,1:(idi-1)))
ELSE
reinf_slope(ib) = slope_default
ENDIF
ENDDO
!
!
WRITE(numout,*) 'Interpolation Done'
!
!
DEALLOCATE(slopemap)
DEALLOCATE(sub_index)
DEALLOCATE(sub_area)
DEALLOCATE(mask)
DEALLOCATE(lon_lu)
DEALLOCATE(lat_lu)
DEALLOCATE(lon_rel)
DEALLOCATE(lat_rel)
!
!
RETURN
!
END SUBROUTINE slowproc_slope
END MODULE slowproc
ORCHIDEE/src_sechiba/Makefile 0000754 0103600 0005670 00000010016 11164403473 015630 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.7 2008/01/08 11:49:07 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a SECHIBA
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/libsechiba.a
SXMODEL_LIB = $(MODEL_LIB)
#-
#- $Id: AA_make.gdef 578 2009-03-13 14:05:38Z bellier $
#-
#- Global definitions for gnu g95 compiler
M_K = gmake
P_C = cpp
P_O = -P -C -traditional $(P_P)
F_C = g95 -c
F_D =
F_P = -i4 -r8
w_w = -O5 -cpp -funroll-all-loops $(F_D) $(F_P) -I$(MODDIR)
#####################################-Q- g95 F_O = $(w_w) -fmod=$(MODDIR) -fno-second-underscore
F_O = $(w_w) -fmod=$(MODDIR)
F_L = g95
M_M = 0
L_X = 0
L_O =
A_C = ar -r
A_G = ar -x
C_C = cc -c
C_O =
C_L = cc
#-
NCDF_INC = /d4/acamlmd/LMDZ4V4/netcdf-3.6.1/include
NCDF_LIB = -L/d4/acamlmd/LMDZ4V4/netcdf-3.6.1/lib -lnetcdf
#-
RM = rm -f
STRIP = strip
SIZE = size
#-
#- $Id: AA_make,v 1.20 2008/01/08 11:49:07 ssipsl Exp $
#-
PARAM_LIB = $(LIBDIR)/libparameters.a
SXPARAM_LIB = $(PARAM_LIB)
#-
PARALLEL_LIB = $(LIBDIR)/libparallel.a
SXPARALLEL_LIB = $(PARALLEL_LIB)
#-
ORGLOB_LIB = $(LIBDIR)/liborglob.a
SXORGLOB_LIB = $(ORGLOB_LIB)
#-
STOMATE_LIB = $(LIBDIR)/libstomate.a
SXSTOMATE_LIB = $(STOMATE_LIB)
#-
MODS1 = \
sechiba_io_p.f90 \
sechiba_io.f90 \
slowproc.f90 \
diffuco.f90 \
condveg.f90 \
enerbil.f90 \
hydrol.f90 \
hydrolc.f90 \
thermosoil.f90 \
routing.f90 \
sechiba.f90 \
intersurf.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-
all:
$(M_K) libparameters
$(M_K) libparallel
$(M_K) libstomate
$(M_K) m_all
@echo sechiba is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
libparameters:
(cd ../src_parameters; $(M_K) -f Makefile)
libparallel:
(cd ../src_parallel; $(M_K) -f Makefile)
liborglob:
(cd ../src_global; $(M_K) -f Makefile)
libstomate:
(cd ../src_stomate; $(M_K) -f Makefile)
$(MODEL_LIB)(%.o) : %.f90
$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
$(A_C) $(MODEL_LIB) $*.o
$(RM) $*.o
config :
$(BINDIR)/Fparser -name SECHIBA $(MODS1)
echo 'Configuration of SECHIBA done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(sechiba.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(MODEL_LIB)(sechiba_io_p.o) \
$(MODEL_LIB)(sechiba_io.o) \
$(MODEL_LIB)(diffuco.o) \
$(MODEL_LIB)(condveg.o) \
$(MODEL_LIB)(enerbil.o) \
$(MODEL_LIB)(hydrolc.o) \
$(MODEL_LIB)(hydrol.o) \
$(MODEL_LIB)(thermosoil.o) \
$(MODEL_LIB)(slowproc.o) \
$(MODEL_LIB)(routing.o)
$(MODEL_LIB)(sechiba_io_p.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(PARALLEL_LIB)(parallel.o)
$(MODEL_LIB)(sechiba_io.o): \
$(MODEL_LIB)(sechiba_io_p.o) \
$(PARAM_LIB)(constantes_veg.o)
$(MODEL_LIB)(hydrol.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(MODEL_LIB)(sechiba_io.o) \
$(ORGLOB_LIB)(grid.o)
$(MODEL_LIB)(hydrolc.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(slowproc.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(STOMATE_LIB)(stomate.o) \
$(MODEL_LIB)(sechiba_io.o) \
$(ORGLOB_LIB)(interpol_help.o)
$(MODEL_LIB)(diffuco.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(enerbil.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(condveg.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(ORGLOB_LIB)(interpol_help.o)
$(MODEL_LIB)(thermosoil.o): \
$(PARAM_LIB)(constantes_soil.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(routing.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(MODEL_LIB)(sechiba_io.o)
$(MODEL_LIB)(intersurf.o): \
$(PARAM_LIB)(constantes_veg.o) \
$(ORGLOB_LIB)(grid.o) \
$(MODEL_LIB)(sechiba.o)
ORCHIDEE/src_sechiba/hydrol.f90 0000754 0103600 0005670 00000601547 11164403473 016030 0 ustar acamlmd lmdjus !tdo - enlever toute profondeur variable pour voir l'effet sur l'efficacite du code
!!
!! This module computes hydrologic processes on continental points.
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.35 $, $Date: 2007/06/12 20:02:37 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/hydrol.f90,v 1.35 2007/06/12 20:02:37 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE hydrol
!
!
! routines called : restput, restget
!
USE ioipsl
!
! modules used :
USE constantes
USE constantes_soil
USE constantes_veg
USE sechiba_io
! for debug :
USE grid
IMPLICIT NONE
! public routines :
! hydrol
PRIVATE
PUBLIC :: hydrol_main,hydrol_clear
!
! variables used inside hydrol module : declaration and initialisation
!
LOGICAL, SAVE :: l_first_hydrol=.TRUE. !! Initialisation has to be done one time
!
LOGICAL, SAVE :: check_cwrr=.FALSE. !! The check the water balance
LOGICAL, SAVE :: doponds=.FALSE. !! Reinfiltration param.
CHARACTER(LEN=80) , SAVE :: file_ext !! Extention for I/O filename
CHARACTER(LEN=80) , SAVE :: var_name !! To store variables names for I/O
REAL(r_std), PARAMETER :: drain_rest_cste = 15.0 !! time constant in days to return to free drainage after return flow
REAL(r_std), PARAMETER :: allowed_err = 2.0E-8_r_std
! one dimension array allocated, computed, saved and got in hydrol module
! Values per soil type
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: nvan
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: avan
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mcr
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mcs !! Saturation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: ks
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: ds
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: pcent
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: free_drain_max
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mcf !! Field capacity / Capacité au champ
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mcw !! Wilting point / Point de flétrissement
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mc_awet
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mc_adry
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: psis
! Values per grid point
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_water_beg !! Total amount of water at start of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_water_end !! Total amount of water at end of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_flux !! Total water flux
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_watveg_beg !! Total amount of water on vegetation at start of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_watveg_end !! Total amount of water on vegetation at end of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_watsoil_beg !! Total amount of water in the soil at start of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_watsoil_end !! Total amount of water in the soil at end of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snow_beg !! Total amount of snow at start of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snow_end !! Total amount of snow at end of time step
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: delsoilmoist !! Change in soil moisture
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: delintercept !! Change in interception storage
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: delswe !! Change in SWE^Q
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: swi !! Soil Wetness Index
! array allocated, computed, saved and got in hydrol module
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: mask_veget !! zero/one when veget fraction is zero/higher
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: mask_soiltile !! zero/one where soil fraction is zero/higher
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: humrelv !! humrel for each soil type
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: vegstressv !! vegstress for each soil type
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:,:):: us !! relative humidity
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: precisol !! Eau tombee sur le sol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: precisol_ns !! Eau tombee sur le sol par type de sol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: ae_ns !! Evaporation du sol nu par type de sol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: evap_bare_lim_ns !! limitation of bare soil evaporation on each soil column (used to deconvoluate vevapnu)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: free_drain_coef !! Coefficient for free drainage at bottom
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: frac_bare_ns !! evaporating bare soil fraction per tile
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_frac_bare !! total evaporating bare soil fraction
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: rootsink !! stress racinaire par niveau et type de sol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: subsnowveg !! Sublimation of snow on vegetation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: subsnownobio !! Sublimation of snow on other surface types (ice, lakes, ...)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snowmelt !! Quantite de neige fondue
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: icemelt !! Quantite de glace fondue
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: subsinksoil !! Excess of sublimation as a sink for the soil
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vegtot !! Total vegetation
! The last vegetation map which was used to distribute the reservoirs
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: resdist !! Distribution of reservoirs
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: mx_eau_var
! arrays used by cwrr scheme
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: nroot !! nvm * nstm * nslm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: kfact_root !! kjpindex * nslm * nstm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: kfact !! nslm * nscm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: zz !! nslm+1 * nstm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dz !! nslm+1 * nstm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: mc_lin !! imin:imax * nscm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: k_lin !! imin:imax * nslm * nscm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: d_lin !! imin:imax * nslm * nscm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: a_lin !! imin:imax * nslm * nscm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: b_lin !! imin:imax * nslm * nscm
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: humtot !! (:)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: flux !! (:)
LOGICAL, ALLOCATABLE, SAVE, DIMENSION (:) :: resolv !! (:)
!! linarization coefficients of hydraulic conductivity K
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: k !! (:,nslm)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: a !! (:,nslm)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: b !!
!! linarization coefficients of hydraulic diffusivity D
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: d !!
!! matrix coefficients
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: e !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: f !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: g1 !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: ep !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: fp !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: gp !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: rhs !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: srhs !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: gam !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: water2infilt !! Water to be infiltrated
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmc !! (:,nstm) Total moisture content (mm)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmcr !! (nstm) Total moisture constent at residual (mm)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmcs !! (nstm) Total moisture constent at saturation (mm)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmc_litter !! (:,nstm) Total moisture in the litter by soil type
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tmc_litt_mea !! Total moisture in the litter over the grid
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmc_litter_wilt !! (:,nstm) Moisture of litter at wilt pt
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmc_litter_field !! (:,nstm) Moisture of litter at field cap.
!!! A CHANGER DANS TOUT HYDROL: tmc_litter_res et sat ne devraient pas dependre de ji - tdo
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmc_litter_res !! (:,nstm) Moisture of litter at residual moisture.
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmc_litter_sat !! (:,nstm) Moisture of litter at saturatiion
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmc_litter_awet !! (:,nstm) Moisture of litter at mc_awet
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tmc_litter_adry !! (:,nstm) Moisture of litter at mc_dry
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tmc_litt_wet_mea !! Total moisture in the litter over the grid below which albedo is fixed
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tmc_litt_dry_mea !! Total moisture in the litter over the grid above which albedo is fixed
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: v1 !! (:)
! REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vB !! (:)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: qflux00 !! flux at the top of the soil column
!! par type de sol :
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: ru_ns !! ruissellement
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: dr_ns !! drainage
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: tr_ns !! transpiration
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: cvs_over_veg !! (:,nvm,nstm) old value of corr_veg_soil/veget kept from diag to next split
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: corr_veg_soil !! (:,nvm,nstm) percentage of each veg. type on each soil of each grid point
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: mc !! (:,nslm,nstm) m³ x m³
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: soilmoist !! (:,nslm)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: soil_wet !! soil wetness
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: soil_wet_litter !! soil wetness of the litter
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: qflux !! fluxes between the soil layers
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: tmat !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: stmat !!
LOGICAL, SAVE :: interpol_diag=.FALSE.
INTEGER(i_std), SAVE :: kjit_ !! Time step number
CONTAINS
!!
!! Main routine for *hydrol* module
!! - called only one time for initialisation
!! - called every time step
!! - called one more time at last time step for writing _restart_ file
!!
!! Algorithm:
!! - call hydrol_snow for snow process (including age of snow)
!! - call hydrol_canop for canopy process
!! - call hydrol_soil for bare soil process
!!
!! @call hydrol_snow
!! @call hydrol_canop
!! @call hydrol_soil
!!
SUBROUTINE hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
& index, indexveg, indexsoil, indexlayer, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, njsc, &
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age, &
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, &
& humrel, vegstress, drysoil_frac, evapot, evapot_penm, evap_bare_lim, flood_frac, flood_res, &
& shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std),INTENT (in) :: rest_id,hist_id !! _Restart_ file and _history_ file identifier
INTEGER(i_std),INTENT (in) :: hist2_id !! _history_ file 2 identifier
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for _restart_ file to write
! input fields
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in):: indexveg !! Indeces of the points on the 3D map for veg
INTEGER(i_std),DIMENSION (kjpindex*nstm), INTENT (in):: indexsoil !! Indeces of the points on the 3D map for soil
INTEGER(i_std),DIMENSION (kjpindex*nslm), INTENT (in):: indexlayer !! Indeces of the points on the 3D map for soil layers
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: returnflow !! Routed water which comes back into the soil (from the bottom)
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: reinfiltration !! Routed water which comes back into the soil (at the top)
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: irrigation !! Water from irrigation returning to soil moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol_new !! New soil temperature
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: njsc !! Indeces of the soiltype
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: frac_nobio !! Fraction of ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: totfrac_nobio !! Total fraction of ice+lakes+...
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: soilcap !! Soil capacity
REAL(r_std),DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile !! Map of soil types
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vevapwet !! Interception loss
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: frac_bare !! Fraction of bare soil in each vegetation type
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintmax !! Maximum water on vegetation for interception
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: transpir !! Transpiration
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: reinf_slope !! slope coef
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot !! Soil Potential Evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: evapot_penm !! Soil Potential Evaporation Correction
! modified fields
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: evap_bare_lim !!
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: vevapnu !! Bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: vevapsno !! Snow evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: vevapflo !! Snow evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: flood_res !! flood reservoir estimate
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: flood_frac !! flood fraction
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: snow !! Snow mass [Kg/m^2]
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: snow_age !! Snow age
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio !! Water balance on ice, lakes, .. [Kg/m^2]
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio_age !! Snow age on ice, lakes, ...
!! We consider that any water on the ice is snow and we only peforme a water balance to have consistency.
!! The water balance is limite to + or - 10^6 so that accumulation is not endless
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: floodout !! flux out of floodplains
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: runoff !! Complete runoff
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: drainage !! Drainage
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: humrel !! Relative humidity
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vegstress !! Veg. moisture stress (only for vegetation growth)
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: drysoil_frac !! function of litter wetness
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: shumdiag !! relative soil moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: k_litt !! litter approximate conductivity
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: litterhumdiag !! litter humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: tot_melt !! Total melt
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: qsintveg !! Water on vegetation due to interception
!
! local declaration
!
INTEGER(i_std) :: jst, jsl
REAL(r_std),DIMENSION (kjpindex) :: soilwet !! A temporary diagnostic of soil wetness
REAL(r_std),DIMENSION (kjpindex) :: snowdepth !! Depth of snow layer
REAL(r_std),DIMENSION (kjpindex) :: njsc_tmp !! Temporary REAL value for njsc to write it
kjit_=kjit
!
! do initialisation
!
IF (l_first_hydrol) THEN
IF (long_print) WRITE (numout,*) ' l_first_hydrol : call hydrol_init '
CALL hydrol_init (kjit, ldrestart_read, kjpindex, index, rest_id, veget, soiltile, humrel,&
& vegstress, snow, snow_age, snow_nobio, snow_nobio_age, qsintveg)
CALL hydrol_var_init (kjpindex, veget, soiltile, njsc, mx_eau_var, shumdiag, k_litt, &
& litterhumdiag, drysoil_frac, evap_bare_lim)
!
! If we check the water balance we first save the total amount of water
!
IF (check_waterbal) THEN
CALL hydrol_waterbal(kjpindex, index, .TRUE., dtradia, veget, &
& totfrac_nobio, qsintveg, snow, snow_nobio,&
& precip_rain, precip_snow, returnflow, reinfiltration, irrigation, tot_melt, &
& vevapwet, transpir, vevapnu, vevapsno, vevapflo, floodout, runoff,drainage)
ENDIF
!
IF (almaoutput) THEN
CALL hydrol_alma(kjpindex, index, .TRUE., qsintveg, snow, snow_nobio, soilwet)
ENDIF
RETURN
ENDIF
!
! prepares restart file for the next simulation
!
IF (ldrestart_write) THEN
IF (long_print) WRITE (numout,*) ' we have to complete restart file with HYDROLOGIC variables '
DO jst=1,nstm
! var_name= "mc_1" ... "mc_3"
WRITE (var_name,"('moistc_',i1)") jst
CALL restput_p(rest_id, var_name, nbp_glo, nslm, 1, kjit, mc(:,:,jst), 'scatter', nbp_glo, index_g)
END DO
!
DO jst=1,nstm
DO jsl=1,nslm
! var_name= "us_1_01" ... "us_3_11"
WRITE (var_name,"('us_',i1,'_',i2.2)") jst,jsl
CALL restput_p(rest_id, var_name, nbp_glo,nvm, 1,kjit,us(:,:,jst,jsl),'scatter',nbp_glo,index_g)
END DO
END DO
!
var_name= 'free_drain_coef'
CALL restput_p(rest_id, var_name, nbp_glo, nstm, 1, kjit, free_drain_coef, 'scatter', nbp_glo, index_g)
!
var_name= 'water2infilt'
CALL restput_p(rest_id, var_name, nbp_glo, nstm, 1, kjit, water2infilt, 'scatter', nbp_glo, index_g)
!
var_name= 'ae_ns'
CALL restput_p(rest_id, var_name, nbp_glo, nstm, 1, kjit, ae_ns, 'scatter', nbp_glo, index_g)
!
var_name= 'vegstress'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, vegstress, 'scatter', nbp_glo, index_g)
!
var_name= 'snow'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, snow, 'scatter', nbp_glo, index_g)
!
var_name= 'snow_age'
CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, snow_age, 'scatter', nbp_glo, index_g)
!
var_name= 'snow_nobio'
CALL restput_p(rest_id, var_name, nbp_glo, nnobio, 1, kjit, snow_nobio, 'scatter', nbp_glo, index_g)
!
var_name= 'snow_nobio_age'
CALL restput_p(rest_id, var_name, nbp_glo, nnobio, 1, kjit, snow_nobio_age, 'scatter', nbp_glo, index_g)
!
var_name= 'qsintveg'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, qsintveg, 'scatter', nbp_glo, index_g)
!
var_name= 'resdist'
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, resdist, 'scatter', nbp_glo, index_g)
!
DO jst=1,nstm
! var_name= "cvs_over_veg_1" ... "cvs_over_veg_3"
WRITE (var_name,"('cvs_over_veg_',i1)") jst
CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, cvs_over_veg(:,:,jst), 'scatter', nbp_glo, index_g)
END DO
!
!!$ DO jst=1,nstm
!!$ ! var_name= "humrelv_1" ... "humrelv_3"
!!$ WRITE (var_name,"('humrelv_',i1)") jst
!!$ CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit, humrelv(:,:,jst), 'scatter', nbp_glo, index_g)
!!$ END DO
!
RETURN
!
END IF
!
! shared time step
!
IF (long_print) WRITE (numout,*) 'hydrol pas de temps = ',dtradia
!
! computes snow
!
CALL hydrol_snow(kjpindex, dtradia, precip_rain, precip_snow, temp_sol_new, soilcap, &
& frac_nobio, totfrac_nobio, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
& tot_melt, snowdepth)
!
! computes canopy
!
!
CALL hydrol_vegupd(kjpindex, veget, frac_bare, soiltile, qsintveg,resdist)
!
CALL hydrol_canop(kjpindex, precip_rain, vevapwet, veget, qsintmax, qsintveg,precisol,tot_melt)
!
! computes surface reservoir
!
CALL hydrol_flood(kjpindex, dtradia, vevapflo, flood_frac, flood_res, floodout)
!
! computes hydro_soil
!
CALL hydrol_soil(kjpindex, dtradia, veget, soiltile, njsc, reinf_slope, &
& transpir, vevapnu, evapot, evapot_penm, runoff, drainage, returnflow, reinfiltration, irrigation, &
& tot_melt,evap_bare_lim, shumdiag, k_litt, litterhumdiag, humrel, vegstress, drysoil_frac)
!
! If we check the water balance we end with the comparison of total water change and fluxes
!
IF (check_waterbal) THEN
CALL hydrol_waterbal(kjpindex, index, .FALSE., dtradia, veget, totfrac_nobio, &
& qsintveg, snow, snow_nobio, precip_rain, precip_snow, returnflow, reinfiltration, &
& irrigation, tot_melt, vevapwet, transpir, vevapnu, vevapsno, vevapflo, floodout, runoff, drainage)
ENDIF
!
! If we use the ALMA standards
!
IF (almaoutput) THEN
CALL hydrol_alma(kjpindex, index, .FALSE., qsintveg, snow, snow_nobio, soilwet)
ENDIF
!
IF ( .NOT. almaoutput ) THEN
DO jst=1,nstm
! var_name= "mc_1" ... "mc_3"
WRITE (var_name,"('moistc_',i1)") jst
CALL histwrite(hist_id, trim(var_name), kjit,mc(:,:,jst), kjpindex*nslm, indexlayer)
! var_name= "kfactroot_1" ... "kfactroot_3"
WRITE (var_name,"('kfactroot_',i1)") jst
CALL histwrite(hist_id, trim(var_name), kjit, kfact_root(:,:,jst), kjpindex*nslm, indexlayer)
! var_name= "vegetsoil_1" ... "vegetsoil_3"
! WRITE (var_name,"('vegetsoil_',i1)") jst
! CALL histwrite(hist_id, trim(var_name), kjit,corr_veg_soil(:,:,jst), kjpindex*nvm, indexveg)
ENDDO
CALL histwrite(hist_id, 'evapnu_soil', kjit, ae_ns, kjpindex*nstm, indexsoil)
CALL histwrite(hist_id, 'drainage_soil', kjit, dr_ns, kjpindex*nstm, indexsoil)
CALL histwrite(hist_id, 'transpir_soil', kjit, tr_ns, kjpindex*nstm, indexsoil)
CALL histwrite(hist_id, 'runoff_soil', kjit, ru_ns, kjpindex*nstm, indexsoil)
CALL histwrite(hist_id, 'humtot_soil', kjit, tmc, kjpindex*nstm, indexsoil)
CALL histwrite(hist_id, 'humtot', kjit, humtot, kjpindex, index)
njsc_tmp(:)=njsc(:)
CALL histwrite(hist_id, 'njsc', kjit, njsc_tmp, kjpindex, index)
CALL histwrite(hist_id, 'humrel', kjit, humrel, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'drainage', kjit, drainage, kjpindex, index)
CALL histwrite(hist_id, 'runoff', kjit, runoff, kjpindex, index)
CALL histwrite(hist_id, 'floodout', kjit, floodout, kjpindex, index)
CALL histwrite(hist_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'rain', kjit, precip_rain, kjpindex, index)
CALL histwrite(hist_id, 'snowf', kjit, precip_snow, kjpindex, index)
CALL histwrite(hist_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'SWI', kjit, swi, kjpindex, index)
IF ( hist2_id > 0 ) THEN
DO jst=1,nstm
! var_name= "mc_1" ... "mc_3"
WRITE (var_name,"('moistc_',i1)") jst
CALL histwrite(hist2_id, trim(var_name), kjit,mc(:,:,jst), kjpindex*nslm, indexlayer)
! var_name= "kfactroot_1" ... "kfactroot_3"
WRITE (var_name,"('kfactroot_',i1)") jst
CALL histwrite(hist2_id, trim(var_name), kjit, kfact_root(:,:,jst), kjpindex*nslm, indexlayer)
! var_name= "vegetsoil_1" ... "vegetsoil_3"
! WRITE (var_name,"('vegetsoil_',i1)") jst
! CALL histwrite(hist2_id, trim(var_name), kjit,corr_veg_soil(:,:,jst), kjpindex*nvm, indexveg)
ENDDO
CALL histwrite(hist2_id, 'evapnu_soil', kjit, ae_ns, kjpindex*nstm, indexsoil)
CALL histwrite(hist2_id, 'drainage_soil', kjit, dr_ns, kjpindex*nstm, indexsoil)
CALL histwrite(hist2_id, 'transpir_soil', kjit, tr_ns, kjpindex*nstm, indexsoil)
CALL histwrite(hist2_id, 'runoff_soil', kjit, ru_ns, kjpindex*nstm, indexsoil)
CALL histwrite(hist2_id, 'humtot_soil', kjit, tmc, kjpindex*nstm, indexsoil)
CALL histwrite(hist2_id, 'humtot', kjit, humtot, kjpindex, index)
njsc_tmp(:)=njsc(:)
CALL histwrite(hist2_id, 'njsc', kjit, njsc_tmp, kjpindex, index)
CALL histwrite(hist2_id, 'humrel', kjit, humrel, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'drainage', kjit, drainage, kjpindex, index)
CALL histwrite(hist2_id, 'runoff', kjit, runoff, kjpindex, index)
CALL histwrite(hist2_id, 'floodout', kjit, floodout, kjpindex, index)
CALL histwrite(hist2_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'rain', kjit, precip_rain, kjpindex, index)
CALL histwrite(hist2_id, 'snowf', kjit, precip_snow, kjpindex, index)
CALL histwrite(hist2_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'SWI', kjit, swi, kjpindex, index)
!
IF (check_waterbal) THEN
CALL histwrite(hist2_id, 'TotWater', kjit, tot_water_end, kjpindex, index)
CALL histwrite(hist2_id, 'TotWaterFlux', kjit, tot_flux, kjpindex, index)
ENDIF
ENDIF
ELSE
CALL histwrite(hist_id, 'Snowf', kjit, precip_snow, kjpindex, index)
CALL histwrite(hist_id, 'Rainf', kjit, precip_rain, kjpindex, index)
CALL histwrite(hist_id, 'Qs', kjit, runoff, kjpindex, index)
CALL histwrite(hist_id, 'Qsb', kjit, drainage, kjpindex, index)
CALL histwrite(hist_id, 'Qsm', kjit, tot_melt, kjpindex, index)
CALL histwrite(hist_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
CALL histwrite(hist_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
!
CALL histwrite(hist_id, 'SoilMoist', kjit, soilmoist, kjpindex*nslm, indexlayer)
CALL histwrite(hist_id, 'SoilWet', kjit, soilwet, kjpindex, index)
! CALL histwrite(hist_id, 'SWI', kjit, swi, kjpindex, index)
!
CALL histwrite(hist_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
CALL histwrite(hist_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
!
CALL histwrite(hist_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
!
IF ( hist2_id > 0 ) THEN
CALL histwrite(hist2_id, 'Snowf', kjit, precip_snow, kjpindex, index)
CALL histwrite(hist2_id, 'Rainf', kjit, precip_rain, kjpindex, index)
CALL histwrite(hist2_id, 'Qs', kjit, runoff, kjpindex, index)
CALL histwrite(hist2_id, 'Qsb', kjit, drainage, kjpindex, index)
CALL histwrite(hist2_id, 'Qsm', kjit, tot_melt, kjpindex, index)
CALL histwrite(hist2_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
CALL histwrite(hist2_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
!
CALL histwrite(hist2_id, 'SoilMoist', kjit, soilmoist, kjpindex*nslm, indexlayer)
CALL histwrite(hist2_id, 'SoilWet', kjit, soilwet, kjpindex, index)
CALL histwrite(hist2_id, 'SWI', kjit, swi, kjpindex, index)
!
CALL histwrite(hist2_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
CALL histwrite(hist2_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
!
CALL histwrite(hist2_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
ENDIF
ENDIF
IF (long_print) WRITE (numout,*) ' hydrol_main Done '
END SUBROUTINE hydrol_main
!! Algorithm:
!! - dynamic allocation for local array
!! - _restart_ file reading for HYDROLOGIC variables
!!
SUBROUTINE hydrol_init(kjit, ldrestart_read, kjpindex, index, rest_id, veget, soiltile, humrel,&
& vegstress, snow, snow_age, snow_nobio, snow_nobio_age, qsintveg)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjit !! Time step number
LOGICAL,INTENT (in) :: ldrestart_read !! Logical for _restart_ file to read
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std), INTENT (in) :: rest_id !! _Restart_ file identifier
! input fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Carte de vegetation
REAL(r_std),DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile !! Map of soil types
! output fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: humrel !! Stress hydrique, relative humidity
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vegstress !! Veg. moisture stress (only for vegetation growth)
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: snow !! Snow mass [Kg/m^2]
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: snow_age !! Snow age
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: snow_nobio !! Snow on ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: snow_nobio_age !! Snow age on ice, lakes, ...
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: qsintveg !! Water on vegetation due to interception
! local declaration
INTEGER(i_std) :: ier, ierror, ipdt
INTEGER(i_std) :: ji, jv, jst, jsl, ik, jsc
REAL(r_std),DIMENSION (kjpindex,nvm,nstm) :: humrelv_temp !! initialization for humrelv
! initialisation
IF (l_first_hydrol) THEN
l_first_hydrol=.FALSE.
ELSE
WRITE (numout,*) ' l_first_hydrol false . we stop '
STOP 'hydrol_init'
ENDIF
!
! Some initializations
!
!
!Config Key = CHECK_CWRR
!Config Desc = Should we check detailed CWRR water balance ?
!Config Def = FALSE
!Config Help = This parameters allows the user to check
!Config the detailed water balance in each time step
!Config of CWRR.
!
check_cwrr = .FALSE.
CALL getin_p('CHECK_CWRR', check_cwrr)
!
!Config Key = DOPONDS
!Config Desc = Should we include ponds
!Config Def = FALSE
!Config Help = This parameters allows the user to ask the model
!Config to take into account the ponds and return
!Config the water into the soil moisture. If this is
!Config activated, then there is no reinfiltration
!Config computed inside the hydrol module.
!
doponds = .FALSE.
CALL getin_p('DO_PONDS', doponds)
! make dynamic allocation with good dimension
! one dimension array allocation with possible restart value
ALLOCATE (nvan(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (avan(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (mcr(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (mcs(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (ks(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (ds(nslm,nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nslm*nscm
STOP 'hydrol_init'
END IF
ALLOCATE (pcent(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (free_drain_max(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (mcf(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (mcw(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (mc_awet(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (mc_adry(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
ALLOCATE (psis(nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need nscm words = ',nscm
STOP 'hydrol_init'
END IF
SELECTCASE (nscm)
CASE (3)
nvan = nvan_fao
avan = avan_fao
mcr = mcr_fao
mcs = mcs_fao
ks = ks_fao
ds(:,:)=zero
pcent = pcent_fao
free_drain_max = free_drain_max_fao
mcf = mcf_fao
mcw = mcw_fao
mc_awet = mc_awet_fao
mc_adry = mc_adry_fao
psis = psis_fao
CASE (5)
DO jsc =1, nscm
nvan(jsc) = nvan_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
avan(jsc) = avan_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
mcr(jsc) = mcr_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
mcs(jsc) = mcs_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
ks(jsc) = ks_fao(CEILING(jsc*un/deux))
ENDDO
ds(:,:)=zero
DO jsc =1, nscm
pcent(jsc) = pcent_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
free_drain_max(jsc) = free_drain_max_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
mcf(jsc) = mcf_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
mcw(jsc) = mcw_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
mc_awet(jsc) = mc_awet_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
mc_adry(jsc) = mc_adry_fao(CEILING(jsc*un/deux))
ENDDO
DO jsc =1, nscm
psis(jsc) = psis_fao(CEILING(jsc*un/deux))
ENDDO
CASE (12)
nvan = nvan_usda
avan = avan_usda
mcr = mcr_usda
mcs = mcs_usda
ks = ks_usda
ds(:,:)=zero
pcent = pcent_usda
free_drain_max = free_drain_max_usda
mcf = mcf_usda
mcw = mcw_usda
mc_awet = mc_awet_usda
mc_adry = mc_adry_usda
psis = psis_usda
CASE DEFAULT
WRITE (numout,*) 'Unsupported soil type classification. Choose between zobler, fao and usda according to the map'
STOP 'hydrol_init'
ENDSELECT
ALLOCATE (mask_veget(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in mask_veget allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'hydrol_init'
END IF
ALLOCATE (mask_soiltile(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in mask_soiltile allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (humrelv(kjpindex,nvm,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in humrelv allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (vegstressv(kjpindex,nvm,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vegstressv allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (us(kjpindex,nvm,nstm,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in us allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (precisol(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in precisol allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'hydrol_init'
END IF
ALLOCATE (precisol_ns(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in precisol_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (free_drain_coef(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in free_drain_coef allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (frac_bare_ns(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in frac_bare_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tot_frac_bare(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_frac_bare allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (water2infilt(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in water2infilt allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (ae_ns(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in ae_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (evap_bare_lim_ns(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in evap_bare_lim_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (rootsink(kjpindex,nslm,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rootsink allocation. We stop. We need kjpindex words = ',kjpindex*nslm*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (subsnowveg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in subsnowveg allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (subsnownobio(kjpindex,nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in subsnownobio allocation. We stop. We need kjpindex words = ',kjpindex*nnobio
STOP 'hydrol_init'
END IF
ALLOCATE (snowmelt(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snowmelt allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (icemelt(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in icemelt allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (subsinksoil(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in subsinksoil allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (mx_eau_var(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in mx_eau_var allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (vegtot(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vegtot allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (resdist(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in resdist allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'hydrol_init'
END IF
ALLOCATE (humtot(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in humtot allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (flux(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in flux allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (resolv(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in resolv allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (k(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in k allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (a(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in a allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (b(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in b allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (d(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in d allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (e(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in e allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (f(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in f allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (g1(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in g1 allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (ep(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in ep allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (fp(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in fp allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (gp(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in gp allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (rhs(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rhs allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (srhs(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in srhs allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (gam(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in gam allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (tmc(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmcs(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmcs allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmcr(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmcr allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litter(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litter allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litt_mea(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litt_mea allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litter_res(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litter_res allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litter_wilt(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litter_wilt allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litter_field(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litter_field allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litter_sat(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litter_sat allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litter_awet(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litter_awet allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litter_adry(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litter_adry allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litt_wet_mea(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litt_wet_mea allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (tmc_litt_dry_mea(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmc_litt_dry_mea allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (v1(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in v1 allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
! ALLOCATE (vB(kjpindex,nstm),stat=ier)
! IF (ier.NE.0) THEN
! WRITE (numout,*) ' error in vB allocation. We stop. We need kjpindex words = ',kjpindex*nstm
! STOP 'hydrol_init'
! END IF
ALLOCATE (qflux00(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qflux00 allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (ru_ns(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in ru_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (dr_ns(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in dr_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tr_ns(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tr_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (cvs_over_veg(kjpindex,nvm,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in cvs_over_veg allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (corr_veg_soil(kjpindex,nvm,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in corr_veg_soil allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (mc(kjpindex,nslm,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in mc allocation. We stop. We need kjpindex words = ',kjpindex*nslm*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (soilmoist(kjpindex,nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soilmoist allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'hydrol_init'
END IF
ALLOCATE (soil_wet(kjpindex,nslm,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soil_wet allocation. We stop. We need kjpindex words = ',kjpindex*nslm*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (soil_wet_litter(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soil_wet allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (qflux(kjpindex,nslm,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qflux allocation. We stop. We need kjpindex words = ',kjpindex*nslm*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (tmat(kjpindex,nslm,3),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tmat allocation. We stop. We need kjpindex words = ',kjpindex*nslm*trois
STOP 'hydrol_init'
END IF
ALLOCATE (stmat(kjpindex,nslm,3),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in stmat allocation. We stop. We need kjpindex words = ',kjpindex*nslm*trois
STOP 'hydrol_init'
END IF
ALLOCATE (nroot(nvm, nstm, nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in nroot allocation. We stop. We need kjpindex words = ',nvm * nstm * nslm
STOP 'hydrol_init'
END IF
ALLOCATE (kfact_root(kjpindex, nslm, nstm), stat=ier)
IF (ier .NE. 0) THEN
WRITE (numout,*) 'error in kfact_root allocation, We stop. We need kjpindex words = ',kjpindex*nslm*nstm
STOP 'hydrol_init'
END IF
ALLOCATE (kfact(nslm, nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in kfact allocation. We stop. We need kjpindex words = ',nslm * nscm
STOP 'hydrol_init'
END IF
ALLOCATE (zz(nslm+1, nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in zz allocation. We stop. We need kjpindex words = ',(nslm+1) * nstm
STOP 'hydrol_init'
END IF
ALLOCATE (dz(nslm+1, nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in dz allocation. We stop. We need kjpindex words = ',(nslm+1) * nstm
STOP 'hydrol_init'
END IF
ALLOCATE (mc_lin(imin:imax, nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in mc_lin allocation. We stop. We need kjpindex words = ',(imax-imin) * nscm
STOP 'hydrol_init'
END IF
ALLOCATE (k_lin(imin:imax, nslm, nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in k_lin allocation. We stop. We need kjpindex words = ',(imax-imin) * nslm * nscm
STOP 'hydrol_init'
END IF
ALLOCATE (d_lin(imin:imax, nslm, nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in d_lin allocation. We stop. We need kjpindex words = ',(imax-imin) * nslm * nscm
STOP 'hydrol_init'
END IF
ALLOCATE (a_lin(imin:imax, nslm, nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in a_lin allocation. We stop. We need kjpindex words = ',(imax-imin) * nslm * nscm
STOP 'hydrol_init'
END IF
ALLOCATE (b_lin(imin:imax, nslm, nscm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in b_lin allocation. We stop. We need kjpindex words = ',(imax-imin) * nslm * nscm
STOP 'hydrol_init'
END IF
!
! If we check the water balance we need two more variables
!
IF ( check_waterbal ) THEN
ALLOCATE (tot_water_beg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_water_beg allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (tot_water_end(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_water_end allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (tot_flux(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_flux allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ENDIF
!
! If we use the almaoutputs we need a few more variables
! tdo - they could be allocated only if alma_output, but then they should also be computed only if alma_output
ALLOCATE (tot_watveg_beg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_watveg_beg allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (tot_watveg_end(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_watveg_end allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (tot_watsoil_beg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_watsoil_beg allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (tot_watsoil_end(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_watsoil_end allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (delsoilmoist(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in delsoilmoist allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (delintercept(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in delintercept. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (delswe(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in delswe. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
ENDIF
ALLOCATE (swi(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in swi. We stop. We need kjpindex words = ',kjpindex
STOP 'hydrol_init'
ENDIF
ALLOCATE (snow_beg(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_beg allocation. We stop. We need kjpindex words =',kjpindex
STOP 'hydrol_init'
END IF
ALLOCATE (snow_end(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_end allocation. We stop. We need kjpindex words =',kjpindex
STOP 'hydrol_init'
END IF
! open restart input file done by sechiba_init
! and read data from restart input file for HYDROLOGIC process
IF (ldrestart_read) THEN
IF (long_print) WRITE (numout,*) ' we have to read a restart file for HYDROLOGIC variables'
!
IF (is_root_prc) CALL ioconf_setatt('UNITS', '-')
!
DO jst=1,nstm
! var_name= "mc_1" ... "mc_3"
WRITE (var_name,"('moistc_',i1)") jst
IF (is_root_prc) CALL ioconf_setatt('LONG_NAME',var_name)
CALL restget_p (rest_id, var_name, nbp_glo, nslm , 1, kjit, .TRUE., mc(:,:,jst), "gather", nbp_glo, index_g)
END DO
!
IF (is_root_prc) CALL ioconf_setatt('UNITS', '-')
DO jst=1,nstm
DO jsl=1,nslm
! var_name= "us_1_01" ... "us_3_11"
WRITE (var_name,"('us_',i1,'_',i2.2)") jst,jsl
IF (is_root_prc) CALL ioconf_setatt('LONG_NAME',var_name)
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., us(:,:,jst,jsl), "gather", nbp_glo, index_g)
END DO
END DO
!
var_name= 'free_drain_coef'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Coefficient for free drainage at bottom of soil')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., free_drain_coef, "gather", nbp_glo, index_g)
!
var_name= 'water2infilt'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Remaining water to be infiltrated on top of the soil')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., water2infilt, "gather", nbp_glo, index_g)
!
var_name= 'ae_ns'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', 'kg/m^2')
CALL ioconf_setatt('LONG_NAME','Bare soil evap on each soil type')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., ae_ns, "gather", nbp_glo, index_g)
!
var_name= 'snow'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', 'kg/m^2')
CALL ioconf_setatt('LONG_NAME','Snow mass')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, 1 , 1, kjit, .TRUE., snow, "gather", nbp_glo, index_g)
!
var_name= 'snow_age'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', 'd')
CALL ioconf_setatt('LONG_NAME','Snow age')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, 1 , 1, kjit, .TRUE., snow_age, "gather", nbp_glo, index_g)
!
var_name= 'snow_nobio'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', 'kg/m^2')
CALL ioconf_setatt('LONG_NAME','Snow on other surface types')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, nnobio , 1, kjit, .TRUE., snow_nobio, "gather", nbp_glo, index_g)
!
var_name= 'snow_nobio_age'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', 'd')
CALL ioconf_setatt('LONG_NAME','Snow age on other surface types')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, nnobio , 1, kjit, .TRUE., snow_nobio_age, "gather", nbp_glo, index_g)
!
var_name= 'vegstress'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Vegetation growth moisture stress')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., vegstress, "gather", nbp_glo, index_g)
!
var_name= 'qsintveg'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', 'kg/m^2')
CALL ioconf_setatt('LONG_NAME','Intercepted moisture')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., qsintveg, "gather", nbp_glo, index_g)
!
var_name= 'resdist'
IF (is_root_prc) THEN
CALL ioconf_setatt('UNITS', '-')
CALL ioconf_setatt('LONG_NAME','Distribution of reservoirs')
ENDIF
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., resdist, "gather", nbp_glo, index_g)
!
IF (is_root_prc) CALL ioconf_setatt('UNITS', '-')
DO jst=1,nstm
! var_name= "cvs_over_veg_1" ... "cvs_over_veg_3"
WRITE (var_name,"('cvs_over_veg_',i1)") jst
IF (is_root_prc) CALL ioconf_setatt('LONG_NAME',var_name)
CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., cvs_over_veg(:,:,jst), "gather", nbp_glo, index_g)
END DO
!
!!$ IF (is_root_prc) CALL ioconf_setatt('UNITS', '-')
!!$ DO jst=1,nstm
!!$ ! var_name= "humrelv_1" ... "humrelv_3"
!!$ WRITE (var_name,"('humrelv_',i1)") jst
!!$ IF (is_root_prc) CALL ioconf_setatt('LONG_NAME',var_name)
!!$ CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., humrelv(:,:,jst), "gather", nbp_glo, index_g)
!!$ END DO
!
!
! get restart values if none were found in the restart file
!
!Config Key = HYDROL_MOISTURE_CONTENT
!Config Desc = Soil moisture on each soil tile and levels
!Config Def = 0.3
!Config Help = The initial value of mc if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (mc, val_exp, 'HYDROL_MOISTURE_CONTENT', 0.3_r_std)
!
!Config Key = US_INIT
!Config Desc = US_NVM_NSTM_NSLM
!Config Def = 0.0
!Config Help = The initial value of us if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
DO jsl=1,nslm
CALL setvar_p (us(:,:,:,jsl), val_exp, 'US_INIT', 0.0_r_std)
ENDDO
!
!Config Key = FREE_DRAIN_COEF
!Config Desc = Coefficient for free drainage at bottom
!Config Def = 1.0, 1.0, 1.0
!Config Help = The initial value of free drainage if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (free_drain_coef, val_exp, 'FREE_DRAIN_COEF', free_drain_max)
!
!Config Key = WATER_TO_INFILT
!Config Desc = Water to be infiltrated on top of the soil
!Config Def = 0.0
!Config Help = The initial value of free drainage if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (water2infilt, val_exp, 'WATER_TO_INFILT', 0.0_r_std)
!
!Config Key = EVAPNU_SOIL
!Config Desc = Bare soil evap on each soil if not found in restart
!Config Def = 0.0
!Config Help = The initial value of bare soils evap if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (ae_ns, val_exp, 'EVAPNU_SOIL', 0.0_r_std)
!
!Config Key = HYDROL_SNOW
!Config Desc = Initial snow mass if not found in restart
!Config Def = 0.0
!Config Help = The initial value of snow mass if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', 0.0_r_std)
!
!Config Key = HYDROL_SNOWAGE
!Config Desc = Initial snow age if not found in restart
!Config Def = 0.0
!Config Help = The initial value of snow age if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (snow_age, val_exp, 'HYDROL_SNOWAGE', 0.0_r_std)
!
!Config Key = HYDROL_SNOW_NOBIO
!Config Desc = Initial snow amount on ice, lakes, etc. if not found in restart
!Config Def = 0.0
!Config Help = The initial value of snow if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (snow_nobio, val_exp, 'HYDROL_SNOW_NOBIO', 0.0_r_std)
!
!Config Key = HYDROL_SNOW_NOBIO_AGE
!Config Desc = Initial snow age on ice, lakes, etc. if not found in restart
!Config Def = 0.0
!Config Help = The initial value of snow age if its value is not found
!Config in the restart file. This should only be used if the model is
!Config started without a restart file.
!
CALL setvar_p (snow_nobio_age, val_exp, 'HYDROL_SNOW_NOBIO_AGE', 0.0_r_std)
!
!Config Key = HYDROL_QSV
!Config Desc = Initial water on canopy if not found in restart
!Config Def = 0.0
!Config Help = The initial value of moisture on canopy if its value
!Config is not found in the restart file. This should only be used if
!Config the model is started without a restart file.
!
CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', 0.0_r_std)
!
! There is no need to configure the initialisation of resdist. If not available it is the vegetation map
!
IF ( MINVAL(resdist) .EQ. MAXVAL(resdist) .AND. MINVAL(resdist) .EQ. val_exp) THEN
resdist = veget
ENDIF
!
! Remember that it is only frac_nobio + SUM(veget(,:)) that is equal to 1. Thus we need vegtot
!
DO ji = 1, kjpindex
vegtot(ji) = SUM(veget(ji,:))
ENDDO
!
!
! compute the masks for veget
mask_veget(:,:) = 0
mask_soiltile(:,:) = 0
DO jst=1,nstm
DO ji= 1, kjpindex
IF(soiltile(ji,jst) .GT. min_sechiba) THEN
mask_soiltile(ji,jst) = 1
ENDIF
ENDDO
ENDDO
DO jv = 1, nvm
DO ji = 1, kjpindex
IF(veget(ji,jv) .GT. min_sechiba) THEN
mask_veget(ji,jv) = 1
ENDIF
END DO
END DO
! set humrelv from us
humrelv(:,:,:) = SUM(us,dim=4)
! humrelv_temp(:,:,:) = SUM(us,dim=4)
! CALL setvar_p (humrelv, val_exp, 'NO_KEYWORD', humrelv_temp)
vegstressv(:,:,:) = humrelv(:,:,:)
! set humrel from humrelv, assuming equi-repartition for the first time step
humrel(:,:) = zero
CALL setvar_p (cvs_over_veg, val_exp, 'NO_KEYWORD', un)
DO jst=1,nstm
DO jv=1,nvm
DO ji=1,kjpindex
vegstress(ji,jv)=vegstress(ji,jv) + vegstressv(ji,jv,jst) * soiltile(ji,jst)
humrel(ji,jv)=humrel(ji,jv) + humrelv(ji,jv,jst) * &
& soiltile(ji,jst) &
& * cvs_over_veg(ji,jv,jst)*vegtot(ji)
humrel(ji,jv)=MAX(humrel(ji,jv), zero)* mask_veget(ji,jv)
END DO
END DO
END DO
ENDIF
!
!
IF (long_print) WRITE (numout,*) ' hydrol_init done '
!
END SUBROUTINE hydrol_init
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
SUBROUTINE hydrol_clear()
l_first_hydrol=.TRUE.
! Allocation for soiltile related parameters
IF ( ALLOCATED (nvan)) DEALLOCATE (nvan)
IF ( ALLOCATED (avan)) DEALLOCATE (avan)
IF ( ALLOCATED (mcr)) DEALLOCATE (mcr)
IF ( ALLOCATED (mcs)) DEALLOCATE (mcs)
IF ( ALLOCATED (ks)) DEALLOCATE (ks)
IF ( ALLOCATED (ds)) DEALLOCATE (ds)
IF ( ALLOCATED (pcent)) DEALLOCATE (pcent)
IF ( ALLOCATED (free_drain_max)) DEALLOCATE (free_drain_max)
IF ( ALLOCATED (mcf)) DEALLOCATE (mcf)
IF ( ALLOCATED (mcw)) DEALLOCATE (mcw)
IF ( ALLOCATED (mc_awet)) DEALLOCATE (mc_awet)
IF ( ALLOCATED (mc_adry)) DEALLOCATE (mc_adry)
IF ( ALLOCATED (psis)) DEALLOCATE (psis)
! Other arrays
IF (ALLOCATED (mask_veget)) DEALLOCATE (mask_veget)
IF (ALLOCATED (mask_soiltile)) DEALLOCATE (mask_soiltile)
IF (ALLOCATED (humrelv)) DEALLOCATE (humrelv)
IF (ALLOCATED (vegstressv)) DEALLOCATE (vegstressv)
IF (ALLOCATED (us)) DEALLOCATE (us)
IF (ALLOCATED (precisol)) DEALLOCATE (precisol)
IF (ALLOCATED (precisol_ns)) DEALLOCATE (precisol_ns)
IF (ALLOCATED (free_drain_coef)) DEALLOCATE (free_drain_coef)
IF (ALLOCATED (frac_bare_ns)) DEALLOCATE (frac_bare_ns)
IF (ALLOCATED (tot_frac_bare)) DEALLOCATE (tot_frac_bare)
IF (ALLOCATED (water2infilt)) DEALLOCATE (water2infilt)
IF (ALLOCATED (ae_ns)) DEALLOCATE (ae_ns)
IF (ALLOCATED (evap_bare_lim_ns)) DEALLOCATE (evap_bare_lim_ns)
IF (ALLOCATED (rootsink)) DEALLOCATE (rootsink)
IF (ALLOCATED (subsnowveg)) DEALLOCATE (subsnowveg)
IF (ALLOCATED (subsnownobio)) DEALLOCATE (subsnownobio)
IF (ALLOCATED (snowmelt)) DEALLOCATE (snowmelt)
IF (ALLOCATED (icemelt)) DEALLOCATE (icemelt)
IF (ALLOCATED (subsinksoil)) DEALLOCATE (subsinksoil)
IF (ALLOCATED (mx_eau_var)) DEALLOCATE (mx_eau_var)
IF (ALLOCATED (vegtot)) DEALLOCATE (vegtot)
IF (ALLOCATED (resdist)) DEALLOCATE (resdist)
IF (ALLOCATED (tot_water_beg)) DEALLOCATE (tot_water_beg)
IF (ALLOCATED (tot_water_end)) DEALLOCATE (tot_water_end)
IF (ALLOCATED (tot_flux)) DEALLOCATE (tot_flux)
IF (ALLOCATED (tot_watveg_beg)) DEALLOCATE (tot_watveg_beg)
IF (ALLOCATED (tot_watveg_end)) DEALLOCATE (tot_watveg_end)
IF (ALLOCATED (tot_watsoil_beg)) DEALLOCATE (tot_watsoil_beg)
IF (ALLOCATED (tot_watsoil_end)) DEALLOCATE (tot_watsoil_end)
IF (ALLOCATED (delsoilmoist)) DEALLOCATE (delsoilmoist)
IF (ALLOCATED (delintercept)) DEALLOCATE (delintercept)
IF (ALLOCATED (snow_beg)) DEALLOCATE (snow_beg)
IF (ALLOCATED (snow_end)) DEALLOCATE (snow_end)
IF (ALLOCATED (delswe)) DEALLOCATE (delswe)
IF (ALLOCATED (swi)) DEALLOCATE (swi)
! more allocation for cwrr scheme
IF (ALLOCATED (v1)) DEALLOCATE (v1)
! IF (ALLOCATED (vB)) DEALLOCATE (vB)
IF (ALLOCATED (humtot)) DEALLOCATE (humtot)
IF (ALLOCATED (flux)) DEALLOCATE (flux)
IF (ALLOCATED (resolv)) DEALLOCATE (resolv)
IF (ALLOCATED (k)) DEALLOCATE (k)
IF (ALLOCATED (a)) DEALLOCATE (a)
IF (ALLOCATED (b)) DEALLOCATE (b)
IF (ALLOCATED (d)) DEALLOCATE (d)
IF (ALLOCATED (e)) DEALLOCATE (e)
IF (ALLOCATED (f)) DEALLOCATE (f)
IF (ALLOCATED (g1)) DEALLOCATE (g1)
IF (ALLOCATED (ep)) DEALLOCATE (ep)
IF (ALLOCATED (fp)) DEALLOCATE (fp)
IF (ALLOCATED (gp)) DEALLOCATE (gp)
IF (ALLOCATED (rhs)) DEALLOCATE (rhs)
IF (ALLOCATED (srhs)) DEALLOCATE (srhs)
IF (ALLOCATED (gam)) DEALLOCATE (gam)
IF (ALLOCATED (tmc)) DEALLOCATE (tmc)
IF (ALLOCATED (tmcs)) DEALLOCATE (tmcs)
IF (ALLOCATED (tmcr)) DEALLOCATE (tmcr)
IF (ALLOCATED (tmc_litter)) DEALLOCATE (tmc_litter)
IF (ALLOCATED (tmc_litt_mea)) DEALLOCATE (tmc_litt_mea)
IF (ALLOCATED (tmc_litter_res)) DEALLOCATE (tmc_litter_res)
IF (ALLOCATED (tmc_litter_wilt)) DEALLOCATE (tmc_litter_wilt)
IF (ALLOCATED (tmc_litter_field)) DEALLOCATE (tmc_litter_field)
IF (ALLOCATED (tmc_litter_sat)) DEALLOCATE (tmc_litter_sat)
IF (ALLOCATED (tmc_litter_awet)) DEALLOCATE (tmc_litter_awet)
IF (ALLOCATED (tmc_litter_adry)) DEALLOCATE (tmc_litter_adry)
IF (ALLOCATED (tmc_litt_wet_mea)) DEALLOCATE (tmc_litt_wet_mea)
IF (ALLOCATED (tmc_litt_dry_mea)) DEALLOCATE (tmc_litt_dry_mea)
IF (ALLOCATED (qflux00)) DEALLOCATE (qflux00)
IF (ALLOCATED (ru_ns)) DEALLOCATE (ru_ns)
IF (ALLOCATED (dr_ns)) DEALLOCATE (dr_ns)
IF (ALLOCATED (tr_ns)) DEALLOCATE (tr_ns)
IF (ALLOCATED (cvs_over_veg)) DEALLOCATE (cvs_over_veg)
IF (ALLOCATED (corr_veg_soil)) DEALLOCATE (corr_veg_soil)
IF (ALLOCATED (mc)) DEALLOCATE (mc)
IF (ALLOCATED (soilmoist)) DEALLOCATE (soilmoist)
IF (ALLOCATED (soil_wet)) DEALLOCATE (soil_wet)
IF (ALLOCATED (soil_wet_litter)) DEALLOCATE (soil_wet_litter)
IF (ALLOCATED (qflux)) DEALLOCATE (qflux)
IF (ALLOCATED (tmat)) DEALLOCATE (tmat)
IF (ALLOCATED (stmat)) DEALLOCATE (stmat)
IF (ALLOCATED (nroot)) DEALLOCATE (nroot)
IF (ALLOCATED (kfact_root)) DEALLOCATE (kfact_root)
IF (ALLOCATED (kfact)) DEALLOCATE (kfact)
IF (ALLOCATED (zz)) DEALLOCATE (zz)
IF (ALLOCATED (dz)) DEALLOCATE (dz)
IF (ALLOCATED (mc_lin)) DEALLOCATE (mc_lin)
IF (ALLOCATED (k_lin)) DEALLOCATE (k_lin)
IF (ALLOCATED (d_lin)) DEALLOCATE (d_lin)
IF (ALLOCATED (a_lin)) DEALLOCATE (a_lin)
IF (ALLOCATED (b_lin)) DEALLOCATE (b_lin)
RETURN
END SUBROUTINE hydrol_clear
!! This routine initializes HYDROLOGIC variables
!! - mx_eau_var
SUBROUTINE hydrol_var_init (kjpindex, veget, soiltile, njsc, mx_eau_var, shumdiag, k_litt, &
& litterhumdiag, drysoil_frac, evap_bare_lim)
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! domain size
! input fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! fraction of vegetation type
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: njsc !! Indeces of the soiltype
REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile !! Map of soil types
! modified fields
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: mx_eau_var !!
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out) :: shumdiag !! relative soil moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: k_litt !! litter cond.
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: litterhumdiag !! litter humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: drysoil_frac !! function of litter humidity
REAL(r_std),DIMENSION (kjpindex), INTENT(out) :: evap_bare_lim !!
! local declaration
INTEGER(i_std) :: ji, jv, jd, jst, jsc, jsl, ji_soil, i
REAL(r_std) :: m, frac
REAL(r_std) :: avan_mod, nvan_mod !! modified VG parameters with exponantial profile
REAL(r_std), DIMENSION(nslm,nscm) :: afact, nfact !! multiplicative factor for decay of a and n
! parameters for "soil densification" with depth
REAL(r_std) :: dp_comp !! depth at which the 'compacted value' (Van Genuchten) of ksat is reached
REAL(r_std) :: f_ks !! exponential factor for decay of ksat with depth
! Fixed parameters from fitted relationships
REAL(r_std), PARAMETER :: n0 = 0.95 !! fitted value for relation log((n-n0)/(n_ref-n0)) = nk_rel * log(k/k_ref)
REAL(r_std), PARAMETER :: nk_rel = 0.34 !! fitted value for relation log((n-n0)/(n_ref-n0)) = nk_rel * log(k/k_ref)
REAL(r_std), PARAMETER :: a0 = 0.00012 !! fitted value for relation log((a-a0)/(a_ref-a0)) = ak_rel * log(k/k_ref)
REAL(r_std), PARAMETER :: ak_rel = 0.53 !! fitted value for relation log((a-a0)/(a_ref-a0)) = ak_rel * log(k/k_ref)
REAL(r_std) :: kfact_max !! Maximum factor for K due to depth
!
!
! Calcul the matrix coef for dublin model:
! pice-wise linearised hydraulic conductivity k_lin=alin * mc_lin + b_lin
! and diffusivity d_lin in each interval of mc, called mc_lin,
! between imin, for residual mcr,
! and imax for saturation mcs.
!
!Config Key = MAXK_PARAM
!Config Desc = Maximum Factor for Ks increase due to vegetation
!Config Def = 10.0
!Config Help =
!
kfact_max = 10.0
CALL getin_p ('MAXK_PARAM', kfact_max)
!
!Config Key = KPROF_PARAM
!Config Desc = Factor for Ks decay with depth
!Config Def = 2.0
!Config Help =
!
f_ks = deux
CALL getin_p ('KPROF_PARAM', f_ks)
!
!Config Key = KDEPTH_PARAM
!Config Desc = Depth for compacted value of Ks
!Config Def = 0.3
!Config Help =
!
dp_comp = 0.3
CALL getin_p ('KDEPTH_PARAM', dp_comp)
!
!
DO jst=1,nstm
!-
!- 1. compute the depths
!-
zz(1,jst) = zero
dz(1,jst) = zero
DO jsl=2,nslm
zz(jsl,jst) = dpu_max* mille*((2**(jsl-1))-1)/ ((2**(nslm-1))-1)
dz(jsl,jst) = zz(jsl,jst)-zz(jsl-1,jst)
ENDDO
zz(nslm+1,jst) = zz(nslm,jst)
dz(nslm+1,jst) = zero
!-
!- 3. compute the profile for roots
!-
DO jv = 1,nvm
DO jsl = 2, nslm-1
nroot(jv,jst,jsl) = (EXP(-humcste(jv)*zz(jsl,jst)/mille)) * &
& (EXP(humcste(jv)*dz(jsl,jst)/mille/deux) - &
& EXP(-humcste(jv)*dz(jsl+1,jst)/mille/deux))/ &
& (EXP(-humcste(jv)*dz(2,jst)/mille/deux) &
& -EXP(-humcste(jv)*zz(nslm,jst)/mille))
ENDDO
ENDDO
DO jv=1,nvm
nroot(jv,jst,1) = zero
nroot(jv,jst,nslm) = (EXP(humcste(jv)*dz(nslm,jst)/mille/deux) -un) * &
& EXP(-humcste(jv)*zz(nslm,jst)/mille) / &
& (EXP(-humcste(jv)*dz(2,jst)/mille/deux) &
& -EXP(-humcste(jv)*zz(nslm,jst)/mille))
ENDDO
! An additional exponential factor for ks depending on the amount of roots in the soil
! through a geometric average over the vegets
kfact_root(:,:,jst) = un
DO jsl = 1, nslm
DO jv = 2, nvm
DO ji = 1, kjpindex
kfact_root(ji,jsl,jst) = kfact_root(ji,jsl,jst) * &
& MAX((MAXVAL(ks_usda)/ks(njsc(ji)))**(- veget(ji,jv) * (humcste(jv)*zz(jsl,jst)/mille - un)/deux), un)
ENDDO
ENDDO
ENDDO
ENDDO
!-
!- 4. Compute the profile for ksat, a and n
!-
! This is used for FAO2 map (with soil type 2 and 4 being heterogeneous with depth)
IF (nscm .EQ. 5) THEN
! For every soil texture
DO jsc = 1, nscm
DO jsl=1,nslm
frac = MAX(zero, MIN(un, f_ks * (zz(jsl,jsc)/mille - dp_comp)))
kfact(jsl,jsc) = ( ks(MIN(nscm,jsc+1))/ks(jsc) )**frac
nfact(jsl,jsc) = ( (nvan(MIN(nscm,jsc+1))-n0)/(nvan(jsc)-n0) )**frac
afact(jsl,jsc) = ( (avan(MIN(nscm,jsc+1))-a0)/(avan(jsc)-a0) )**frac
ENDDO
ENDDO
! And this is to put a global soiltype profile
ELSE
! For every soil texture
DO jsc = 1, nscm
DO jsl=1,nslm
kfact(jsl,jsc) = MIN(MAX(EXP(- f_ks * (zz(jsl,jsc)/mille - dp_comp)), un/kfact_max),un)
nfact(jsl,jsc) = ( kfact(jsl,jsc) )**nk_rel
afact(jsl,jsc) = ( kfact(jsl,jsc) )**ak_rel
ENDDO
ENDDO
ENDIF
! For every soil texture
DO jsc = 1, nscm
!-
!- 5. compute the linearized values of k, a, b and d
!-
mc_lin(imin,jsc)=mcr(jsc)
mc_lin(imax,jsc)=mcs(jsc)
DO ji= imin+1, imax-1
mc_lin(ji,jsc) = mcr(jsc) + (ji-imin)*(mcs(jsc)-mcr(jsc))/(imax-imin)
ENDDO
DO jsl = 1, nslm
nvan_mod = n0 + (nvan(jsc)-n0) * nfact(jsl,jsc)
avan_mod = a0 + (avan(jsc)-a0) * afact(jsl,jsc)
m = un - un / nvan_mod
! Perhaps we may have problems with precision here for some machines (k being very small for ji=imin+1
! How can we handle it?
DO ji = imax,imin+1,-1
frac=MIN(un,(mc_lin(ji,jsc)-mcr(jsc))/(mcs(jsc)-mcr(jsc)))
k_lin(ji,jsl,jsc) = ks(jsc) * kfact(jsl,jsc) * (frac**0.5) * ( un - ( un - frac ** (un/m)) ** m )**2
ENDDO
! We have to avoid k=0
k_lin(imin,jsl,jsc) = k_lin(imin+1,jsl,jsc)/mille
DO ji = imin, imax-1
a_lin(ji,jsl,jsc) = (k_lin(ji+1,jsl,jsc)-k_lin(ji,jsl,jsc)) / (mc_lin(ji+1,jsc)-mc_lin(ji,jsc))
b_lin(ji,jsl,jsc) = k_lin(ji,jsl,jsc) - a_lin(ji,jsl,jsc)*mc_lin(ji,jsc)
IF(ji.NE.imin.AND.ji.NE.imax-1) THEN
frac=MIN(un,(mc_lin(ji,jsc)-mcr(jsc))/(mcs(jsc)-mcr(jsc)))
d_lin(ji,jsl,jsc) =(k_lin(ji,jsl,jsc) / (avan_mod*m*nvan_mod)) * &
& ( (frac**(-un/m))/(mc_lin(ji,jsc)-mcr(jsc)) ) * &
& ( frac**(-un/m) -un ) ** (-m)
frac=MIN(un,(mc_lin(ji+1,jsc)-mcr(jsc))/(mcs(jsc)-mcr(jsc)))
d_lin(ji+1,jsl,jsc) =(k_lin(ji+1,jsl,jsc) / (avan_mod*m*nvan_mod))*&
& ( (frac**(-un/m))/(mc_lin(ji+1,jsc)-mcr(jsc)) ) * &
& ( frac**(-un/m) -un ) ** (-m)
d_lin(ji,jsl,jsc) = undemi * (d_lin(ji,jsl,jsc)+d_lin(ji+1,jsl,jsc))
ELSEIF(ji.EQ.imin) THEN
d_lin(ji,jsl,jsc) = zero
ELSEIF(ji.EQ.imax-1) THEN
frac=MIN(un,(mc_lin(ji,jsc)-mcr(jsc))/(mcs(jsc)-mcr(jsc)))
d_lin(ji,jsl,jsc) =(k_lin(ji,jsl,jsc) / (avan_mod*m*nvan_mod)) * &
& ( (frac**(-un/m))/(mc_lin(ji,jsc)-mcr(jsc)) ) * &
& ( frac**(-un/m) -un ) ** (-m)
ds(jsl,jsc) = d_lin(ji,jsl,jsc)
ENDIF
ENDDO
ENDDO
ENDDO
! initialisation
mx_eau_var(:) = zero
!
DO jst = 1,nstm
DO ji = 1, kjpindex
mx_eau_var(ji) = mx_eau_var(ji) + soiltile(ji,jst)*&
& dpu_max*mille*mcs(njsc(ji))
END DO
END DO
DO ji = 1,kjpindex
IF (vegtot(ji) .LE. zero) THEN
mx_eau_var(ji) = mx_eau_eau*deux
ENDIF
END DO
! Compute the litter humidity, shumdiag and fry
litterhumdiag(:) = zero
k_litt(:) = zero
tmc_litt_mea(:) = zero
tmc_litt_wet_mea(:) = zero
tmc_litt_dry_mea(:) = zero
shumdiag(:,:) = zero
soilmoist(:,:) = zero
humtot(:) = zero
tmc(:,:) = zero
swi(:) = zero
! Loop on soil types to compute the variables (ji,jst)
DO jst=1,nstm
DO ji = 1, kjpindex
tmcs(ji,jst)=dpu_max* mille*mcs(njsc(ji))
tmcr(ji,jst)=dpu_max* mille*mcr(njsc(ji))
ENDDO
ENDDO
! The total soil moisture for each soil type:
DO jst=1,nstm
DO ji = 1, kjpindex
tmc(ji,jst)= dz(2,jst) * ( trois*mc(ji,1,jst)+ mc(ji,2,jst))/huit
ENDDO
ENDDO
DO jst=1,nstm
DO jsl=2,nslm-1
DO ji = 1, kjpindex
tmc(ji,jst) = tmc(ji,jst) + dz(jsl,jst) * ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
& + dz(jsl+1,jst)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
ENDDO
END DO
ENDDO
DO jst=1,nstm
DO ji = 1, kjpindex
tmc(ji,jst) = tmc(ji,jst) + dz(nslm,jst) * (trois * mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
tmc(ji,jst) = tmc(ji,jst) + water2infilt(ji,jst)
ENDDO
ENDDO
! The litter variables:
DO jst=1,nstm
DO ji = 1, kjpindex
tmc_litter(ji,jst) = dz(2,jst) * (trois*mc(ji,1,jst)+mc(ji,2,jst))/huit
tmc_litter_wilt(ji,jst) = dz(2,jst) * mcw(njsc(ji)) / deux
tmc_litter_res(ji,jst) = dz(2,jst) * mcr(njsc(ji)) / deux
tmc_litter_field(ji,jst) = dz(2,jst) * mcf(njsc(ji)) / deux
tmc_litter_sat(ji,jst) = dz(2,jst) * mcs(njsc(ji)) / deux
tmc_litter_awet(ji,jst) = dz(2,jst) * mc_awet(njsc(ji)) / deux
tmc_litter_adry(ji,jst) = dz(2,jst) * mc_adry(njsc(ji)) / deux
ENDDO
ENDDO
! sum from level 1 to 4
DO jst=1,nstm
DO jsl=2,4
DO ji = 1, kjpindex
tmc_litter(ji,jst) = tmc_litter(ji,jst) + dz(jsl,jst) * &
& ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
& + dz(jsl+1,jst)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
tmc_litter_wilt(ji,jst) = tmc_litter_wilt(ji,jst) + &
&(dz(jsl,jst)+ dz(jsl+1,jst))*&
& mcw(njsc(ji))/deux
tmc_litter_res(ji,jst) = tmc_litter_res(ji,jst) + &
&(dz(jsl,jst)+ dz(jsl+1,jst))*&
& mcr(njsc(ji))/deux
tmc_litter_sat(ji,jst) = tmc_litter_sat(ji,jst) + &
&(dz(jsl,jst)+ dz(jsl+1,jst))* &
& mcs(njsc(ji))/deux
tmc_litter_field(ji,jst) = tmc_litter_field(ji,jst) + &
& (dz(jsl,jst)+ dz(jsl+1,jst))* &
& mcf(njsc(ji))/deux
tmc_litter_awet(ji,jst) = tmc_litter_awet(ji,jst) + &
&(dz(jsl,jst)+ dz(jsl+1,jst))* &
& mc_awet(njsc(ji))/deux
tmc_litter_adry(ji,jst) = tmc_litter_adry(ji,jst) + &
& (dz(jsl,jst)+ dz(jsl+1,jst))* &
& mc_adry(njsc(ji))/deux
END DO
ENDDO
ENDDO
! subsequent calcul of soil_wet_litter (tmc-tmcw)/(tmcf-tmcw)
DO jst=1,nstm
DO ji = 1, kjpindex
soil_wet_litter(ji,jst)=MIN(un, MAX(zero,&
&(tmc_litter(ji,jst)-tmc_litter_wilt(ji,jst))/&
& (tmc_litter_field(ji,jst)-tmc_litter_wilt(ji,jst)) ))
ENDDO
ENDDO
! subsequent calcul of soil_wet_litter (tmc-tmcw)/(tmcf-tmcw)
! Soil wetness profiles (mc-mcw)/(mcs-mcw)
DO jst=1,nstm
DO ji = 1, kjpindex
soil_wet(ji,1,jst) = MIN(un, MAX(zero,&
&(trois*mc(ji,1,jst) + mc(ji,2,jst) - quatre*mcw(njsc(ji)))&
& /(quatre*(mcs(njsc(ji))-mcw(njsc(ji)))) ))
humrelv(ji,1,jst) = zero
ENDDO
ENDDO
DO jst=1,nstm
DO jsl=2,nslm-1
DO ji = 1, kjpindex
soil_wet(ji,jsl,jst) = MIN(un, MAX(zero,&
& (trois*mc(ji,jsl,jst) + &
& mc(ji,jsl-1,jst) *(dz(jsl,jst)/(dz(jsl,jst)+dz(jsl+1,jst))) &
& + mc(ji,jsl+1,jst)*(dz(jsl+1,jst)/(dz(jsl,jst)+dz(jsl+1,jst))) &
& - quatre*mcw(njsc(ji))) / (quatre*(mcs(njsc(ji))-mcw(njsc(ji)))) ))
END DO
ENDDO
ENDDO
DO jst=1,nstm
DO ji = 1, kjpindex
soil_wet(ji,nslm,jst) = MIN(un, MAX(zero,&
& (trois*mc(ji,nslm,jst) &
& + mc(ji,nslm-1,jst)-quatre*mcw(njsc(ji)))/(quatre*(mcs(njsc(ji))-mcw(njsc(ji)))) ))
ENDDO
ENDDO
!Now we compute the grid averaged values
DO jst=1,nstm
DO ji = 1, kjpindex
i= MAX(MIN(INT((imax-imin)*(tmc_litter(ji,jst)-tmc_litter_res(ji,jst))&
& / (tmc_litter_sat(ji,jst)-tmc_litter_res(ji,jst)))+imin , imax-1), imin)
! k_litt is an averaged conductivity for saturated infiltration in the 'litter' layer
! This is used for reinfiltration from surface water
k_litt(ji) = k_litt(ji) + soiltile(ji,jst) * SQRT(k_lin(i,1,njsc(ji))*ks(njsc(ji)))
ENDDO
ENDDO
DO jst=1,nstm
DO ji = 1, kjpindex
humtot(ji) = humtot(ji) + soiltile(ji,jst) * tmc(ji,jst)
litterhumdiag(ji) = litterhumdiag(ji) + &
& soil_wet_litter(ji,jst) * soiltile(ji,jst)
tmc_litt_wet_mea(ji) = tmc_litt_wet_mea(ji) + &
& tmc_litter_awet(ji,jst)* soiltile(ji,jst)
tmc_litt_dry_mea(ji) = tmc_litt_dry_mea(ji) + &
& tmc_litter_adry(ji,jst) * soiltile(ji,jst)
tmc_litt_mea(ji) = tmc_litt_mea(ji) + &
& tmc_litter(ji,jst) * soiltile(ji,jst)
ENDDO
ENDDO
DO jst=1,nstm
DO jsl=1,nbdl
DO ji = 1, kjpindex
shumdiag(ji,jsl)= shumdiag(ji,jsl) + soil_wet(ji,jsl,jst) * &
& ((mcs(njsc(ji))-mcw(njsc(ji)))/(mcf(njsc(ji))-mcw(njsc(ji)))) * &
& soiltile(ji,jst)
soilmoist(ji,jsl) = soilmoist(ji,jsl) + mc(ji,jsl,jst)*soiltile(ji,jst)
shumdiag(ji,jsl) = MAX(MIN(shumdiag(ji,jsl), un), zero)
END DO
END DO
END DO ! loop on soiltile
!
!
!
DO ji=1,kjpindex
drysoil_frac(ji) = un + MAX( MIN( (tmc_litt_dry_mea(ji) - tmc_litt_mea(ji)) / &
& (tmc_litt_wet_mea(ji) - tmc_litt_dry_mea(ji)), zero), - un)
END DO
evap_bare_lim = zero
IF (long_print) WRITE (numout,*) ' hydrol_var_init done '
END SUBROUTINE hydrol_var_init
!! This routine computes snow processes
!!
SUBROUTINE hydrol_snow (kjpindex, dtradia, precip_rain, precip_snow , temp_sol_new, soilcap,&
& frac_nobio, totfrac_nobio, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
& tot_melt, snowdepth)
!
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: precip_rain !! Rainfall
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: precip_snow !! Snow precipitation
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: temp_sol_new !! New soil temperature
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: soilcap !! Soil capacity
REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio !! Fraction of continental ice, lakes, ...
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: totfrac_nobio !! Total fraction of continental ice+lakes+ ...
! modified fields
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: vevapnu !! Bare soil evaporation
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: vevapsno !! Snow evaporation
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: snow !! Snow mass [Kg/m^2]
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: snow_age !! Snow age
REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout) :: snow_nobio !! Ice water balance
REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout) :: snow_nobio_age!! Snow age on ice, lakes, ...
! output fields
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: tot_melt !! Total melt
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: snowdepth !! Snow depth
!
! local declaration
!
INTEGER(i_std) :: ji, jv
REAL(r_std), DIMENSION (kjpindex) :: d_age !! Snow age change
REAL(r_std), DIMENSION (kjpindex) :: xx !! temporary
REAL(r_std) :: snowmelt_tmp !! The name says it all !
!
! for continental points
!
!
! 0. initialisation
!
DO jv = 1, nnobio
DO ji=1,kjpindex
subsnownobio(ji,jv) = zero
ENDDO
ENDDO
DO ji=1,kjpindex
subsnowveg(ji) = zero
snowmelt(ji) = zero
icemelt(ji) = zero
subsinksoil(ji) = zero
tot_melt(ji) = zero
ENDDO
!
! 1. On vegetation
!
DO ji=1,kjpindex
!
! 1.1. It is snowing
!
snow(ji) = snow(ji) + (un - totfrac_nobio(ji))*precip_snow(ji)
!
!
! 1.2. Sublimation - separate between vegetated and no-veget fractions
! Care has to be taken as we might have sublimation from the
! the frac_nobio while there is no snow on the rest of the grid.
!
IF ( snow(ji) > snowcri ) THEN
subsnownobio(ji,iice) = frac_nobio(ji,iice)*vevapsno(ji)
subsnowveg(ji) = vevapsno(ji) - subsnownobio(ji,iice)
ELSE
! Correction Nathalie - Juillet 2006.
! On doit d'abord tester s'il existe un frac_nobio!
! Pour le moment je ne regarde que le iice
IF ( frac_nobio(ji,iice) .GT. min_sechiba) THEN
subsnownobio(ji,iice) = vevapsno(ji)
subsnowveg(ji) = zero
ELSE
subsnownobio(ji,iice) = zero
subsnowveg(ji) = vevapsno(ji)
ENDIF
ENDIF
!
!
! 1.2.1 Check that sublimation on the vegetated fraction is possible.
!
IF (subsnowveg(ji) .GT. snow(ji)) THEN
! What could not be sublimated goes into soil evaporation
! vevapnu(ji) = vevapnu(ji) + (subsnowveg(ji) - snow(ji))
IF( (un - totfrac_nobio(ji)).GT.min_sechiba) THEN
subsinksoil (ji) = (subsnowveg(ji) - snow(ji))/ (un - totfrac_nobio(ji))
END IF
! Sublimation is thus limited to what is available
subsnowveg(ji) = snow(ji)
snow(ji) = zero
vevapsno(ji) = subsnowveg(ji) + subsnownobio(ji,iice)
ELSE
snow(ji) = snow(ji) - subsnowveg(ji)
ENDIF
!
! 1.3. snow melt only if temperature positive
!
IF (temp_sol_new(ji).GT.tp_00) THEN
!
IF (snow(ji).GT.sneige) THEN
!
snowmelt(ji) = (1. - frac_nobio(ji,iice))*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0
!
! 1.3.1.1 enough snow for melting or not
!
IF (snowmelt(ji).LT.snow(ji)) THEN
snow(ji) = snow(ji) - snowmelt(ji)
ELSE
snowmelt(ji) = snow(ji)
snow(ji) = zero
END IF
!
ELSEIF (snow(ji).GE.zero) THEN
!
! 1.3.2 not enough snow
!
snowmelt(ji) = snow(ji)
snow(ji) = zero
ELSE
!
! 1.3.3 negative snow - now snow melt
!
snow(ji) = zero
snowmelt(ji) = zero
WRITE(numout,*) 'hydrol_snow: WARNING! snow was negative and was reset to zero. '
!
END IF
ENDIF
!
! 1.4. Ice melt only if there is more than a given mass : maxmass_glacier,
! i.e. only weight melts glaciers !
! Ajouts Edouard Davin / Nathalie de Noblet add extra to melting
!
IF ( snow(ji) .GT. maxmass_glacier ) THEN
snowmelt(ji) = snowmelt(ji) + (snow(ji) - maxmass_glacier)
snow(ji) = maxmass_glacier
ENDIF
!
END DO
!
! 2. On Land ice
!
DO ji=1,kjpindex
!
! 2.1. It is snowing
!
snow_nobio(ji,iice) = snow_nobio(ji,iice) + frac_nobio(ji,iice)*precip_snow(ji) + &
& frac_nobio(ji,iice)*precip_rain(ji)
!
! 2.2. Sublimation - was calculated before it can give us negative snow_nobio but that is OK
! Once it goes below a certain values (-maxmass_glacier for instance) we should kill
! the frac_nobio(ji,iice) !
!
snow_nobio(ji,iice) = snow_nobio(ji,iice) - subsnownobio(ji,iice)
!
! 2.3. Snow melt only for continental ice fraction
!
snowmelt_tmp = zero
IF (temp_sol_new(ji) .GT. tp_00) THEN
!
! 2.3.1 If there is snow on the ice-fraction it can melt
!
snowmelt_tmp = frac_nobio(ji,iice)*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0
!
IF ( snowmelt_tmp .GT. snow_nobio(ji,iice) ) THEN
snowmelt_tmp = MAX( zero, snow_nobio(ji,iice))
ENDIF
snowmelt(ji) = snowmelt(ji) + snowmelt_tmp
snow_nobio(ji,iice) = snow_nobio(ji,iice) - snowmelt_tmp
!
ENDIF
!
! 2.4 Ice melt only if there is more than a given mass : maxmass_glacier,
! i.e. only weight melts glaciers !
!
IF ( snow_nobio(ji,iice) .GT. maxmass_glacier ) THEN
icemelt(ji) = snow_nobio(ji,iice) - maxmass_glacier
snow_nobio(ji,iice) = maxmass_glacier
ENDIF
!
END DO
!
! 3. On other surface types - not done yet
!
IF ( nnobio .GT. 1 ) THEN
WRITE(numout,*) 'WE HAVE',nnobio-1,' SURFACE TYPES I DO NOT KNOW'
WRITE(numout,*) 'CANNOT TREAT SNOW ON THESE SURFACE TYPES'
STOP 'in hydrol_snow'
ENDIF
!
! 4. computes total melt (snow and ice)
!
DO ji = 1, kjpindex
tot_melt(ji) = icemelt(ji) + snowmelt(ji)
ENDDO
!
! 5. computes snow age on veg and ice (for albedo)
!
DO ji = 1, kjpindex
!
! 5.1 Snow age on vegetation
!
IF (snow(ji) .LE. zero) THEN
snow_age(ji) = zero
ELSE
snow_age(ji) =(snow_age(ji) + (un - snow_age(ji)/max_snow_age) * dtradia/one_day) &
& * EXP(-precip_snow(ji) / snow_trans)
ENDIF
!
! 5.2 Snow age on ice
!
! age of snow on ice: a little bit different because in cold regions, we really
! cannot negect the effect of cold temperatures on snow metamorphism any more.
!
IF (snow_nobio(ji,iice) .LE. zero) THEN
snow_nobio_age(ji,iice) = zero
ELSE
!
d_age(ji) = ( snow_nobio_age(ji,iice) + &
& (un - snow_nobio_age(ji,iice)/max_snow_age) * dtradia/one_day ) * &
& EXP(-precip_snow(ji) / snow_trans) - snow_nobio_age(ji,iice)
IF (d_age(ji) .GT. min_sechiba ) THEN
xx(ji) = MAX( tp_00 - temp_sol_new(ji), zero )
xx(ji) = ( xx(ji) / 7._r_std ) ** 4._r_std
d_age(ji) = d_age(ji) / (un+xx(ji))
ENDIF
snow_nobio_age(ji,iice) = MAX( snow_nobio_age(ji,iice) + d_age(ji), zero )
!
ENDIF
ENDDO
!
! 6.0 Diagnose the depth of the snow layer
!
DO ji = 1, kjpindex
snowdepth(ji) = snow(ji) /sn_dens
ENDDO
IF (long_print) WRITE (numout,*) ' hydrol_snow done '
END SUBROUTINE hydrol_snow
!! This routine computes canopy processes
!!
SUBROUTINE hydrol_canop (kjpindex, precip_rain, vevapwet, veget, qsintmax, &
& qsintveg,precisol,tot_melt)
!
! interface description
!
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
! input fields
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: precip_rain !! Rain precipitation
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in) :: vevapwet !! Interception loss
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in) :: veget !! Fraction of vegetation type
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in) :: qsintmax !! Maximum water on vegetation for interception
REAL(r_std), DIMENSION (kjpindex), INTENT (in) :: tot_melt !! Total melt
! modified fields
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: qsintveg !! Water on vegetation due to interception
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out) :: precisol !! Eau tombee sur le sol
! output fields
!
! local declaration
!
INTEGER(i_std) :: ji, jv
REAL(r_std), DIMENSION (kjpindex,nvm) :: zqsintvegnew
LOGICAL, SAVE :: firstcall=.TRUE.
REAL(r_std), SAVE, DIMENSION(nvm) :: throughfall_by_pft
IF ( firstcall ) THEN
!Config Key = PERCENT_THROUGHFALL_PFT
!Config Desc = Percent by PFT of precip that is not intercepted by the canopy
!Config Def = 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30.
!Config Help = During one rainfall event, PERCENT_THROUGHFALL_PFT% of the incident rainfall
!Config will get directly to the ground without being intercepted, for each PFT.
throughfall_by_pft = (/ 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30. /)
CALL getin_p('PERCENT_THROUGHFALL_PFT',throughfall_by_pft)
throughfall_by_pft = throughfall_by_pft / 100.
firstcall=.FALSE.
ENDIF
! calcul de qsintmax a prevoir a chaque pas de temps
! dans ini_sechiba
! boucle sur les points continentaux
! calcul de qsintveg au pas de temps suivant
! par ajout du flux interception loss
! calcule par enerbil en fonction
! des calculs faits dans diffuco
! calcul de ce qui tombe sur le sol
! avec accumulation dans precisol
! essayer d'harmoniser le traitement du sol nu
! avec celui des differents types de vegetation
! fait si on impose qsintmax ( ,1) = 0.0
!
! loop for continental subdomain
!
!
! 1. evaporation off the continents
!
! 1.1 The interception loss is take off the canopy.
DO jv=1,nvm
qsintveg(:,jv) = qsintveg(:,jv) - vevapwet(:,jv)
END DO
! 1.2 It is raining : precip_rain is shared for each vegetation
! type
! sum (veget (1,nvm)) must be egal to 1-totfrac_nobio.
! iniveget computes veget each day
!
DO jv=1,nvm
! Correction Nathalie - Juin 2006 - une partie de la pluie arrivera toujours sur le sol
! sorte de throughfall supplementaire
!Ancienne formulation
qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * precip_rain(:)
!Nouvelle formulation
!qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * ((1-throughfall_by_pft(jv))*precip_rain(:))
END DO
!
! 1.3 Limits the effect and sum what receives soil
!
precisol(:,:) = zero
DO jv=1,nvm
DO ji = 1, kjpindex
zqsintvegnew(ji,jv) = MIN (qsintveg(ji,jv),qsintmax(ji,jv))
! correction throughfall Nathalie - Juin 2006
!Ancienne formulation
precisol(ji,jv) = qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
!Nouvelle formulation
!precisol(ji,jv) = (veget(ji,jv)*throughfall_by_pft(jv)*precip_rain(ji)) + qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
ENDDO
END DO
!
DO jv=1,nvm
DO ji = 1, kjpindex
IF (vegtot(ji).GT.min_sechiba) THEN
precisol(ji,jv) = precisol(ji,jv)+tot_melt(ji)*veget(ji,jv)/vegtot(ji)
ENDIF
ENDDO
END DO
!
!
! 1.4 swap qsintveg to the new value
!
DO jv=1,nvm
qsintveg(:,jv) = zqsintvegnew (:,jv)
END DO
IF (long_print) WRITE (numout,*) ' hydrol_canop done '
END SUBROUTINE hydrol_canop
!!
!!
!!
SUBROUTINE hydrol_vegupd(kjpindex, veget, frac_bare, soiltile,qsintveg,resdist)
!
! The vegetation cover has changed and we need to adapt the reservoir distribution
! and the distribution of plants on different soil types.
! You may note that this occurs after evaporation and so on have been computed. It is
! not a problem as a new vegetation fraction will start with humrel=0 and thus will have no
! evaporation. If this is not the case it should have been caught above.
!
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex
! input fields
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in) :: veget !! New vegetation map
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: frac_bare !! fraction of bare soil per veg.
REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile !! Map of soil types : proportion of each soil type
! modified fields
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: qsintveg !! Water on vegetation
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(inout) :: resdist !! Old vegetation map
!
! local declaration
!
INTEGER(i_std) :: ji,jv,jst,jst_pref
REAL(r_std), DIMENSION (kjpindex,nstm) :: soil_exist,soil_exist_max
REAL(r_std), DIMENSION (kjpindex,nvm) :: veget_exist,veget_exist_max
REAL(r_std), DIMENSION (kjpindex,nvm) :: qsintveg2 !! Water on vegetation due to interception over old veget
REAL(r_std), DIMENSION (kjpindex,nvm) :: vmr !! variation of veget
REAL(r_std), DIMENSION (kjpindex,nvm) :: qsdq
REAL(r_std), DIMENSION (kjpindex) :: vegchtot,vtr, qstr, fra
REAL(r_std), DIMENSION (kjpindex) :: test_pref,denom
REAL(r_std), PARAMETER :: EPS1 = EPSILON(un)
!
DO jv = 1, nvm
DO ji = 1, kjpindex
!mask
! vmr(ji,jv) = MAX ( EPSILON(un), MIN ( veget(ji,jv)-resdist(ji,jv) , MAX( EPSILON(un), veget(ji,jv)-resdist(ji,jv)) ) )
! vmr(ji,jv) = MAX ( EPSILON(un), MAX( EPSILON(un), veget(ji,jv)-resdist(ji,jv)) )
! IF(ABS(veget(ji,jv)-resdist(ji,jv)).gt.epsilon(un)) then
! WRITE(numout,*) '-----------------------------------------------'
! WRITE(numout,*) 'vmr,epsilon(un),veget,resdist',vmr(ji,jv),epsilon(un)
! WRITE(numout,*),veget(ji,jv),resdist(ji,jv)
! WRITE(numout,*) 'ABS(veget -resdist',ABS(veget(ji,jv)-resdist(ji,jv))
! endif
IF ( ABS(veget(ji,jv)-resdist(ji,jv)) .GT. EPS1 ) THEN
vmr(ji,jv) = veget(ji,jv)-resdist(ji,jv)
ELSE
vmr(ji,jv) = zero
ENDIF
!
IF (resdist(ji,jv) .GT. min_sechiba) THEN
qsintveg2(ji,jv) = qsintveg(ji,jv)/resdist(ji,jv)
ELSE
qsintveg2(ji,jv) = zero
ENDIF
ENDDO
ENDDO
!
vegchtot(:) = zero
DO jv = 1, nvm
DO ji = 1, kjpindex
vegchtot(ji) = vegchtot(ji) + ABS( vmr(ji,jv) )
ENDDO
ENDDO
!
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( vegchtot(ji) .GT. min_sechiba ) THEN
qsdq(ji,jv) = ABS(vmr(ji,jv)) * qsintveg2(ji,jv)
ENDIF
ENDDO
ENDDO
!
! calculate water mass that we have to redistribute
!
qstr(:) = zero
vtr(:) = zero
!
!
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( ( vegchtot(ji) .GT. min_sechiba ) .AND. ( vmr(ji,jv) .LT. -min_sechiba ) ) THEN
qstr(ji) = qstr(ji) + qsdq(ji,jv)
vtr(ji) = vtr(ji) - vmr(ji,jv)
ENDIF
ENDDO
ENDDO
!
! put it into reservoir of plant whose surface area has grown
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( vegchtot(ji) .GT. min_sechiba .AND. ABS(vtr(ji)) .GT. EPSILON(un)) THEN
fra(ji) = vmr(ji,jv) / vtr(ji)
IF ( vmr(ji,jv) .GT. min_sechiba) THEN
qsintveg(ji,jv) = qsintveg(ji,jv) + fra(ji)* qstr(ji)
ELSE
qsintveg(ji,jv) = qsintveg(ji,jv) - qsdq(ji,jv)
ENDIF
ENDIF
ENDDO
ENDDO
!MM underflow :
DO jv = 1, nvm
DO ji = 1, kjpindex
IF ( ABS(qsintveg(ji,jv)) < EPS1 ) THEN
qsintveg(ji,jv) = EPS1
ENDIF
ENDDO
ENDDO
! Now that the work is done resdist needs an update !
resdist(:,:) = veget(:,:)
! Distribution of the vegetation depending on the soil type
!!$ soil_exist(:,:) = zero
!!$ DO ji = 1, kjpindex
!!$ IF(vegtot(ji).GT.min_sechiba) THEN
!!$ soil_exist(ji,:) = mask_soiltile(ji,:)/vegtot(ji)
!!$ ENDIF
!!$ ENDDO
soil_exist(:,:) = mask_soiltile(:,:)
!!$ veget_exist(:,:) = zero
!!$ DO jv = 1, nvm
!!$ DO ji = 1, kjpindex
!!$ IF(vegtot(ji).GT.min_sechiba) THEN
!!$ veget_exist(ji,jv) = veget(ji,jv)/vegtot(ji)
!!$ ENDIF
!!$ ENDDO
!!$ ENDDO
veget_exist(:,:) = veget(:,:)
! Compute corr_veg_soil
corr_veg_soil(:,:,:) = zero
!!$ test_pref(:)=zero
denom(:) = SUM( veget(:,:) * frac_bare(:,:), dim=2)
!!$ WRITE(numout,*) "denom =",denom
!!$ WRITE(numout,*) "denom/vegtot =",denom/vegtot
DO jst = 1, nstm
DO jv = nvm, 1, -1
! The loop on jst is a simple way to treat the cases where the pref_soil_veg are not fully respected (changing veget)
! In the future, this should not be done any more: soiltiles should be allowed to change with veget (LPJ?),
! but it implies that we should exchange some water between the different tiles to conserve the water balance
jst_pref = MODULO(pref_soil_veg(jv)+(jst-2),nstm) + 1
DO ji=1,kjpindex
corr_veg_soil(ji,jv,jst_pref) = zero
!!$ WRITE(numout,*) 'ji,jv,jst_pref,jst, ',ji,jv,jst_pref,jst, &
!!$ 'corr_veg_soil(ji,jv,jst_pref), veget_exist(ji,jv), soil_exist(ji,jst_pref) ',&
!!$ corr_veg_soil(ji,jv,jst_pref), veget_exist(ji,jv), soil_exist(ji,jst_pref)
!for veget distribution used in sechiba via humrel
IF (soil_exist(ji,jst_pref).GT.min_sechiba) THEN
corr_veg_soil(ji,jv,jst_pref)=MIN(veget_exist(ji,jv)/soiltile(ji,jst_pref),soil_exist(ji,jst_pref))
!!$ test_pref(ji) = test_pref(ji) + &
!!$ MIN(veget_exist(ji,jv),soil_exist(ji,jst_pref)*soiltile(ji,jst_pref) ) * frac_bare(ji,jv)
!!$ IF (ji .EQ. 17 .OR. ji .EQ. 24) THEN
!!$ WRITE(numout,*) 'ji=',ji,' !!'
!!$ WRITE(numout,*) 'lalo(ji,1:2) = ',lalo(ji,1:2)
!!$ WRITE(numout,*) 'jst,jst_pref,jv',jst,jst_pref,jv
!!$ WRITE(numout,*) 'frac_bare',frac_bare(ji,jv)
!!$ WRITE(numout,*) 'corr_veg_soil',corr_veg_soil(ji,jv,jst_pref)
!!$ WRITE(numout,*) 'vegtot,veget_exist,soiltile,soil_exist',vegtot(ji),veget_exist(ji,jv), &
!!$ & soiltile(ji,jst_pref),soil_exist(ji,jst_pref)
!!$ ENDIF
veget_exist(ji,jv)=MAX(veget_exist(ji,jv)-soil_exist(ji,jst_pref)*soiltile(ji,jst_pref),zero)
soil_exist(ji,jst_pref)=MAX(soil_exist(ji,jst_pref)-corr_veg_soil(ji,jv,jst_pref),zero)
ENDIF
!!$ WRITE(numout,*) 'ji,jv,jst_pref,jst, ',ji,jv,jst_pref,jst, &
!!$ 'corr_veg_soil(ji,jv,jst_pref), veget_exist(ji,jv), soil_exist(ji,jst_pref) ',&
!!$ corr_veg_soil(ji,jv,jst_pref), veget_exist(ji,jv), soil_exist(ji,jst_pref)
ENDDO
ENDDO
ENDDO
!!$ WRITE(numout,*) "test_pref =",test_pref
!!$ WRITE(numout,*) "test_pref/denom ="
!!$ DO ji=1,kjpindex
!!$ IF (ABS( denom(ji) ) .GT. zero ) THEN
!!$ WRITE(numout,'(F12.8," ",$)') test_pref(ji)/denom(ji)
!!$ ELSE
!!$ WRITE(numout,'(a3,1X,$)') "INF"
!!$ ENDIF
!!$ ENDDO
!!$ WRITE(numout,*)
!!$
!!$ WRITE(numout,*) "un-test_pref/denom ="
!!$ DO ji=1,kjpindex
!!$ IF (ABS( denom(ji) ) .GT. zero ) THEN
!!$ WRITE(numout,'(E15.8," ",$)') un-test_pref(ji)/denom(ji)
!!$ ELSE
!!$ WRITE(numout,'(a3,1X,$)') "INF"
!!$ ENDIF
!!$ ENDDO
!!$ WRITE(numout,*)
!!$
!!$ WRITE(numout,*) "vegtot :"
!!$ DO ji=1,kjpindex
!!$ WRITE(numout,'(F12.8,2X,$)') vegtot(ji)
!!$ ENDDO
!!$ WRITE(numout,*)
!!$
!!$ denom(:)=zero
!!$ DO jst = 1, nstm
!!$ DO jv = 1,nvm
!!$ DO ji=1,kjpindex
!!$ denom(ji) = denom(ji) + corr_veg_soil(ji,jv,jst)
!!$ ENDDO
!!$ ENDDO
!!$ ENDDO
!!$ WRITE(numout,*) "Somme des corr_veg_soil :"
!!$ DO ji=1,kjpindex
!!$ WRITE(numout,'(F12.8,2X,$)') denom(ji)
!!$ ENDDO
!!$ WRITE(numout,*)
!
! update the corresponding masks
!
mask_veget(:,:) = 0
DO jv = 1, nvm
DO ji = 1, kjpindex
IF(veget(ji,jv) .GT. min_sechiba) THEN
mask_veget(ji,jv) = 1
ENDIF
END DO
! print *,'mask: soiltile,mask_soiltile',soiltile(ji,:),mask_soiltile(ji,:)
END DO
!
! Tout dans cette routine est maintenant certainement obsolete (veget etant constant) en dehors des lignes suivantes:
frac_bare_ns(:,:) = zero
tot_frac_bare(:) = zero
DO jst = 1, nstm
DO jv = 1, nvm
DO ji =1, kjpindex
frac_bare_ns(ji,jst) = frac_bare_ns(ji,jst) + corr_veg_soil(ji,jv,jst) * frac_bare(ji,jv) / vegtot(ji)
!!$ frac_bare_ns(ji,jst) = frac_bare_ns(ji,jst) + corr_veg_soil(ji,jv,jst) * frac_bare(ji,jv)
ENDDO
ENDDO
ENDDO
!!$ denom(:)=zero
!!$ DO jst = 1, nstm
!!$ DO ji=1,kjpindex
!!$ denom(ji) = denom(ji) + frac_bare_ns(ji,jst)
!!$ ENDDO
!!$ ENDDO
!!$ WRITE(numout,*) "Somme des frac_bare_ns :"
!!$ DO ji=1,kjpindex
!!$ WRITE(numout,'(F12.8,2X,$)') denom(ji)
!!$ ENDDO
!!$ WRITE(numout,*)
!!$ denom(:)=zero
!!$ DO jv = 1,nvm
!!$ DO ji=1,kjpindex
!!$ denom(ji) = denom(ji) + frac_bare(ji,jv)
!!$ ENDDO
!!$ ENDDO
!!$ WRITE(numout,*) "Somme des frac_bare :"
!!$ DO ji=1,kjpindex
!!$ WRITE(numout,'(F12.8,2X,$)') denom(ji)
!!$ ENDDO
!!$ WRITE(numout,*)
DO jv = 1, nvm
DO ji =1, kjpindex
tot_frac_bare(ji) = tot_frac_bare(ji) + veget(ji,jv) * frac_bare(ji,jv)
ENDDO
ENDDO
!!$ WRITE(numout,*) "tot_frac_bare :"
!!$ DO ji=1,kjpindex
!!$ WRITE(numout,'(F12.8,2X,$)') tot_frac_bare(ji)
!!$ ENDDO
!!$ WRITE(numout,*)
!!$
!!$ denom(:)=zero
!!$ DO jv = 1, nvm
!!$ DO ji =1, kjpindex
!!$ IF(vegtot(ji).GT.min_sechiba) THEN
!!$ denom(ji) = denom(ji) + veget(ji,jv) * frac_bare(ji,jv) / vegtot(ji)
!!$ ENDIF
!!$ ENDDO
!!$ ENDDO
!!$ WRITE(numout,*) "tot_frac_bare / vegtot :"
!!$ DO ji=1,kjpindex
!!$ WRITE(numout,'(F12.8,2X,$)') denom(ji)
!!$ ENDDO
!!$ WRITE(numout,*)
!!$
!!$ denom(:)=zero
!!$ DO jst = 1, nstm
!!$ DO ji =1, kjpindex
!!$ denom(ji) = denom(ji) + frac_bare_ns(ji,jst) / tot_frac_bare(ji)
!!$ ENDDO
!!$ ENDDO
!!$ WRITE(numout,*) "frac_bare_ns / tot_frac_bare :"
!!$ DO ji=1,kjpindex
!!$ WRITE(numout,'(F12.8,2X,$)') denom(ji)
!!$ ENDDO
!!$ WRITE(numout,*)
!!$
!!$ denom(:)=zero
!!$ DO jst = 1, nstm
!!$ DO ji =1, kjpindex
!!$ IF(vegtot(ji).GT.min_sechiba) THEN
!!$ denom(ji) = denom(ji) + frac_bare_ns(ji,jst) / tot_frac_bare(ji) / vegtot(ji)
!!$ ELSE
!!$ denom(ji) = denom(ji) + frac_bare_ns(ji,jst) / tot_frac_bare(ji)
!!$ ENDIF
!!$ ENDDO
!!$ ENDDO
!!$ WRITE(numout,*) "frac_bare_ns / tot_frac_bare / vegtot :"
!!$ DO ji=1,kjpindex
!!$ WRITE(numout,'(F12.8,2X,$)') denom(ji)
!!$ ENDDO
!!$ WRITE(numout,*)
RETURN
!
END SUBROUTINE hydrol_vegupd
!!
!! this routine computes the evolution of the surface reservoir (floodplain)
!!
SUBROUTINE hydrol_flood (kjpindex, dtradia, vevapflo, flood_frac, flood_res, floodout)
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex
! input fields
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: flood_frac !! Fraction of floodplains in grid box
! modified fields
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: floodout !! Flux to take out from floodplains
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: flood_res !! Floodplains reservoir estimate
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: vevapflo !! Evaporation over floodplains
! local declaration
INTEGER(i_std) :: ji, jst, jv !! indices
REAL(r_std) :: k_m !! conductivity in the soil
REAL(r_std), DIMENSION (kjpindex) :: temp !!
!-
!- 1. Take out vevapflo from the reservoir and transfer the remaining to subsinksoil
!-
DO ji = 1,kjpindex
temp(ji) = MIN(flood_res(ji), vevapflo(ji))
ENDDO
DO ji = 1,kjpindex
flood_res(ji) = flood_res(ji) - temp(ji)
subsinksoil(ji) = subsinksoil(ji) + vevapflo(ji) - temp(ji)
vevapflo(ji) = temp(ji)
ENDDO
!-
!- 2. Compute the total flux from floodplain floodout (transfered to routing)
!-
DO ji = 1,kjpindex
floodout(ji) = vevapflo(ji) - flood_frac(ji) * SUM(precisol(ji,:))
ENDDO
!-
!- 3. Discriminate between precip over land and over floodplain
!-
DO jv=1, nvm
DO ji = 1,kjpindex
precisol(ji,jv) = precisol(ji,jv) * (1 - flood_frac(ji))
ENDDO
ENDDO
IF (long_print) WRITE (numout,*) ' hydrol_flood done'
END SUBROUTINE hydrol_flood
!!
!! this routine computes soil processes with CWRR scheme
!!
SUBROUTINE hydrol_soil (kjpindex, dtradia, veget, soiltile, njsc, reinf_slope, &
& transpir, vevapnu, evapot, evapot_penm, runoff, drainage, returnflow, reinfiltration, irrigation, &
& tot_melt, evap_bare_lim, shumdiag, k_litt, litterhumdiag, humrel,vegstress, drysoil_frac)
!
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex
! input fields
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Map of vegetation types
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: njsc !! Indeces of the soiltype
REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile !! Map of soil types
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in) :: transpir !! transpiration
REAL(r_std), DIMENSION (kjpindex), INTENT (in) :: reinf_slope !! slope coef
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: vevapnu !!
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: returnflow !! Water returning to the deep reservoir
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: reinfiltration !! Water returning to the top of the soil
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: irrigation !! Irrigation
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: evapot !!
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: evapot_penm !!
! modified fields
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: runoff !! complete runoff
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: drainage !! complete drainage
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: tot_melt
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: evap_bare_lim !!
REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (out) :: shumdiag !! relative soil moisture
REAL(r_std), DIMENSION (kjpindex), INTENT (out) :: k_litt !! litter cond.
REAL(r_std), DIMENSION (kjpindex), INTENT (out) :: litterhumdiag !! litter humidity
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (inout) :: humrel !! Relative humidity
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out) :: vegstress !! Veg. moisture stress (only for vegetation growth)
REAL(r_std), DIMENSION (kjpindex), INTENT (out) :: drysoil_frac !! Function of the litter humidity, that will be used to compute albedo
!
! local declaration
!
INTEGER(i_std) :: ji, jv, jsl, jsl1, jst !! indices
REAL(r_std), PARAMETER :: frac_mcs = 0.66 !! temporary depth
REAL(r_std) :: dztmp !! temporary depth
REAL(r_std), DIMENSION(kjpindex) :: temp !! temporary value for fluxes
REAL(r_std), DIMENSION(kjpindex) :: tmcold, tmcint
REAL(r_std), DIMENSION(kjpindex,nslm,nstm) :: moderwilt
REAL(r_std), DIMENSION(kjpindex,nslm) :: mcint !! To save mc values for future use
REAL(r_std), DIMENSION(kjpindex) :: under_mcr !! Allows under residual soil moisture due to evap
LOGICAL, DIMENSION(kjpindex) :: under_mcr_test !! test on under residual soil moisture and Mask soil Tile
LOGICAL, DIMENSION(kjpindex) :: under_mcr_test1 !! test on under residual soil moisture
REAL(r_std), DIMENSION(kjpindex) :: over_mcs !! Allows over saturated soil moisture due to returnflow
REAL(r_std), DIMENSION(kjpindex,nstm) :: evap_bare_lim_ns !! limitation of bare soil evaporation on each soil column (used to deconvoluate vevapnu)
REAL(r_std), DIMENSION(kjpindex) :: deltahum,diff
LOGICAL(r_std), DIMENSION(kjpindex) :: test
REAL(r_std), DIMENSION(kjpindex) :: tsink
REAL(r_std), DIMENSION(kjpindex) :: returnflow_soil
REAL(r_std), DIMENSION(kjpindex) :: reinfiltration_soil
REAL(r_std), DIMENSION(kjpindex) :: irrigation_soil
REAL(r_std), DIMENSION(kjpindex) :: flux_infilt
!
!
returnflow_soil(:) = zero
reinfiltration_soil(:) = zero
irrigation_soil(:) = zero
qflux(:,:,:) = zero
under_mcr(:) = zero
over_mcs(:) = zero
flux_infilt(:) = zero
!
! split 2d variables to 3d variables, per soil type
!
CALL hydrol_split_soil (kjpindex, veget, soiltile, vevapnu, transpir, humrel, evap_bare_lim)
!
! Common variables
!
DO ji=1,kjpindex
IF(vegtot(ji).GT.min_sechiba) THEN
returnflow_soil(ji) = zero
reinfiltration_soil(ji) = (returnflow(ji) + reinfiltration(ji))/vegtot(ji)
irrigation_soil(ji) = irrigation(ji)/vegtot(ji)
ENDIF
ENDDO
!
! for each soil type
!
DO jst=1, nstm
!
!- We compute the sum of the sinks for future check-up
DO ji=1,kjpindex
tsink(ji) = SUM(rootsink(ji,:,jst))+MAX(ae_ns(ji,jst),zero)+subsinksoil(ji)
ENDDO
!
! The total moisture content is save for balance checks at the end
tmcold(:) = tmc(:,jst)
! The moisture content is updated with the evaporation from enerbil and with the reinfiltration fraction from previous timestep
DO ji = 1, kjpindex
!- the bare soil evaporation is substracted to the soil moisture profile and first to the water available:
temp(ji) = MIN(water2infilt(ji,jst), MAX(ae_ns(ji,jst),zero) + subsinksoil(ji))
ENDDO
DO ji = 1, kjpindex
! First we substract from the surface
water2infilt(ji,jst) = water2infilt(ji,jst) - temp(ji)
! Then to the rest of the soil
ENDDO
DO jsl = 1, nslm
DO ji = 1, kjpindex
mc(ji,jsl,jst) = mask_soiltile(ji,jst) * (mc(ji,jsl,jst) &
& - (MAX(ae_ns(ji,jst),zero) + subsinksoil(ji) - temp(ji)) / (dpu_max*mille))
ENDDO
ENDDO
!- The value of mc is kept in mcint, used in the flux computation after diffusion:
DO jsl = 1, nslm
DO ji = 1, kjpindex
mcint(ji,jsl) = mc(ji,jsl,jst)
ENDDO
ENDDO
DO ji = 1, kjpindex
tmcint(ji) = dz(2,jst) * ( trois*mcint(ji,1) + mcint(ji,2) )/huit
ENDDO
DO jsl = 2,nslm-1
DO ji = 1, kjpindex
tmcint(ji) = tmcint(ji) + dz(jsl,jst) &
& * (trois*mcint(ji,jsl)+mcint(ji,jsl-1))/huit &
& + dz(jsl+1,jst) * (trois*mcint(ji,jsl)+mcint(ji,jsl+1))/huit
ENDDO
ENDDO
DO ji = 1, kjpindex
tmcint(ji) = tmcint(ji) + dz(nslm,jst) &
& * (trois * mcint(ji,nslm) + mcint(ji,nslm-1))/huit
ENDDO
!- Some initialisation necessary for the diffusion scheme to work
DO ji = 1, kjpindex
!- We correct rootsink for first two layers so that it is not too low in the first layer
v1(ji,jst) = dz(2,jst)/huit * (trois * mc(ji,1,jst)+ mc(ji,2,jst))
rootsink(ji,2,jst) = rootsink(ji,2,jst) + MAX(rootsink(ji,1,jst)-v1(ji,jst), zero)
rootsink(ji,1,jst) = MIN(rootsink(ji,1,jst),v1(ji,jst))
!- estimate maximum evaporation flux in mm/step, assuming the water is available
flux(ji) = zero
IF(vegtot(ji).GT.min_sechiba) THEN
!- Flux = evapot_penm if frac_bare_ns > min_sechiba
!- = zero else
flux(ji) = evapot_penm(ji) * &
& AINT(frac_bare_ns(ji,jst)+un-min_sechiba)
ENDIF
ENDDO
! Then we prepare the infiltration (first the irrigation and below mcr fill up)
DO ji = 1, kjpindex
!- We add the irrigation to the soil (irrigation is put so that it does not runoff)
!- by filling the layers from top to bottom (same for reinfiltration) - this is done by smooth below
! mc(ji,1,jst) = mc(ji,1,jst) + irrigation_soil(ji) + reinfiltration_soil(ji) * deux / dz(2,jst)
!MG d apres Tristan le 17/07/08
mc(ji,1,jst) = mc(ji,1,jst) + (irrigation_soil(ji) + reinfiltration_soil(ji)) * deux / dz(2,jst)
ENDDO
CALL hydrol_soil_smooth(kjpindex,jst, njsc, under_mcr, over_mcs)
DO ji = 1, kjpindex
! Initialise the flux to be infiltrated
flux_infilt(ji) = water2infilt(ji,jst) + precisol_ns(ji,jst)
!- The incoming flux is also first dedicated to fill the soil up to mcr (in case needed)
temp(ji) = MIN(flux_infilt(ji),under_mcr(ji))
ENDDO
DO ji = 1, kjpindex
flux_infilt(ji) = flux_infilt(ji) - temp(ji)
under_mcr(ji) = under_mcr(ji) - temp(ji)
ENDDO
!- coefficients are computed for the profile of mc before rainfall infiltration:
CALL hydrol_soil_coef(kjpindex,jst,njsc)
! Then the infiltration by precipitation is computed
CALL hydrol_soil_infilt(kjpindex, jst, dtradia, njsc, flux_infilt, over_mcs)
!- module to implement dublin model for one time-step
!- gravity drainage as lower boundary layer
!- m.bruen, CWRR, ucd.
!
!-step3: matrix resolution
!-calcul of the matrix coefficients
!- coefficient are recomputed for the new profile of mc:
CALL hydrol_soil_coef(kjpindex,jst,njsc)
!- Set the values for diffusion scheme
CALL hydrol_soil_setup(kjpindex,jst,dtradia)
resolv(:) = .FALSE.
under_mcr_test1(:)=(under_mcr(:).LT.min_sechiba)
under_mcr_test(:)=(mask_soiltile(:,jst) .GT. 0).AND.under_mcr_test1(:)
DO ji = 1, kjpindex
! We only run the scheme in case we are not under mcr after precip and various reinfiltrations and not over mcs
IF (under_mcr_test(ji)) THEN
IF (over_mcs(ji).LT.min_sechiba) THEN
resolv(ji)=.TRUE.
ENDIF
ENDIF
ENDDO
DO ji = 1, kjpindex
! We only run the scheme in case we are not under mcr after precip and various reinfiltrations and not over mcs
IF (under_mcr_test(ji)) THEN
IF (.NOT. resolv(ji)) THEN
! In oversaturated case, we first take the evaporation from the outgoing water (the rest will be taken from the soil)
over_mcs(ji) = over_mcs(ji) - flux(ji)
ENDIF
ENDIF
ENDDO
DO jsl = 1, nslm
DO ji = 1, kjpindex
! We only run the scheme in case we are not under mcr after precip and various reinfiltrations and not over mcs
IF (under_mcr_test(ji)) THEN
IF (.NOT. resolv(ji)) THEN
! In oversaturated case, we first take the evaporation from the outgoing water (the rest will be taken from the soil)
over_mcs(ji) = over_mcs(ji) - rootsink(ji,jsl,jst)
ENDIF
ENDIF
ENDDO
ENDDO
DO jsl = 1, nslm
DO ji = 1, kjpindex
! We only run the scheme in case we are not under mcr after precip and various reinfiltrations and not over mcs
IF (mask_soiltile(ji,jst) .GT. 0) THEN
IF (.NOT. under_mcr_test1(ji)) THEN
! In under residual case, we equally spread the transpiration over the layers
under_mcr(ji) = under_mcr(ji) + rootsink(ji,jsl,jst)
ENDIF
ENDIF
ENDDO
ENDDO
DO ji = 1, kjpindex
! We directly use the value of k (a and b are only used un hydrol_soil_coef to compute k)
!- First layer
tmat(ji,1,1) = zero
tmat(ji,1,2) = f(ji,1)
tmat(ji,1,3) = g1(ji,1)
rhs(ji,1) = fp(ji,1) * mc(ji,1,jst) + gp(ji,1)*mc(ji,2,jst) &
& - flux(ji) - SQRT(k(ji,1)*k(ji,2)) *(dtradia/one_day) - rootsink(ji,1,jst)
ENDDO
!- soil body
DO jsl=2, nslm-1
DO ji = 1, kjpindex
tmat(ji,jsl,1) = e(ji,jsl)
tmat(ji,jsl,2) = f(ji,jsl)
tmat(ji,jsl,3) = g1(ji,jsl)
rhs(ji,jsl) = ep(ji,jsl)*mc(ji,jsl-1,jst) + fp(ji,jsl)*mc(ji,jsl,jst) &
& + gp(ji,jsl) * mc(ji,jsl+1,jst) &
& + (SQRT(k(ji,jsl-1)*k(ji,jsl)) - SQRT(k(ji,jsl)*k(ji,jsl+1))) * (dtradia/one_day) &
& - rootsink(ji,jsl,jst)
ENDDO
ENDDO
DO ji = 1, kjpindex
!- Last layer
jsl=nslm
tmat(ji,jsl,1) = e(ji,jsl)
tmat(ji,jsl,2) = f(ji,jsl)
tmat(ji,jsl,3) = zero
rhs(ji,jsl) = ep(ji,jsl)*mc(ji,jsl-1,jst) + fp(ji,jsl)*mc(ji,jsl,jst) &
& + (SQRT(k(ji,jsl-1)*k(ji,jsl)) - k(ji,jsl)) * (dtradia/one_day) &
& - rootsink(ji,jsl,jst)
ENDDO
!- store the equations in case needed again
DO jsl=1,nslm
DO ji = 1, kjpindex
srhs(ji,jsl) = rhs(ji,jsl)
stmat(ji,jsl,1) = tmat(ji,jsl,1)
stmat(ji,jsl,2) = tmat(ji,jsl,2)
stmat(ji,jsl,3) = tmat(ji,jsl,3)
ENDDO
ENDDO
!
!- step 4 : solve equations assuming atmosphere limiting (sufficient soil moisture for Evapot)
!-
CALL hydrol_soil_tridiag(kjpindex,jst)
!
!- step 5 : check if really atmosphere limiting
!-
DO ji = 1, kjpindex
!
!- Prepare to rerun in case of under residual with evaporation
!-
! resolv(ji) = (mc(ji,1,jst).LT.(mcr(njsc(ji))*0.9).AND.flux(ji).GT.min_sechiba)
!MG erreur!!!
resolv(ji) = (mc(ji,1,jst).LT.(mcr(njsc(ji))).AND.flux(ji).GT.min_sechiba)
ENDDO
! Reset the coefficient for diffusion (only used if resolv(ji) = .TRUE.)
DO jsl=1,nslm
!- The new condition is to put the upper layer at residual soil moisture
DO ji = 1, kjpindex
rhs(ji,jsl) = srhs(ji,jsl)
tmat(ji,jsl,1) = stmat(ji,jsl,1)
tmat(ji,jsl,2) = stmat(ji,jsl,2)
tmat(ji,jsl,3) = stmat(ji,jsl,3)
END DO
ENDDO
!
DO ji = 1, kjpindex
tmat(ji,1,2) = un
tmat(ji,1,3) = zero
! rhs(ji,1) = mcr(njsc(ji))*0.9
!MG erreur!!!
rhs(ji,1) = mcr(njsc(ji))
ENDDO
!
!- step 6 : resolve the equations with new boundary conditions if necessary
!-
CALL hydrol_soil_tridiag(kjpindex,jst)
!-
!- step 6.5 : initialize qflux at bottom of diffusion and avoid over saturated or under residual soil moisture
!-
DO ji = 1, kjpindex
dr_ns(ji,jst)=zero
jsl=nslm
IF (under_mcr(ji).LT.min_sechiba) THEN
dr_ns(ji,jst) = mask_soiltile(ji,jst)*k(ji,jsl) * (dtradia/one_day)
ENDIF
ENDDO
! Finally, for soil that are under-residual, we just equally distribute the lack of water
! For over-saturated ones, we do the same if the outgoing flux was not sufficient to satisfy evapot
DO jsl = 1, nslm
DO ji = 1, kjpindex
mc(ji,jsl,jst) = mc(ji,jsl,jst) - under_mcr(ji) / (dpu_max*mille)
mc(ji,jsl,jst) = mask_soiltile(ji,jst) * mc(ji,jsl,jst) + MIN(zero, over_mcs(ji)) / (dpu_max*mille)
ENDDO
ENDDO
!
!- step 7 : close the water balance
!
DO ji = 1, kjpindex
tmc(ji,jst) = dz(2,jst) * ( trois*mc(ji,1,jst) + mc(ji,2,jst) )/huit
ENDDO
DO jsl = 2,nslm-1
DO ji = 1, kjpindex
tmc(ji,jst) = tmc(ji,jst) + dz(jsl,jst) &
& * (trois*mc(ji,jsl,jst)+mc(ji,jsl-1,jst))/huit &
& + dz(jsl+1,jst) * (trois*mc(ji,jsl,jst)+mc(ji,jsl+1,jst))/huit
ENDDO
ENDDO
DO ji = 1, kjpindex
tmc(ji,jst) = tmc(ji,jst) + dz(nslm,jst) &
& * (trois * mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
ENDDO
DO ji = 1, kjpindex
qflux00(ji,jst) = mask_soiltile(ji,jst) * &
& (MIN(tmcs(ji,jst),tmc(ji,jst))-tmcint(ji)+SUM(rootsink(ji,:,jst))+dr_ns(ji,jst)-returnflow_soil(ji))
!
! deduction of ae_ns and ru_ns:
! ae_ns+ru_ns=precisol_ns+irrigation-q0
!
ae_ns(ji,jst) = MAX(MIN((precisol_ns(ji,jst)+irrigation_soil(ji)+reinfiltration_soil(ji) & ! (returnflow introduit par le haut)
& +water2infilt(ji,jst)-qflux00(ji,jst)) ,evapot_penm(ji)),zero) * mask_soiltile(ji,jst)
ru_ns(ji,jst) = (precisol_ns(ji,jst)+irrigation_soil(ji)+reinfiltration_soil(ji) &
& +water2infilt(ji,jst)-qflux00(ji,jst)-ae_ns(ji,jst)) * mask_soiltile(ji,jst)
ENDDO
!
! Special treatment for the unstable cases when boundary condition mc1=mcr leads to negative runoff
!
IF (long_print) THEN
DO ji = 1, kjpindex
IF (ru_ns(ji,jst) .LT.-min_sechiba) THEN
WRITE (numout,*) 'Negative runoff corrected', ji,jst,ru_ns(ji,jst), mc(ji,1,jst), tmc(ji,jst)
ENDIF
ENDDO
ENDIF
DO ji = 1, kjpindex
temp(ji) = MIN(ru_ns(ji,jst),zero)
ENDDO
DO ji = 1, kjpindex
ru_ns(ji,jst) = ru_ns(ji,jst) - temp(ji)
! We correct this by taking water from the whole soil
qflux00(ji,jst) = qflux00(ji,jst) + temp(ji)
ENDDO
DO jsl = 1, nslm
DO ji = 1, kjpindex
mc(ji,jsl,jst) = mc(ji,jsl,jst) + temp(ji) / (dpu_max*mille)
ENDDO
ENDDO
! Avoid under-precision value for the 3 outward flux
DO ji = 1, kjpindex
IF (ABS(ae_ns(ji,jst)).LT.min_sechiba) THEN
ae_ns(ji,jst) = zero
ENDIF
IF(ABS(ru_ns(ji,jst)).LT.min_sechiba) THEN
ru_ns(ji,jst) = zero
ENDIF
IF(ABS(dr_ns(ji,jst)).LT.min_sechiba) THEN
dr_ns(ji,jst) = zero
ENDIF
ENDDO
! Then compute the temporary surface water and correct the outgoing runoff
IF ( .NOT. doponds ) THEN
DO ji = 1, kjpindex
water2infilt(ji,jst) = reinf_slope(ji) * ru_ns(ji,jst)
ENDDO
ELSE
DO ji = 1, kjpindex
water2infilt(ji,jst) = zero
ENDDO
ENDIF
!
DO ji = 1, kjpindex
ru_ns(ji,jst) = ru_ns(ji,jst) - water2infilt(ji,jst)
water2infilt(ji,jst) = water2infilt(ji,jst) + ae_ns(ji,jst)
ENDDO
CALL hydrol_soil_smooth(kjpindex, jst, njsc, under_mcr, over_mcs)
!MG d apres Tristan le 17/07/08
! Finally, for soil that are under-residual, we just equally distribute the lack of water
! For over-saturated ones, we do the same if the outgoing flux was not sufficient to satisfy evapot
DO jsl = 1, nslm
DO ji = 1, kjpindex
mc(ji,jsl,jst) = mc(ji,jsl,jst) - under_mcr(ji) / (dpu_max*mille)
mc(ji,jsl,jst) = mask_soiltile(ji,jst) * mc(ji,jsl,jst) + MIN(zero, over_mcs(ji)) / (dpu_max*mille)
ENDDO
ENDDO
! Optional computation of the fluxes
IF ( check_cwrr ) THEN
CALL hydrol_soil_flux(kjpindex,jst,mcint,returnflow_soil)
ENDIF
!
!- step8: we make some useful output
!- Total soil moisture, soil moisture at litter levels, soil wetness...
!
!-total soil moisture:
DO ji = 1, kjpindex
tmc(ji,jst)= dz(2,jst) * (trois*mc(ji,1,jst) + mc(ji,2,jst))/huit
ENDDO
DO jsl=2,nslm-1
DO ji = 1, kjpindex
tmc(ji,jst) = tmc(ji,jst) + dz(jsl,jst) * ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
& + dz(jsl+1,jst)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
ENDDO
END DO
DO ji = 1, kjpindex
tmc(ji,jst) = tmc(ji,jst) + dz(nslm,jst) * (trois * mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
tmc(ji,jst) = tmc(ji,jst) + water2infilt(ji,jst)
ENDDO
! the litter is the 4 top levels of the soil
! we compute various field of soil moisture for the litter (used for stomate and for albedo)
DO ji = 1, kjpindex
tmc_litter(ji,jst) = dz(2,jst) * ( trois*mc(ji,1,jst)+ mc(ji,2,jst))/huit
tmc_litter(ji,jst) = tmc_litter(ji,jst)
ENDDO
! sum from level 1 to 4
DO jsl=2,4
DO ji = 1, kjpindex
tmc_litter(ji,jst) = tmc_litter(ji,jst) + dz(jsl,jst) * &
& ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
& + dz(jsl+1,jst)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
END DO
ENDDO
! subsequent calcul of soil_wet_litter (tmc-tmcw)/(tmcf-tmcw)
DO ji = 1, kjpindex
soil_wet_litter(ji,jst) = MIN(un, MAX(zero,&
& (tmc_litter(ji,jst)-tmc_litter_wilt(ji,jst)) / &
& (tmc_litter_field(ji,jst)-tmc_litter_wilt(ji,jst)) ))
ENDDO
! Soil wetness profiles (mc-mcw)/(mcs-mcw)
! soil_wet is the ratio of soil moisture to available soil moisture for plant
! (ie soil moisture at saturation minus soil moisture at wilting point).
DO ji = 1, kjpindex
soil_wet(ji,1,jst) = MIN(un, MAX(zero,&
& (trois*mc(ji,1,jst) + mc(ji,2,jst) - quatre*mcw(njsc(ji)))&
& /(quatre*(mcs(njsc(ji))-mcw(njsc(ji)))) ))
humrelv(ji,1,jst) = zero
ENDDO
DO jsl=2,nslm-1
DO ji = 1, kjpindex
soil_wet(ji,jsl,jst) = MIN(un, MAX(zero,&
& (trois*mc(ji,jsl,jst) + &
& mc(ji,jsl-1,jst) *(dz(jsl,jst)/(dz(jsl,jst)+dz(jsl+1,jst))) &
& + mc(ji,jsl+1,jst)*(dz(jsl+1,jst)/(dz(jsl,jst)+dz(jsl+1,jst))) &
& - quatre*mcw(njsc(ji))) / (quatre*(mcs(njsc(ji))-mcw(njsc(ji)))) ))
END DO
ENDDO
DO ji = 1, kjpindex
soil_wet(ji,nslm,jst) = MIN(un, MAX(zero,&
& (trois*mc(ji,nslm,jst) &
& + mc(ji,nslm-1,jst)-quatre*mcw(njsc(ji)))/(quatre*(mcs(njsc(ji))-mcw(njsc(ji)))) ))
ENDDO
!
!- step8: we make the outputs for sechiba:
!-we compute the moderation of transpiration due to wilting point:
! moderwilt is a factor which is zero if soil moisture is below the wilting point
! and is un if soil moisture is above the wilting point.
DO jsl=1,nslm
DO ji = 1, kjpindex
moderwilt(ji,jsl,jst) = INT( MAX(soil_wet(ji,jsl,jst), zero) + un - min_sechiba )
END DO
ENDDO
!- we compute the new humrelv to use in sechiba:
!- loop on each vegetation type
humrelv(:,1,jst) = zero
!- calcul of us for each layer and vegetation type.
DO jv = 2,nvm
DO ji = 1, kjpindex
!- Here we make the assumption that roots do not take water from the 1st layer.
!- Comment the us=0 if you want to change this.
! us(ji,jv,jst,1) = moderwilt(ji,1,jst)*MIN(un,((trois*mc(ji,1,jst) + mc(ji,2,jst)) &
! & /(quatre*mcs(jst)*pcent(jst))) )* (un-EXP(-humcste(jv)*dz(2,jst)/mille/deux)) &
! & /(un-EXP(-humcste(jv)*zz(nslm,jst)/mille))
us(ji,jv,jst,1) = zero
humrelv(ji,jv,jst) = MAX(us(ji,jv,jst,1),zero)
ENDDO
ENDDO
DO jsl = 2,nslm-1
DO jv = 2, nvm
DO ji = 1, kjpindex
! us is computed with a SQRT in order for it to grow more rapidly with soil moisture.
! it is not essential
us(ji,jv,jst,jsl) =moderwilt(ji,jsl,jst)* &
& MIN( un, &
& SQRT((trois*mc(ji,jsl,jst)+ &
& mc(ji,jsl-1,jst)*(dz(jsl,jst)/(dz(jsl,jst)+dz(jsl+1,jst)))+ &
& mc(ji,jsl+1,jst)*(dz(jsl+1,jst)/(dz(jsl,jst)+dz(jsl+1,jst)))) &
& /(quatre*mcs(njsc(ji))*pcent(njsc(ji)))) )* &
& nroot(jv,jst,jsl)
us(ji,jv,jst,jsl) = MAX(us (ji,jv,jst,jsl), zero)
humrelv(ji,jv,jst) = MAX((humrelv(ji,jv,jst) + us(ji,jv,jst,jsl)),zero)
END DO
ENDDO
ENDDO
DO jv = 2, nvm
DO ji = 1, kjpindex
us(ji,jv,jst,nslm) = moderwilt(ji,nslm,jst)* &
& MIN(un, &
& SQRT((trois*mc(ji,nslm,jst) + mc(ji,nslm-1,jst)) &
& / (quatre*mcs(njsc(ji))*pcent(njsc(ji)))) ) * &
& nroot(jv,jst,nslm)
us(ji,jv,jst,nslm) = MAX(us(ji,jv,jst,nslm), zero)
humrelv(ji,jv,jst) = MAX(zero,MIN(un, humrelv(ji,jv,jst) + us(ji,jv,jst,nslm)))
vegstressv(ji,jv,jst) = humrelv(ji,jv,jst)
END DO
END DO
DO jv = 2, nvm
DO ji = 1, kjpindex
IF (corr_veg_soil(ji,jv,jst) .LT. min_sechiba) THEN
humrelv(ji,jv,jst) = zero
ENDIF
END DO
END DO
!before closing the soil water, we check the water balance of soil
IF(check_cwrr) THEN
DO ji = 1,kjpindex
deltahum(ji) = (tmc(ji,jst) - tmcold(ji))
diff(ji) = precisol_ns(ji,jst)-ru_ns(ji,jst)-dr_ns(ji,jst)-tsink(ji) &
& + irrigation_soil(ji) + returnflow_soil(ji) + reinfiltration_soil(ji)
test(ji) = (abs(deltahum(ji)-diff(ji))*mask_soiltile(ji,jst) .GT. allowed_err)
ENDDO
DO ji = 1,kjpindex
IF(test(ji)) THEN
WRITE (numout,*)'CWRR pat: bilan non nul',ji,jst,njsc(ji),deltahum(ji)-diff(ji)
WRITE (numout,*)'tmc,tmcold,diff',tmc(ji,jst),tmcold(ji),deltahum(ji)
WRITE (numout,*)'evapot,evapot_penm,ae_ns',evapot(ji),evapot_penm(ji),ae_ns(ji,jst)
WRITE (numout,*)'flux,ru_ns,qdrain,tsink,q0,precisol',flux(ji),ru_ns(ji,jst), &
& dr_ns(ji,jst),tsink(ji),qflux00(ji,jst),precisol_ns(ji,jst)
WRITE (numout,*)'water2infilt',water2infilt(ji,jst)
WRITE (numout,*)'soiltile',soiltile(ji,jst)
WRITE (numout,*)'irrigation, returnflow, reinfiltration', &
& irrigation_soil(ji),returnflow_soil(ji),reinfiltration_soil(ji)
WRITE (numout,*)'mc',mc(ji,:,jst)
WRITE (numout,*)'qflux',qflux(ji,:,jst)
WRITE (numout,*)'veget', veget(ji,:)
WRITE (numout,*)'k', k(ji,:)
waterbal_error=.TRUE.
CALL ipslerr(2, 'hydrol_soil', 'We will STOP after hydrol_waterbal.',&
& 'CWRR water balance check','')
ENDIF
ENDDO
DO ji = 1,kjpindex
IF(MINVAL(mc(ji,:,jst)).LT.-min_sechiba) THEN
WRITE (numout,*)'CWRR MC NEGATIVE', &
& ji,lalo(ji,:),MINLOC(mc(ji,:,jst)),jst,mc(ji,:,jst)
WRITE (numout,*)'evapot,evapot_penm,ae_ns',evapot(ji),evapot_penm(ji),ae_ns(ji,jst)
WRITE (numout,*)'flux,ru_ns,qdrain,tsink,q0,precisol',flux(ji),ru_ns(ji,jst), &
& dr_ns(ji,jst),tsink(ji),qflux00(ji,jst),precisol_ns(ji,jst)
WRITE (numout,*)'water2infilt',water2infilt(ji,jst)
WRITE (numout,*)'soiltile',soiltile(ji,jst)
WRITE (numout,*)'irrigation, returnflow, reinfiltration', &
& irrigation_soil(ji),returnflow_soil(ji),reinfiltration_soil(ji)
WRITE (numout,*)'mc',mc(ji,:,jst)
WRITE (numout,*)'qflux',qflux(ji,:,jst)
WRITE (numout,*)'veget', veget(ji,:)
WRITE (numout,*)'k', k(ji,:)
WRITE (numout,*)'soiltile',soiltile(ji,jst)
waterbal_error=.TRUE.
CALL ipslerr(2, 'hydrol_soil', 'We will STOP after hydrol_waterbal.',&
& 'CWRR MC NEGATIVE','')
ENDIF
END DO
DO ji=1,kjpindex
IF (ru_ns(ji,jst)*soiltile(ji,jst).LT.-min_sechiba) THEN
WRITE (numout,*) 'Negative runoff', ji,jst, mask_soiltile(ji,jst)
WRITE (numout,*) 'mc1, mc2', mc(ji,1,jst), mc(ji,2,jst)
WRITE (numout,*) 'mcint1, mcint2', mcint(ji,1), mcint(ji,2)
WRITE (numout,*) 'qflux1, flux', qflux(ji,nslm,jst), flux(ji)
WRITE (numout,*) 'over_mcs, under_mcr, test', &
& over_mcs(ji), under_mcr(ji), tmc(ji,jst)-tmcint(ji)+qflux(ji,nslm,jst)+SUM(rootsink(ji,:,jst))
WRITE (numout,*) 'mc', mc(ji,:,jst)
WRITE (numout,*) 'mcint', mcint(ji,:)
WRITE (numout,*) 'qflux', qflux(ji,:,jst)
WRITE (numout,*) 'rootsink1,evapot_penm,vegtot', rootsink(ji,1,jst), evapot_penm(ji), vegtot(ji)
WRITE (numout,*) 'ae_ns, tsink, returnflow, reinfiltration, precisol_ns, irrigation, qflux0, ru_ns', &
& ae_ns(ji,jst), tsink(ji), returnflow_soil(ji), reinfiltration_soil(ji), &
& precisol_ns(ji,jst), irrigation_soil(ji), qflux00(ji,jst), ru_ns(ji,jst)
waterbal_error=.TRUE.
CALL ipslerr(2, 'hydrol_soil', 'We will STOP after hydrol_waterbal.',&
& 'Negative runoff, non-saturated soil','')
ENDIF
ENDDO
ENDIF
IF (long_print) WRITE (numout,*) ' hydrol_soil done for jst =', jst
END DO ! end of loop on soiltile
!
! sum 3d variables into 2d variables
!
CALL hydrol_diag_soil (kjpindex, veget, soiltile, njsc, runoff, drainage, &
& evap_bare_lim, evapot, vevapnu, returnflow, reinfiltration, irrigation, &
& shumdiag, k_litt, litterhumdiag, humrel, vegstress, drysoil_frac,tot_melt)
RETURN
END SUBROUTINE hydrol_soil
SUBROUTINE hydrol_soil_infilt(kjpindex, ins, dtradia, njsc, flux_infilt, over_mcs)
! GLOBAL (in or inout)
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: njsc !! Indeces of the soiltile
REAL(r_std), DIMENSION (kjpindex), INTENT (in) :: flux_infilt !! Water to infiltrate
REAL(r_std), DIMENSION (kjpindex), INTENT (inout) :: over_mcs !! Over saturation
! LOCAL DECLARATIONS
INTEGER(i_std) :: ji, jv, jsl, ins, i !! Indeces
REAL(r_std) :: m !!
REAL(r_std), DIMENSION (kjpindex) :: wat_inf_pot !! infiltrable water in the layer
REAL(r_std), DIMENSION (kjpindex) :: wat_inf !! infiltrated water in the layer
REAL(r_std), DIMENSION (kjpindex) :: dt_tmp !! time remaining before the end of the time step
REAL(r_std) :: dt_inf !! the time it takes to complete the infiltration in the layer
REAL(r_std) :: k_m !! the mean conductivity used for the saturated front
REAL(r_std) :: infilt_tmp !! infiltration rate for the considered layer
REAL(r_std), DIMENSION (kjpindex) :: infilt_tot !! total infiltration
REAL(r_std), DIMENSION (kjpindex) :: flux_tmp !! rate at which precip hits the ground
! If data (or coupling with GCM) was available, a parameterization for subgrid rainfall could be performed
DO ji = 1, kjpindex
!-
!- 1. First layer
!-
! First we fill up the first layer (about 1mm) without any resistance and quasi-immediately
wat_inf_pot(ji) = (mcs(njsc(ji))-mc(ji,1,ins)) * dz(2,ins) / deux
wat_inf(ji) = MIN(wat_inf_pot(ji), flux_infilt(ji))
mc(ji,1,ins) = mc(ji,1,ins) + wat_inf(ji) * deux / dz(2,ins)
ENDDO
!-
!- 2. Infiltration layer by layer
!-
! Initialize a countdown for infiltration during the time-step and the value of potential runoff
dt_tmp(:) = dtradia / one_day
infilt_tot(:) = zero
! Compute the rate at which water will try to infiltrate each layer
flux_tmp(:) = (flux_infilt(:)-wat_inf(:)) / dt_tmp(:)
DO jsl = 2, nslm-1
DO ji = 1, kjpindex
! Infiltrability of each layer if under a saturated one
! This is computed by an simple arithmetic average because
! the time step (30min) is not appropriate for a geometric average (advised by Haverkamp and Vauclin)
k_m = (k(ji,jsl) + ks(njsc(ji))*kfact(jsl-1,njsc(ji))*kfact_root(ji,jsl,ins)) / deux
!- We compute the mean rate at which water actually infiltrate:
!- Subgrid: Exponential distribution of k around i_m, but average p directly used
infilt_tmp = k_m * (un - EXP(- flux_tmp(ji) / k_m))
! From which we deduce the time it takes to fill up the layer or to end the time step...
wat_inf_pot(ji) = (mcs(njsc(ji))-mc(ji,jsl,ins)) * (dz(jsl,ins) + dz(jsl+1,ins)) / deux
dt_inf = MIN(wat_inf_pot(ji) / (infilt_tmp + min_sechiba), dt_tmp(ji))
! ...and the water that enters the layer...
wat_inf(ji) = dt_inf * (infilt_tmp)
! ...obviously the moisture content...
mc(ji,jsl,ins) = mc(ji,jsl,ins) + &
& wat_inf(ji) * deux / (dz(jsl,ins) + dz(jsl+1,ins))
! ...the time remaining before the next time step
dt_tmp(ji) = dt_tmp(ji) - dt_inf
! ...and finally the infilt_tot (which is just used to check if there is a problem, below)
infilt_tot(ji) = infilt_tot(ji) + infilt_tmp * dt_inf
ENDDO
ENDDO
! Register the cases where the soil is saturated
DO ji = 1, kjpindex
IF (dt_tmp(ji) .GT. min_sechiba .AND. flux_tmp(ji) .GT. min_sechiba) THEN
over_mcs(ji) = over_mcs(ji) + dt_tmp(ji) * flux_tmp(ji)
ENDIF
ENDDO
DO ji = 1, kjpindex
IF (infilt_tot(ji) .LT. -min_sechiba .OR. infilt_tot(ji) .GT. flux_infilt(ji) + min_sechiba) THEN
WRITE (numout,*) 'Error in the calculation of infilt tot', infilt_tot(ji)
WRITE (numout,*) 'k, ji, jst, mc', k(ji,1:2), ji, ins, mc(ji,1,ins)
waterbal_error=.TRUE.
CALL ipslerr(3, 'hydrol_soil_infilt', 'We will STOP after hydrol_soil_infilt.','','')
ENDIF
ENDDO
RETURN
END SUBROUTINE hydrol_soil_infilt
SUBROUTINE hydrol_soil_smooth(kjpindex, ins, njsc, under_mcr, over_mcs)
!- smooth soil moisture values:
!- avoid over-saturation or under-residual values
!- arguments
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std), INTENT(in) :: ins !! number of soil type
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: njsc !! Indeces of the soiltile
REAL(r_std), DIMENSION(kjpindex), INTENT(out) :: under_mcr !! Allows under residual soil moisture due to evap
REAL(r_std), DIMENSION(kjpindex), INTENT(out) :: over_mcs !! Allows over saturated soil moisture due to returnflow
! -- variables locales
INTEGER(i_std) :: ji,jsl
REAL(r_std) :: excess
!-
!- Avoid over-saturation values
!-
!- in case of over-saturation we put the water where it is possible
DO jsl = 1, nslm-2
DO ji=1, kjpindex
excess = MAX(mc(ji,jsl,ins)-mcs(njsc(ji)),zero)
mc(ji,jsl,ins) = mc(ji,jsl,ins) - excess
mc(ji,jsl+1,ins) = mc(ji,jsl+1,ins) + excess * &
& (dz(jsl,ins)+dz(jsl+1,ins))/(dz(jsl+1,ins)+dz(jsl+2,ins))
ENDDO
ENDDO
jsl = nslm-1
DO ji=1, kjpindex
excess = MAX(mc(ji,jsl,ins)-mcs(njsc(ji)),zero)
mc(ji,jsl,ins) = mc(ji,jsl,ins) - excess
mc(ji,jsl+1,ins) = mc(ji,jsl+1,ins) + excess * &
& (dz(jsl,ins)+dz(jsl+1,ins))/dz(jsl+1,ins)
ENDDO
jsl = nslm
DO ji=1, kjpindex
excess = MAX(mc(ji,jsl,ins)-mcs(njsc(ji)),zero)
mc(ji,jsl,ins) = mc(ji,jsl,ins) - excess
mc(ji,jsl-1,ins) = mc(ji,jsl-1,ins) + excess * &
& dz(jsl,ins)/(dz(jsl-1,ins)+dz(jsl,ins))
ENDDO
DO jsl = nslm-1,2,-1
DO ji=1, kjpindex
excess = MAX(mc(ji,jsl,ins)-mcs(njsc(ji)),zero)
mc(ji,jsl,ins) = mc(ji,jsl,ins) - excess
mc(ji,jsl-1,ins) = mc(ji,jsl-1,ins) + excess * &
& (dz(jsl,ins)+dz(jsl+1,ins))/(dz(jsl-1,ins)+dz(jsl,ins))
ENDDO
ENDDO
DO ji=1, kjpindex
excess = mask_soiltile(ji,ins) * MAX(mc(ji,1,ins)-mcs(njsc(ji)),zero)
mc(ji,1,ins) = mc(ji,1,ins) - excess
over_mcs(ji) = excess * dz(2,ins)/2
ENDDO
!-
!- Avoid below residual values
!-
! Smooth the profile to avoid negative values of punctual soil moisture
DO jsl = 1,nslm-2
DO ji=1, kjpindex
excess = MAX(mcr(njsc(ji))-mc(ji,jsl,ins),zero)
mc(ji,jsl,ins) = mc(ji,jsl,ins) + excess
mc(ji,jsl+1,ins) = mc(ji,jsl+1,ins) - excess * &
& (dz(jsl,ins)+dz(jsl+1,ins))/(dz(jsl+1,ins)+dz(jsl+2,ins))
ENDDO
ENDDO
jsl = nslm-1
DO ji=1, kjpindex
excess = MAX(mcr(njsc(ji))-mc(ji,jsl,ins),zero)
mc(ji,jsl,ins) = mc(ji,jsl,ins) + excess
mc(ji,jsl+1,ins) = mc(ji,jsl+1,ins) - excess * &
& (dz(jsl,ins)+dz(jsl+1,ins))/dz(jsl+1,ins)
ENDDO
jsl = nslm
DO ji=1, kjpindex
excess = MAX(mcr(njsc(ji))-mc(ji,jsl,ins),zero)
mc(ji,jsl,ins) = mc(ji,jsl,ins) + excess
mc(ji,jsl-1,ins) = mc(ji,jsl-1,ins) - excess * &
& dz(jsl,ins)/(dz(jsl-1,ins)+dz(jsl,ins))
ENDDO
DO jsl = nslm-1,2,-1
DO ji=1, kjpindex
excess = MAX(mcr(njsc(ji))-mc(ji,jsl,ins),zero)
mc(ji,jsl,ins) = mc(ji,jsl,ins) + excess
mc(ji,jsl-1,ins) = mc(ji,jsl-1,ins) - excess * &
& (dz(jsl,ins)+dz(jsl+1,ins))/(dz(jsl-1,ins)+dz(jsl,ins))
ENDDO
ENDDO
DO ji=1, kjpindex
excess = mask_soiltile(ji,ins) * MAX(mcr(njsc(ji))-mc(ji,1,ins),zero)
mc(ji,1,ins) = mc(ji,1,ins) + excess
! Keep the value in case excess is still positive (due to big change in evapot)
under_mcr(ji) = excess * dz(2,ins)/2
ENDDO
! We just get sure that mc remains at 0 where soiltile=0
DO jsl = 1, nslm
DO ji=1, kjpindex
mc(ji,jsl,ins) = mask_soiltile(ji,ins) * mc(ji,jsl,ins)
ENDDO
ENDDO
RETURN
END SUBROUTINE hydrol_soil_smooth
SUBROUTINE hydrol_soil_flux(kjpindex,ins,mcint,returnflow_soil)
!
!**** *hydrol_soil_flux* -
!**** *routine that computes the hydrological fluxes between the different soil layer.
!
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std), INTENT(in) :: ins !! index of soil type
REAL(r_std), DIMENSION (kjpindex,nslm), INTENT(in) :: mcint !! mc values at the beginning of the time step
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: returnflow_soil !! returnflow
! local
INTEGER(i_std) :: jsl,ji
REAL(r_std), DIMENSION(kjpindex) :: temp
!- Compute the flux at every level from bottom to top (using mc and sink values)
DO ji = 1, kjpindex
!- First initialize qflux from the bottom, with dr_ns
jsl = nslm
qflux(ji,jsl,ins) = dr_ns(ji,ins) - returnflow_soil(ji)
jsl = nslm-1
qflux(ji,jsl,ins) = qflux(ji,jsl+1,ins) &
& + (mc(ji,jsl,ins)-mcint(ji,jsl) &
& + trois*mc(ji,jsl+1,ins) - trois*mcint(ji,jsl+1)) &
& * (dz(jsl+1,ins)/huit) &
& + rootsink(ji,jsl+1,ins)
ENDDO
DO jsl = nslm-2,1,-1
DO ji = 1, kjpindex
qflux(ji,jsl,ins) = qflux(ji,jsl+1,ins) &
& + (mc(ji,jsl,ins)-mcint(ji,jsl) &
& + trois*mc(ji,jsl+1,ins) - trois*mcint(ji,jsl+1)) &
& * (dz(jsl+1,ins)/huit) &
& + rootsink(ji,jsl+1,ins) &
& + (dz(jsl+2,ins)/huit) &
& * (trois*mc(ji,jsl+1,ins) - trois*mcint(ji,jsl+1) &
& + mc(ji,jsl+2,ins)-mcint(ji,jsl+2))
END DO
ENDDO
DO ji = 1, kjpindex
temp(ji) = qflux(ji,1,ins) + (dz(2,ins)/huit) &
& * (trois* (mc(ji,1,ins)-mcint(ji,1)) + (mc(ji,2,ins)-mcint(ji,2))) &
& + rootsink(ji,1,ins)
ENDDO
DO ji = 1, kjpindex
IF (ABS(qflux00(ji,ins)-temp(ji)).GT. deux*min_sechiba) THEN
WRITE (numout,*) 'Problem in the water balance, qflux computation', qflux00(ji,ins),temp(ji)
WRITE (numout,*) 'returnflow_soil', returnflow_soil(ji)
WRITE(numout,*) 'ji', ji, 'jsl',jsl,'ins',ins
WRITE(numout,*) 'mcint', mcint(ji,:)
WRITE(numout,*) 'mc', mc(ji,:,ins)
WRITE (numout,*) 'rootsink', rootsink(ji,1,ins)
waterbal_error=.TRUE.
CALL ipslerr(3, 'hydrol_soil_flux', 'We will STOP after hydrol_soil_flux.',&
& 'Problem in the water balance, qflux computation','')
ENDIF
ENDDO
RETURN
END SUBROUTINE hydrol_soil_flux
SUBROUTINE hydrol_soil_tridiag(kjpindex,ins)
!- solves a set of linear equations which has a tridiagonal
!- coefficient matrix.
!- arguments
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std), INTENT(in) :: ins !! number of soil type
! -- variables locales
INTEGER(i_std) :: ji,jt,jsl
REAL(r_std), DIMENSION(kjpindex) :: bet
DO ji = 1, kjpindex
IF (resolv(ji)) THEN
bet(ji) = tmat(ji,1,2)
mc(ji,1,ins) = rhs(ji,1)/bet(ji)
ENDIF
ENDDO
DO jsl = 2,nslm
DO ji = 1, kjpindex
IF (resolv(ji)) THEN
gam(ji,jsl) = tmat(ji,jsl-1,3)/bet(ji)
bet(ji) = tmat(ji,jsl,2) - tmat(ji,jsl,1)*gam(ji,jsl)
mc(ji,jsl,ins) = (rhs(ji,jsl)-tmat(ji,jsl,1)*mc(ji,jsl-1,ins))/bet(ji)
ENDIF
ENDDO
ENDDO
DO ji = 1, kjpindex
IF (resolv(ji)) THEN
DO jsl = nslm-1,1,-1
mc(ji,jsl,ins) = mc(ji,jsl,ins) - gam(ji,jsl+1)*mc(ji,jsl+1,ins)
ENDDO
ENDIF
ENDDO
RETURN
END SUBROUTINE hydrol_soil_tridiag
SUBROUTINE hydrol_soil_coef(kjpindex,ins,njsc)
!
!**** *hydrol_soil_coef* -
!**** *computes coef for the linearised hydraulic conductivity k_lin=a_lin mc_lin+b_lin
!**** *and the linearised diffusivity d_lin
!
IMPLICIT NONE
!
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std), INTENT(in) :: ins ! index of soil type
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: njsc !! Indeces of the soiltype
! local
INTEGER(i_std) :: jsl,ji,i
!-first, we identify the interval i in which the current value of mc is located
!-then, we give the values of the linearized parameters to compute
! conductivity and diffusivity as K=a*mc+b and d
DO jsl=1,nslm
DO ji=1,kjpindex
i= MAX(MIN(INT((imax-imin)*(mc(ji,jsl,ins)-mcr(njsc(ji))) &
& / (mcs(njsc(ji))-mcr(njsc(ji))))+imin , imax-1), imin)
a(ji,jsl) = a_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins)
b(ji,jsl) = b_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins)
d(ji,jsl) = d_lin(i,jsl,njsc(ji)) * kfact_root(ji,jsl,ins)
k(ji,jsl) = MAX(k_lin(imin+1,jsl,njsc(ji)), &
& a_lin(i,jsl,njsc(ji)) * mc(ji,jsl,ins) + b_lin(i,jsl,njsc(ji)))
ENDDO ! loop on grid
ENDDO
RETURN
END SUBROUTINE hydrol_soil_coef
SUBROUTINE hydrol_soil_setup(kjpindex,ins,dtradia)
!
!**** *hydrol_soil_setup* -
!**** *routine that computes the matrix coef for dublin model.
IMPLICIT NONE
!
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
! parameters
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std), INTENT(in) :: ins ! index of soil type
! local
INTEGER(i_std) :: jsl,ji,i
REAL(r_std), DIMENSION (nslm) :: temp0, temp5, temp6, temp7
REAL(r_std) :: temp3, temp4
!-we compute tridiag matrix coefficients (LEFT and RIGHT)
! of the system to solve [LEFT]*mc_{t+1}=[RIGHT]*mc{t}+[add terms]:
! e(nslm),f(nslm),g1(nslm) for the [left] vector
! and ep(nslm),fp(nslm),gp(nslm) for the [right] vector
! w_time=1 (in constantes_soil) indicates implicit computation for diffusion
temp3 = w_time*(dtradia/one_day)/deux
temp4 = (un-w_time)*(dtradia/one_day)/deux
!- coefficient for first layer
DO ji = 1, kjpindex
e(ji,1) = zero
f(ji,1) = trois * dz(2,ins)/huit + temp3 &
& * deux*SQRT(d(ji,1)*d(ji,2))/(dz(2,ins))
g1(ji,1) = dz(2,ins)/(huit) - temp3 &
& * deux*SQRT(d(ji,1)*d(ji,2))/(dz(2,ins))
ep(ji,1) = zero
fp(ji,1) = trois * dz(2,ins)/huit - temp4 &
& * deux*SQRT(d(ji,1)*d(ji,2))/(dz(2,ins))
gp(ji,1) = dz(2,ins)/(huit) + temp4 &
& * deux*SQRT(d(ji,1)*d(ji,2))/(dz(2,ins))
ENDDO
!- coefficient for medium layers
DO jsl = 2, nslm-1
DO ji = 1, kjpindex
e(ji,jsl) = dz(jsl,ins)/(huit) - temp3 &
& * deux*SQRT(d(ji,jsl)*d(ji,jsl-1))/(dz(jsl,ins))
f(ji,jsl) = trois * (dz(jsl,ins)+dz(jsl+1,ins))/huit + temp3 &
& * ( deux*SQRT(d(ji,jsl)*d(ji,jsl-1))/(dz(jsl,ins)) + &
& deux*SQRT(d(ji,jsl)*d(ji,jsl+1))/(dz(jsl+1,ins)) )
g1(ji,jsl) = dz(jsl+1,ins)/(huit) - temp3 &
& * deux*SQRT(d(ji,jsl)*d(ji,jsl+1))/(dz(jsl+1,ins))
ep(ji,jsl) = dz(jsl,ins)/(huit) + temp4 &
& * deux*SQRT(d(ji,jsl)*d(ji,jsl-1))/(dz(jsl,ins))
fp(ji,jsl) = trois * (dz(jsl,ins)+dz(jsl+1,ins))/huit - temp4 &
& * ( deux*SQRT(d(ji,jsl)*d(ji,jsl-1))/(dz(jsl,ins)) + &
& deux*SQRT(d(ji,jsl)*d(ji,jsl+1))/(dz(jsl+1,ins)) )
gp(ji,jsl) = dz(jsl+1,ins)/(huit) + temp4 &
& * deux*SQRT(d(ji,jsl)*d(ji,jsl+1))/(dz(jsl+1,ins))
ENDDO
ENDDO
!- coefficient for last layer
DO ji = 1, kjpindex
e(ji,nslm) = dz(nslm,ins)/(huit) - temp3 &
& * deux*SQRT(d(ji,nslm)*d(ji,nslm-1)) / (dz(nslm,ins))
f(ji,nslm) = trois * dz(nslm,ins)/huit + temp3 &
& * deux*SQRT(d(ji,nslm)*d(ji,nslm-1)) / (dz(nslm,ins))
g1(ji,nslm) = zero
ep(ji,nslm) = dz(nslm,ins)/(huit) + temp4 &
& * deux*SQRT(d(ji,nslm)*d(ji,nslm-1)) / (dz(nslm,ins))
fp(ji,nslm) = trois * dz(nslm,ins)/huit - temp4 &
& * deux*SQRT(d(ji,nslm)*d(ji,nslm-1)) / (dz(nslm,ins))
gp(ji,nslm) = zero
ENDDO
RETURN
END SUBROUTINE hydrol_soil_setup
!!! fait la connexion entre l'hydrologie et sechiba :
!!! cherche les variables sechiba pour l'hydrologie
!!! "transforme" ces variables
SUBROUTINE hydrol_split_soil (kjpindex, veget, soiltile, vevapnu, transpir, humrel,evap_bare_lim)
!
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in) :: veget !! Vegetation map
REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile !! Map of soil types
REAL(r_std), DIMENSION (kjpindex), INTENT (in) :: vevapnu !! Bare soil evaporation
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in) :: transpir !! Transpiration
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in) :: humrel !! Relative humidity
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: evap_bare_lim !!
!
! local declaration
!
INTEGER(i_std) :: ji, jv, jsl, jst
REAL(r_std), Dimension (kjpindex) :: vevapnu_old
REAL(r_std), Dimension (kjpindex) :: tmp_check1
REAL(r_std), Dimension (kjpindex) :: tmp_check2
REAL(r_std), DIMENSION (kjpindex,nstm) :: tmp_check3
REAL(r_std) :: test
!
!
! split 2d variables into 3d variables, per soil type
!
precisol_ns(:,:)=zero
DO jv=1,nvm
DO jst=1,nstm
DO ji=1,kjpindex
IF(veget(ji,jv).GT.min_sechiba) THEN
precisol_ns(ji,jst)=precisol_ns(ji,jst)+precisol(ji,jv)* &
& corr_veg_soil(ji,jv,jst) /vegtot(ji) / veget(ji,jv)
ENDIF
END DO
END DO
END DO
!
!
!
vevapnu_old(:)=zero
DO jst=1,nstm
DO ji=1,kjpindex
vevapnu_old(ji)=vevapnu_old(ji)+ &
& ae_ns(ji,jst)*soiltile(ji,jst)*vegtot(ji)
END DO
END DO
!
!
!
DO jst=1,nstm
DO ji=1,kjpindex
IF (vevapnu_old(ji).GT.min_sechiba) THEN
IF(evap_bare_lim(ji).GT.min_sechiba) THEN
ae_ns(ji,jst) = vevapnu(ji) * evap_bare_lim_ns(ji,jst)/evap_bare_lim(ji)
ELSE
ae_ns(ji,jst)=ae_ns(ji,jst) * vevapnu(ji)/vevapnu_old(ji)
ENDIF
ELSEIF(frac_bare_ns(ji,jst).GT.min_sechiba) THEN
IF(evap_bare_lim(ji).GT.min_sechiba) THEN
ae_ns(ji,jst) = vevapnu(ji) * evap_bare_lim_ns(ji,jst)/evap_bare_lim(ji)
ELSE
!!$ WRITE(numout,*) "ji,jst ",ji,jst," frac_bare_ns,tot_frac_bare",&
!!$ frac_bare_ns(ji,jst),tot_frac_bare(ji)
ae_ns(ji,jst) = vevapnu(ji) * frac_bare_ns(ji,jst)/tot_frac_bare(ji)
ENDIF
!!$ ELSE
!!$ WRITE(numout,*) "Rien a faire pour ji,jst : ",ji,jst
ENDIF
precisol_ns(ji,jst)=precisol_ns(ji,jst)+MAX(-ae_ns(ji,jst),zero)
END DO
END DO
tr_ns(:,:)=zero
DO jv=1,nvm
DO jst=1,nstm
DO ji=1,kjpindex
IF (humrel(ji,jv).GT.min_sechiba) THEN
tr_ns(ji,jst)=tr_ns(ji,jst)+ cvs_over_veg(ji,jv,jst)*humrelv(ji,jv,jst)* &
& transpir(ji,jv)/humrel(ji,jv)
ENDIF
END DO
END DO
END DO
rootsink(:,:,:)=zero
DO jv=1,nvm
DO jsl=1,nslm
DO jst=1,nstm
DO ji=1,kjpindex
IF (humrel(ji,jv).GT.min_sechiba) THEN
rootsink(ji,jsl,jst) = rootsink(ji,jsl,jst) &
& + cvs_over_veg(ji,jv,jst)* (transpir(ji,jv)*us(ji,jv,jst,jsl))/ &
& humrel(ji,jv)
END IF
END DO
END DO
END DO
END DO
IF(check_cwrr) THEN
DO jsl=1,nslm
DO jst=1,nstm
DO ji=1,kjpindex
IF(mc(ji,jsl,jst).LT.-0.05) THEN
! IF(kjit_.LT.2.OR.kjit_.GT.1484) THEN
WRITE(numout,*) 'CWRR split-----------------------------------------------'
WRITE(numout,*) 'ji,jst,jsl',ji,jst,jsl
WRITE(numout,*) 'mc',mc(ji,jsl,jst)
WRITE(numout,*) 'rootsink,us',rootsink(ji,:,jst),us(ji,:,jst,jsl)
WRITE(numout,*) 'corr_veg_soil',corr_veg_soil(ji,:,jst)
WRITE(numout,*) 'transpir',transpir(ji,:)
WRITE(numout,*) 'veget',veget(ji,:)
WRITE(numout,*) 'cvs_over_veg',cvs_over_veg(ji,:,jst)
WRITE(numout,*) 'humrel',humrel(ji,:)
WRITE(numout,*) 'humrelv (pour ce jst)',humrelv(ji,:,jst)
WRITE(numout,*) 'ae_ns',ae_ns(ji,jst)
WRITE(numout,*) 'tr_ns',tr_ns(ji,jst)
WRITE(numout,*) 'vevapnuold',vevapnu_old(ji)
ENDIF
END DO
END DO
END DO
ENDIF
! Now we check if the deconvolution is correct and conserves the fluxes:
IF (check_cwrr) THEN
tmp_check1(:)=zero
tmp_check2(:)=zero
! First we check the precisol and evapnu
DO jst=1,nstm
DO ji=1,kjpindex
tmp_check1(ji)=tmp_check1(ji) + &
& (precisol_ns(ji,jst)-MAX(-ae_ns(ji,jst),zero))* &
& soiltile(ji,jst)*vegtot(ji)
END DO
END DO
DO jv=1,nvm
DO ji=1,kjpindex
tmp_check2(ji)=tmp_check2(ji) + precisol(ji,jv)
!!$ tmp_check2(ji)=tmp_check2(ji) + precisol(ji,jv)*vegtot(ji)
END DO
END DO
DO ji=1,kjpindex
IF(ABS(tmp_check1(ji)- tmp_check2(ji)).GT.allowed_err) THEN
WRITE(numout,*) 'PRECISOL SPLIT FALSE:ji=',ji,tmp_check1(ji),tmp_check2(ji)
WRITE(numout,*) 'vegtot',vegtot(ji)
DO jv=1,nvm
WRITE(numout,*) 'jv,veget, precisol',jv,veget(ji,jv),precisol(ji,jv)
DO jst=1,nstm
WRITE(numout,*) 'corr_veg_soil:jst',jst,corr_veg_soil(ji,jv,jst)
END DO
END DO
DO jst=1,nstm
WRITE(numout,*) 'jst,precisol_ns',jst,precisol_ns(ji,jst)
WRITE(numout,*) 'soiltile', soiltile(ji,jst)
END DO
waterbal_error=.TRUE.
CALL ipslerr(2, 'hydrol_split_soil', 'We will STOP after hydrol_split_soil.',&
& 'check_CWRR','PRECISOL SPLIT FALSE')
ENDIF
END DO
tmp_check1(:)=zero
DO jst=1,nstm
DO ji=1,kjpindex
tmp_check1(ji)=tmp_check1(ji) + ae_ns(ji,jst)* &
& soiltile(ji,jst)*vegtot(ji)
END DO
END DO
DO ji=1,kjpindex
IF(ABS(tmp_check1(ji)- vevapnu(ji)).GT.allowed_err) THEN
WRITE(numout,*) 'VEVAPNU SPLIT FALSE:ji, Sum(ae_ns), vevapnu =',ji,tmp_check1(ji),vevapnu(ji)
WRITE(numout,*) 'ae_ns',ae_ns(ji,:)
WRITE(numout,*) 'vegtot',vegtot(ji)
WRITE(numout,*) 'evap_bare_lim, evap_bare_lim_ns',evap_bare_lim(ji), evap_bare_lim_ns(ji,:)
WRITE(numout,*) 'tot_frac_bare,frac_bare_ns',tot_frac_bare(ji),frac_bare_ns(ji,:)
WRITE(numout,*) 'vevapnu_old',vevapnu_old(ji)
DO jst=1,nstm
WRITE(numout,*) 'jst,ae_ns',jst,ae_ns(ji,jst)
WRITE(numout,*) 'soiltile', soiltile(ji,jst)
WRITE(numout,*) 'veget_exist/soiltile', veget(ji,:)/vegtot(ji)/soiltile(ji,jst)
WRITE(numout,*) "corr_veg_soil",corr_veg_soil(ji,:,jst)
END DO
waterbal_error=.TRUE.
CALL ipslerr(2, 'hydrol_split_soil', 'We will STOP after hydrol_split_soil.',&
& 'check_CWRR','VEVAPNU SPLIT FALSE')
ENDIF
ENDDO
! Second we check the transpiration and root sink
tmp_check1(:)=zero
tmp_check2(:)=zero
DO jst=1,nstm
DO ji=1,kjpindex
tmp_check1(ji)=tmp_check1(ji) + tr_ns(ji,jst)* &
& soiltile(ji,jst)*vegtot(ji)
END DO
END DO
DO jv=1,nvm
DO ji=1,kjpindex
tmp_check2(ji)=tmp_check2(ji) + transpir(ji,jv)
END DO
END DO
DO ji=1,kjpindex
IF(ABS(tmp_check1(ji)- tmp_check2(ji)).GT.allowed_err) THEN
WRITE(numout,*) 'TRANSPIR SPLIT FALSE:ji=',ji,tmp_check1(ji),tmp_check2(ji)
WRITE(numout,*) 'vegtot',vegtot(ji)
DO jv=1,nvm
WRITE(numout,*) 'jv,veget, transpir',jv,veget(ji,jv),transpir(ji,jv)
DO jst=1,nstm
WRITE(numout,*) 'corr_veg_soil:ji,jv,jst',ji,jv,jst,corr_veg_soil(ji,jv,jst)
END DO
END DO
DO jst=1,nstm
WRITE(numout,*) 'jst,tr_ns',jst,tr_ns(ji,jst)
WRITE(numout,*) 'soiltile', soiltile(ji,jst)
END DO
waterbal_error=.TRUE.
CALL ipslerr(2, 'hydrol_split_soil', 'We will STOP after hydrol_split_soil.',&
& 'check_CWRR','TRANSPIR SPLIT FALSE')
ENDIF
END DO
tmp_check3(:,:)=zero
DO jst=1,nstm
DO jsl=1,nslm
DO ji=1,kjpindex
tmp_check3(ji,jst)=tmp_check3(ji,jst) + rootsink(ji,jsl,jst)
END DO
END DO
ENDDO
DO jst=1,nstm
DO ji=1,kjpindex
IF(ABS(tmp_check3(ji,jst)- tr_ns(ji,jst)).GT.allowed_err) THEN
WRITE(numout,*) 'ROOTSINK SPLIT FALSE:ji,jst=', ji,jst,&
& tmp_check3(ji,jst),tr_ns(ji,jst)
WRITE(numout,*) 'HUMREL(jv=1:13)',humrel(ji,:)
WRITE(numout,*) 'TRANSPIR',transpir(ji,:)
DO jv=1,nvm
WRITE(numout,*) 'jv=',jv,'us=',us(ji,jv,jst,:)
ENDDO
waterbal_error=.TRUE.
CALL ipslerr(2, 'hydrol_split_soil', 'We will STOP after hydrol_split_soil.',&
& 'check_CWRR','ROOTSINK SPLIT FALSE')
ENDIF
END DO
END DO
ENDIF
RETURN
END SUBROUTINE hydrol_split_soil
SUBROUTINE hydrol_diag_soil (kjpindex, veget, soiltile, njsc, runoff, drainage, &
& evap_bare_lim, evapot, vevapnu, returnflow, reinfiltration, irrigation, &
& shumdiag, k_litt, litterhumdiag, humrel, vegstress, drysoil_frac, tot_melt)
!
! interface description
! input scalar
INTEGER(i_std), INTENT(in) :: kjpindex
REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Map of vegetation types
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: njsc !! Indeces of the soiltype
REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in) :: soiltile !! Map of soil types
REAL(r_std), DIMENSION (kjpindex), INTENT (out) :: drysoil_frac !! Function of litter wetness
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: runoff !! complete runoff
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: drainage !! Drainage
REAL(r_std), DIMENSION (kjpindex), INTENT(out) :: evap_bare_lim !!
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: evapot !!
REAL(r_std), DIMENSION (kjpindex), INTENT(inout) :: vevapnu
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: returnflow !! Water returning to the deep reservoir
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: reinfiltration !! Water returning to the top of the soil
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: irrigation !! Water from irrigation
REAL(r_std), DIMENSION (kjpindex), INTENT(in) :: tot_melt
REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out) :: shumdiag !! relative soil moisture
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: k_litt !! litter cond.
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: litterhumdiag !! litter humidity
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: humrel !! Relative humidity
REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out) :: vegstress !! Veg. moisture stress (only for vegetation growth)
!
! local declaration
!
INTEGER(i_std) :: ji, jv, jsl, jst, i
REAL(r_std), DIMENSION (kjpindex) :: mask_vegtot
!
! Put the prognostics variables of soil to zero if soiltype is zero
DO jst=1,nstm
DO ji=1,kjpindex
! IF(soiltile(ji,jst).EQ.zero) THEN
ae_ns(ji,jst) = ae_ns(ji,jst) * mask_soiltile(ji,jst)
dr_ns(ji,jst) = dr_ns(ji,jst) * mask_soiltile(ji,jst)
ru_ns(ji,jst) = ru_ns(ji,jst) * mask_soiltile(ji,jst)
tmc(ji,jst) = tmc(ji,jst) * mask_soiltile(ji,jst)
DO jv=1,nvm
humrelv(ji,jv,jst) = humrelv(ji,jv,jst) * mask_soiltile(ji,jst)
DO jsl=1,nslm
us(ji,jv,jst,jsl) = us(ji,jv,jst,jsl) * mask_soiltile(ji,jst)
END DO
END DO
DO jsl=1,nslm
mc(ji,jsl,jst) = mc(ji,jsl,jst) * mask_soiltile(ji,jst)
END DO
! ENDIF
END DO
END DO
runoff(:) = zero
drainage(:) = zero
humtot(:) = zero
evap_bare_lim(:) = zero
evap_bare_lim_ns(:,:) = zero
shumdiag(:,:)= zero
k_litt(:) = zero
litterhumdiag(:) = zero
tmc_litt_mea(:) = zero
soilmoist(:,:) = zero
humrel(:,:) = zero
vegstress(:,:) = zero
swi(:) = zero
!
! sum 3d variables in 2d variables with fraction of vegetation per soil type
!
DO ji = 1, kjpindex
mask_vegtot(ji) = 0
IF(vegtot(ji) .GT. min_sechiba) THEN
mask_vegtot(ji) = 1
ENDIF
END DO
DO ji = 1, kjpindex
! Here we weight ae_ns by the fraction of bare evaporating soil.
! This is given by frac_bare_ns, taking into account bare soil under vegetation
ae_ns(ji,:) = mask_vegtot(ji) * ae_ns(ji,:) * frac_bare_ns(ji,:)
END DO
DO jst = 1, nstm
DO ji = 1, kjpindex
drainage(ji) = mask_vegtot(ji) * (drainage(ji) + vegtot(ji)*soiltile(ji,jst) * dr_ns(ji,jst))
runoff(ji) = mask_vegtot(ji) * (runoff(ji) + vegtot(ji)*soiltile(ji,jst) * ru_ns(ji,jst)) &
& + (1 - mask_vegtot(ji)) * (tot_melt(ji) + irrigation(ji) + returnflow(ji) + reinfiltration(ji))
humtot(ji) = mask_vegtot(ji) * (humtot(ji) + soiltile(ji,jst) * tmc(ji,jst))
END DO
END DO
DO jst=1,nstm
DO ji=1,kjpindex
IF ((evapot(ji).GT.min_sechiba) .AND. &
& (tmc_litter(ji,jst).GT.(tmc_litter_wilt(ji,jst)))) THEN
evap_bare_lim_ns(ji,jst) = ae_ns(ji,jst) / evapot(ji)
ELSEIF((evapot(ji).GT.min_sechiba).AND. &
& (tmc_litter(ji,jst).GT.(tmc_litter_res(ji,jst)))) THEN
evap_bare_lim_ns(ji,jst) = (un/deux) * ae_ns(ji,jst) / evapot(ji)
END IF
END DO
END DO
DO ji = 1, kjpindex
evap_bare_lim(ji) = SUM(evap_bare_lim_ns(ji,:)*vegtot(ji)*soiltile(ji,:))
IF(evap_bare_lim(ji).GT.un + min_sechiba) THEN
print *,'CWRR DIAG EVAP_BARE_LIM TOO LARGE', ji, &
& evap_bare_lim(ji),evap_bare_lim_ns(ji,:)
ENDIF
ENDDO
! we add the excess of snow sublimation to vevapnu
DO ji = 1,kjpindex
vevapnu(ji) = vevapnu (ji) + subsinksoil(ji)*vegtot(ji)
END DO
DO jst=1,nstm
DO jv=1,nvm
DO ji=1,kjpindex
IF(veget(ji,jv).GT.min_sechiba) THEN
vegstress(ji,jv)=vegstress(ji,jv)+vegstressv(ji,jv,jst)*soiltile(ji,jst) &
& * corr_veg_soil(ji,jv,jst) *vegtot(ji)/veget(ji,jv)
vegstress(ji,jv)= MAX(vegstress(ji,jv),zero)
ENDIF
END DO
END DO
END DO
cvs_over_veg(:,:,:) = zero
DO jv=1,nvm
DO ji=1,kjpindex
IF(veget(ji,jv).GT.min_sechiba) THEN
DO jst=1,nstm
cvs_over_veg(ji,jv,jst) = corr_veg_soil(ji,jv,jst)/vegtot(ji) / veget(ji,jv)
ENDDO
ENDIF
END DO
END DO
DO jst=1,nstm
DO jv=1,nvm
DO ji=1,kjpindex
humrel(ji,jv)=humrel(ji,jv)+humrelv(ji,jv,jst)*soiltile(ji,jst) &
& * cvs_over_veg(ji,jv,jst)*vegtot(ji)
humrel(ji,jv)=MAX(humrel(ji,jv),zero)
END DO
END DO
END DO
DO jst=1,nstm
DO ji=1,kjpindex
! We compute here a mean k for the 'litter' used for reinfiltration from floodplains of ponds
i= MAX(MIN(INT((imax-imin)*(tmc_litter(ji,jst)-tmc_litter_res(ji,jst))&
& / (tmc_litter_sat(ji,jst)-tmc_litter_res(ji,jst)))+imin , imax-1), imin)
k_litt(ji) = k_litt(ji) + soiltile(ji,jst) * SQRT(k_lin(i,1,njsc(ji))*ks(njsc(ji)))
ENDDO
ENDDO
DO jst=1,nstm
DO ji=1,kjpindex
litterhumdiag(ji) = litterhumdiag(ji) + &
& soil_wet_litter(ji,jst) * soiltile(ji,jst)
tmc_litt_mea(ji) = tmc_litt_mea(ji) + &
& tmc_litter(ji,jst) * soiltile(ji,jst)
END DO
DO jsl=1,nbdl
DO ji=1,kjpindex
shumdiag(ji,jsl)= shumdiag(ji,jsl) + soil_wet(ji,jsl,jst) * &
& ((mcs(njsc(ji))-mcw(njsc(ji)))/(mcf(njsc(ji))-mcw(njsc(ji)))) * &
& soiltile(ji,jst)
soilmoist(ji,jsl)=soilmoist(ji,jsl)+mc(ji,jsl,jst)*soiltile(ji,jst)
! shumdiag(ji,jsl) = MAX(MIN(shumdiag(ji,jsl), un), zero)
END DO
END DO
END DO
! First we compute swi (ALMIP requirement) - we assume here that dz is independant of jst (jst=1)
jst=1
DO ji=1,kjpindex
swi(ji) = swi(ji) + shumdiag(ji,1) * (dz(2,jst))/(deux*dpu_max*mille)
DO jsl=2,nslm-1
swi(ji) = swi(ji) + shumdiag(ji,jsl) * (dz(jsl,jst)+dz(jsl+1,jst))/(deux*dpu_max*mille)
ENDDO
jsl = nslm
swi(ji) = swi(ji) + shumdiag(ji,jsl) * (dz(jsl,jst))/(deux*dpu_max*mille)
ENDDO
! For stomate we need shumdiag to be bounded by 0 and 1
!!$ DO jsl=1,nbdl
!!$ DO ji=1,kjpindex
!!$ shumdiag(ji,jsl) = MAX(MIN(shumdiag(ji,jsl), un), zero)
!!$ END DO
!!$ END DO
shumdiag(:,:) = MIN(shumdiag(:,:), un)
shumdiag(:,:) = MAX(shumdiag(:,:), zero)
DO ji=1,kjpindex
drysoil_frac(ji) = un + MAX( MIN( (tmc_litt_dry_mea(ji) - tmc_litt_mea(ji)) / &
& (tmc_litt_wet_mea(ji) - tmc_litt_dry_mea(ji)), zero), - un)
END DO
END SUBROUTINE hydrol_diag_soil
!!
!! This routines checks the water balance. First it gets the total
!! amount of water and then it compares the increments with the fluxes.
!! The computation is only done over the soil area as over glaciers (and lakes?)
!! we do not have water conservation.
!!
!! This verification does not make much sense in REAL*4 as the precision is the same as some
!! of the fluxes
!!
SUBROUTINE hydrol_waterbal (kjpindex, index, first_call, dtradia, veget, totfrac_nobio, &
& qsintveg, snow, snow_nobio, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, tot_melt, &
& vevapwet, transpir, vevapnu, vevapsno, vevapflo, floodout, runoff, drainage)
!
!
!
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
LOGICAL, INTENT (in) :: first_call !! At which time is this routine called ?
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
!
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: veget !! Fraction of vegetation type
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: totfrac_nobio!! Total fraction of continental ice+lakes+...
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintveg !! Water on vegetation due to interception
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: snow !! Snow mass [Kg/m^2]
REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio !!Ice water balance
!
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: returnflow !! Water to the bottom
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: reinfiltration !! Water to the top
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: irrigation !! Water from irrigation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: tot_melt !! Total melt
!
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: vevapwet !! Interception loss
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: transpir !! Transpiration
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vevapnu !! Bare soil evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vevapsno !! Snow evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: vevapflo !! Floodplains evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: floodout !! flow out of floodplains
REAL(r_std),DIMENSION (kjpindex), INTENT(in) :: runoff !! complete runoff
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: drainage !! Drainage
!
! LOCAL
!
INTEGER(i_std) :: ji
REAL(r_std) :: watveg, delta_water
!
!
!
IF ( first_call ) THEN
tot_water_beg(:) = zero
DO ji = 1, kjpindex
watveg = SUM(qsintveg(ji,:))
tot_water_beg(ji) = humtot(ji)*vegtot(ji) + watveg + snow(ji)&
& + SUM(snow_nobio(ji,:))
ENDDO
tot_water_end(:) = tot_water_beg(:)
tot_flux(:) = zero
RETURN
ENDIF
!
! Check the water balance
!
tot_water_end(:) = zero
tot_flux(:) = zero
!
DO ji = 1, kjpindex
!
! If the fraction of ice, lakes, etc. does not complement the vegetation fraction then we do not
! need to go any further
!
!MM this test with DGVM ??
IF ( ABS(un - (totfrac_nobio(ji) + vegtot(ji))) .GT. allowed_err ) THEN
WRITE(numout,*) 'HYDROL problem in vegetation or frac_nobio on point ', ji
WRITE(numout,*) 'totfrac_nobio : ', totfrac_nobio(ji)
WRITE(numout,*) 'vegetation fraction : ', vegtot(ji)
waterbal_error=.TRUE.
CALL ipslerr(2, 'hydrol_waterbal', 'We will STOP after hydrol_waterbal.','','')
ENDIF
ENDDO
IF ( .NOT. waterbal_error ) THEN
DO ji = 1, kjpindex
!
watveg = SUM(qsintveg(ji,:))
tot_water_end(ji) = humtot(ji)*vegtot(ji) + watveg + &
& snow(ji) + SUM(snow_nobio(ji,:))
!
tot_flux(ji) = precip_rain(ji) + precip_snow(ji) + irrigation (ji) - &
& SUM(vevapwet(ji,:)) - SUM(transpir(ji,:)) - vevapnu(ji) - vevapsno(ji) - vevapflo(ji) + &
& floodout(ji) - runoff(ji) - drainage(ji) + returnflow(ji) + reinfiltration(ji)
ENDDO
DO ji = 1, kjpindex
!
delta_water = tot_water_end(ji) - tot_water_beg(ji)
!
!
! Set some precision ! This is a wild guess and corresponds to what works on an IEEE machine
! under double precision (REAL*8).
!
!
IF ( ABS(delta_water-tot_flux(ji)) .GT. deux*allowed_err ) THEN
WRITE(numout,*) '------------------------------------------------------------------------- '
WRITE(numout,*) 'HYDROL does not conserve water. The erroneous point is : ', ji
WRITE(numout,*) 'Coord erroneous point', lalo(ji,:)
WRITE(numout,*) 'The error in mm/s is :', (delta_water-tot_flux(ji))/dtradia, ' and in mm/dt : ', &
& delta_water-tot_flux(ji)
WRITE(numout,*) 'delta_water : ', delta_water, ' tot_flux : ', tot_flux(ji)
WRITE(numout,*) 'Actual and allowed error : ', ABS(delta_water-tot_flux(ji)), allowed_err
WRITE(numout,*) 'vegtot : ', vegtot(ji)
WRITE(numout,*) 'precip_rain : ', precip_rain(ji)
WRITE(numout,*) 'precip_snow : ', precip_snow(ji)
WRITE(numout,*) 'Water from routing. Reinfiltration/returnflow/irrigation : ', reinfiltration(ji), &
& returnflow(ji),irrigation(ji)
WRITE(numout,*) 'Total water in soil humtot:', humtot(ji)
WRITE(numout,*) 'mc:' , mc(ji,:,:)
WRITE(numout,*) 'Water on vegetation watveg:', watveg
WRITE(numout,*) 'Snow mass snow:', snow(ji)
WRITE(numout,*) 'Snow mass on ice snow_nobio:', SUM(snow_nobio(ji,:))
WRITE(numout,*) 'Melt water tot_melt:', tot_melt(ji)
WRITE(numout,*) 'evapwet : ', vevapwet(ji,:)
WRITE(numout,*) 'transpir : ', transpir(ji,:)
WRITE(numout,*) 'evapnu, evapsno, evapflo: ', vevapnu(ji), vevapsno(ji), vevapflo(ji)
WRITE(numout,*) 'drainage,runoff,floodout : ', drainage(ji),runoff(ji),floodout(ji)
waterbal_error=.TRUE.
CALL ipslerr(2, 'hydrol_waterbal', 'We will STOP after hydrol_waterbal.','','')
ENDIF
!
ENDDO
!
! Transfer the total water amount at the end of the current timestep top the begining of the next one.
!
tot_water_beg = tot_water_end
!
ENDIF
END SUBROUTINE hydrol_waterbal
!
! This routine computes the changes in soil moisture and interception storage for the ALMA outputs
!
SUBROUTINE hydrol_alma (kjpindex, index, first_call, qsintveg, snow, snow_nobio, soilwet)
!
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
LOGICAL, INTENT (in) :: first_call !! At which time is this routine called ?
!
REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in) :: qsintveg !! Water on vegetation due to interception
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: snow !! Snow water equivalent
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: soilwet !! Soil wetness
REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: snow_nobio !! Water balance on ice, lakes, .. [Kg/m^2]
!
! LOCAL
!
INTEGER(i_std) :: ji
REAL(r_std) :: watveg
!
!
!
IF ( first_call ) THEN
tot_watveg_beg(:) = zero
tot_watsoil_beg(:) = zero
snow_beg(:) = zero
!
DO ji = 1, kjpindex
watveg = SUM(qsintveg(ji,:))
tot_watveg_beg(ji) = watveg
tot_watsoil_beg(ji) = humtot(ji)
snow_beg(ji) = snow(ji)+ SUM(snow_nobio(ji,:))
ENDDO
!
tot_watveg_end(:) = tot_watveg_beg(:)
tot_watsoil_end(:) = tot_watsoil_beg(:)
snow_end(:) = snow_beg(:)
RETURN
ENDIF
!
! Calculate the values for the end of the time step
!
tot_watveg_end(:) = zero
tot_watsoil_end(:) = zero
snow_end(:) = zero
delintercept(:) = zero
delsoilmoist(:) = zero
delswe(:) = zero
!
DO ji = 1, kjpindex
watveg = SUM(qsintveg(ji,:))
tot_watveg_end(ji) = watveg
tot_watsoil_end(ji) = humtot(ji)
snow_end(ji) = snow(ji)+ SUM(snow_nobio(ji,:))
!
delintercept(ji) = tot_watveg_end(ji) - tot_watveg_beg(ji)
delsoilmoist(ji) = tot_watsoil_end(ji) - tot_watsoil_beg(ji)
delswe(ji) = snow_end(ji) - snow_beg(ji)
!
!
ENDDO
!
!
! Transfer the total water amount at the end of the current timestep top the begining of the next one.
!
tot_watveg_beg = tot_watveg_end
tot_watsoil_beg = tot_watsoil_end
snow_beg(:) = snow_end(:)
!
DO ji = 1,kjpindex
soilwet(ji) = tot_watsoil_end(ji) / mx_eau_var(ji)
ENDDO
!
END SUBROUTINE hydrol_alma
!
!
END MODULE hydrol
ORCHIDEE/src_sechiba/sechiba.f90~ 0000754 0103600 0005670 00000215324 11205035470 016307 0 ustar acamlmd lmdjus !! This module computes continental processes SECHIBA
!!
!! See also this graph
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.37 $, $Date: 2007/06/12 19:55:02 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/sechiba.f90,v 1.37 2007/06/12 19:55:02 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE sechiba
! routines called : diffuco_main, enerbil_main, hydrolc_main, enrbil_fusion, condveg_main, thermosoil_main
!
USE ioipsl
!
! modules used :
USE constantes
USE constantes_veg
USE constantes_co2
USE diffuco
USE condveg
USE enerbil
USE hydrol
USE hydrolc
USE thermosoil
USE sechiba_io
USE slowproc
USE routing
! USE write_field_p, only : WriteFieldI_p
IMPLICIT NONE
! public routines :
! sechiba_main
! sechiba_clear
PRIVATE
PUBLIC sechiba_main,sechiba_clear
! Index arrays we need internaly
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexveg !! indexing array for the 3D fields of vegetation
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexnobio !! indexing array for the 3D fields of other surf(ice,lakes ...)
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexsoil !! indexing array for the 3D fields of soil types
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexgrnd !! indexing array for the 3D ground heat profiles
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexlayer !! indexing array for the 3D fields of soil layers
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexalb !! indexing array for the 2 fields of albedo
! three dimensions array allocated, computed, saved and got in sechiba module
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:):: assim_param !! min+max+opt temps, vcmax, vjmax for photosynthesis
! two dimensions array allocated, computed, saved and got in sechiba module
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: veget !! Fraction of vegetation type
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: height !! Vegetation Height (m)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: frac_bare !! Bare soil fraction for each tile
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: lai !! Surface foliaire
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: gpp !! STOMATE: GPP. gC/m**2 of total area
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: humrel !! Relative humidity
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vegstress !! Vegetation moisture stress (only for vegetation growth)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: soiltile !! Map of soil types, created in slowproc in the
!! order : silt, sand and clay.
!
! one dimension array allocated, computed and used in sechiba module and passed to other
! modules called
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: njsc !! Soilclass index
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vbeta1 !! Snow resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vbeta4 !! Bare soil resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vbeta5 !! Floodplains resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: soilcap !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: soilflx !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: temp_sol !! Soil temperature
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: qsurf !! near soil air moisture
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: flood_res !! flood reservoir estimate
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: flood_frac !! flooded fraction
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snow !! Snow mass [Kg/m^2]
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snow_age !! Snow age
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: drysoil_frac !! Fraction of visibly (albedo) Dry soil (Between 0 and 1)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: rsol !! resistance to bare soil evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: evap_bare_lim !! Bare soil stress
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: evapot !! Soil Potential Evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: evapot_corr !! Soil Potential Evaporation Correction (Milly 1992)
!MG
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: etm !! Maximum 'evapo'transpir (taking into account the vegetation resistance)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vevapflo !! Floodplains evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vevapsno !! Snow evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vevapnu !! Bare soil evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: t2mdiag !! 2 meter temperature
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_melt !! Total melt
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vbeta !! Resistance coefficient
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: valpha !! Resistance coefficient
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: fusion !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: rau !! Density
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: deadleaf_cover !! Fraction of soil covered by dead leaves
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: co2_flux !! CO2 flux (gC/m**2 of average ground/s)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: totfrac_nobio !! Total fraction of continental ice+lakes+cities+...
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: floodout !! Flow out of floodplains from hydrol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: runoff !! Surface runoff generated by hydrol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: drainage !! Deep drainage generated by hydrol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: returnflow !! Routed water which returns into the soil
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: reinfiltration !! Routed water which returns into the soil
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: irrigation !! irrigation going back into the soils
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: emis !! Surface emissivity
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: z0 !! Surface roughness
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: roughheight !! Effective height for roughness
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: reinf_slope !! slope coefficient (reinfiltration)
!
! Arrays which are diagnostics from the physical processes for
! for the biological processes. They are not saved in the restart file because at the first time step,
! they are recalculated. However, they must be saved in memory as they are in slowproc which is called
! before the modules which calculate them.
!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: shumdiag !! Relative soil moisture
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: k_litt !! litter cond.
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: litterhumdiag!! litter humidity
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: stempdiag !! Temperature which controls canopy evolution
! two dimensions array allocated, computed and used in sechiba module and passed to other
! modules called
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: qsintveg !! Water on vegetation due to interception
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vbeta2 !! Interception resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vbeta3 !! Vegetation resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vbetaco2 !! STOMATE: Vegetation resistance to CO2
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: cimean !! STOMATE: Mean ci
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vevapwet !! Interception
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: transpir !! Transpiration
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: qsintmax !! Maximum water on vegetation for interception
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: rveget !! Vegetation resistance
!MG
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: rstruct !! Vegetation structural resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: snow_nobio !! Water balance over other surface types (that is snow !)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: snow_nobio_age !! Snow age on other surface types
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: frac_nobio !! Fraction of continental ice, lakes, ...
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: albedo !! Surface albedo for visible and NIR
!
! variables used inside sechiba module : declaration and initialisation
!
LOGICAL, SAVE :: l_first_sechiba = .TRUE.!! Initialisation has to be done one time
CHARACTER(LEN=80) , SAVE :: file_ext !! Extention for I/O filename
CHARACTER(LEN=80) , SAVE :: var_name !! To store variables names for I/O
LOGICAL, SAVE :: river_routing !! Flag that decides if we route.
LOGICAL, SAVE :: hydrol_cwrr !! Selects the CWRR hydrology.
LOGICAL, SAVE :: myfalse=.FALSE.
LOGICAL, SAVE :: mytrue=.TRUE.
CONTAINS
!! Main routine for *sechiba* module.
!!
!! Should be called two times:
!! - first time to have initial values
!! - second time to have complete algorithm
!!
!! Algorithm:
!! 3 series of called SECHIBA processes
!! - initialisation (first time only)
!! - time step evolution (every time step)
!! - prepares output and storage of restart arrays (last time only)
!!
!! One serie consists of:
!! - call sechiba_var_init to do some initialisation
!! - call slowproc_main to do some daily initialisation
!! - call diffuco_main for diffusion coefficient calculation
!! - call enerbil_main for energy bilan calculation
!! - call hydrolc_main for hydrologic processes calculation
!! - call enerbil_fusion : last part with fusion
!! - call condveg_main for surface conditions such as roughness, albedo, and emmisivity
!! - call thermosoil_main for soil thermodynamic calculation
!! - call sechiba_end to swap new fields to previous
!!
!! @call sechiba_var_init
!! @call slowproc_main
!! @call diffuco_main
!! @call enerbil_main
!! @call hydrolc_main
!! @call enerbil_fusion
!! @call condveg_main
!! @call thermosoil_main
!! @call sechiba_end
!!
SUBROUTINE sechiba_main (kjit, kjpij, kjpindex, index, dtradia, date0, &
& ldrestart_read, ldrestart_write, control_in, &
& lalo, contfrac, neighbours, resolution,&
! First level conditions
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! & zlev, u, v, qair, temp_air, epot_air, ccanopy, &
& zlev, u, v, qair, q2m, t2m, temp_air, epot_air, ccanopy, &
! Variables for the implicit coupling
& tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
! Surface temperatures and surface properties
& tsol_rad, temp_sol_new, qsurf_out, albedo_out, emis_out, z0_out, &
! File ids
&rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom)
! interface description for dummy arguments
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: kjpij !! Total size of size. This is the un-compressed grid
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std),INTENT (in) :: rest_id !! _Restart_ file identifier
INTEGER(i_std),INTENT (in) :: hist_id !! _History_ file identifier
INTEGER(i_std),INTENT (in) :: hist2_id !! _History_ file 2 identifier
INTEGER(i_std),INTENT (in) :: rest_id_stom !! STOMATE's _Restart_ file identifier
INTEGER(i_std),INTENT (in) :: hist_id_stom !! STOMATE's _History_ file identifier
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
REAL(r_std), INTENT (in) :: date0 !! initial date
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for _restart_ file to write
TYPE(control_type), INTENT(in) :: control_in !! Flags that (de)activate parts of the model
! input fields
REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geographical coordinates
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: contfrac !! Fraction of continent in the grid
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
!
INTEGER(i_std), DIMENSION (kjpindex,8), INTENT(in) :: neighbours !! neighoring grid points if land
REAL(r_std), DIMENSION (kjpindex,2), INTENT(in) :: resolution !! size in x an y of the grid (m)
!
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
! Ajout Nathalie - Juin 2006 - Q2M/t2m pour calcul Rveget
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q2m !! 2m specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: t2m !! 2m air temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: lwdown !! Down-welling long-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swdown !! Down-welling surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Air temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: epot_air !! Air potential energy
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: ccanopy !! CO2 concentration in the canopy
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: petAcoef !! Coeficients A from the PBL resolution
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: peqAcoef !! One for T and another for q
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: petBcoef !! Coeficients B from the PBL resolution
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: peqBcoef !! One for T and another for q
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: tq_cdrag !! This is the cdrag without the wind multiplied
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: coastalflow !! Diffuse water flow to the oceans
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: riverflow !! River outflow to the oceans
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: tsol_rad !! Radiative surface temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapp !! Total of evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: qsurf_out !! Surface specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: z0_out !! Surface roughness (output diagnostic)
REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo_out !! Albedo (output diagnostic)
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxsens !! Sensible chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxlat !! Latent chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: emis_out !! Emissivity
REAL(r_std),DIMENSION (kjpindex) :: var_write !! Variable to write
INTEGER(i_std) :: i, iloc, jv
IF (long_print) WRITE(numout,*) ' kjpindex =',kjpindex
! do SECHIBA'S first call initialisation
IF (l_first_sechiba) THEN
CALL sechiba_init (kjit, ldrestart_read, kjpij, kjpindex, index, rest_id, control_in, lalo)
!
! computes slow variables
!
CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
ldrestart_read, ldrestart_write, control%ok_co2, control%ok_stomate, &
index, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
t2mdiag, t2mdiag, temp_sol, stempdiag, &
vegstress, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, frac_bare, height, veget, frac_nobio, njsc, totfrac_nobio, qsintmax, &
rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux)
!
! computes initialisation of diffusion coeff
!
CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, u, v, &
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb , &
& zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb , &
& rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
& swnet, swdown, ccanopy, humrel, frac_bare, veget, lai, qsintveg, qsintmax, assim_param, &
!MG
! & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
& vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, rstruct, cimean, rest_id, hist_id, hist2_id)
!
! computes initialisation of energy bilan
!
CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
! & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
!MG
& index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
& qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, &
!MG
! & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
& rveget, rstruct, cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
& vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
! & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id)
!MG
& temp_sol_new, qsurf, evapot, evapot_corr, etm, rest_id, hist_id, hist2_id)
!
! computes initialisation of hydrology
!
IF ( .NOT. hydrol_cwrr ) THEN
CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare,&
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, rsol, drysoil_frac, evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, &
& soilcap, rest_id, hist_id, hist2_id)
evap_bare_lim(:) = -un
k_litt(:) = huit
ELSE
CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, indexsoil, indexlayer,&
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, njsc,&
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, flood_frac, flood_res, &
& shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id)
rsol(:) = -un
ENDIF
!
! computes initialisation of condveg
!
CALL condveg_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
& lalo, neighbours, resolution, contfrac, veget, frac_nobio, totfrac_nobio, &
& zlev, snow, snow_age, snow_nobio, snow_nobio_age, frac_bare, &
& drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, rest_id, hist_id, hist2_id)
!
! computes initialisation of Soil Thermodynamic
!
CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
& index, indexgrnd, temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id)
!
! If we chose to route the water then we call the module. Else variables
! are set to zero.
!
!
IF ( river_routing .AND. kjpindex .GT. 1) THEN
CALL routing_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget, floodout, runoff, &
!MG
! & drainage, evapot_corr, precip_rain, humrel, k_litt, flood_frac, flood_res, &
& drainage, evapot_corr, etm, precip_rain, humrel, k_litt, flood_frac, flood_res, &
& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
ELSE
riverflow(:) = zero
coastalflow(:) = zero
returnflow(:) = zero
reinfiltration(:) = zero
irrigation(:) = zero
flood_frac(:) = zero
flood_res(:) = zero
ENDIF
!
! Write the internal variables into the output fields
!
z0_out(:) = z0(:)
emis_out(:) = emis(:)
albedo_out(:,:) = albedo(:,:)
qsurf_out(:) = qsurf(:)
!
! This line should remain last as it ends the initialisation and returns to the caling
! routine.
!
!Aurélien 2009
WRITE (numout,*) '-------------------------'
WRITE (numout,*) ' INITIALISATION TERMINEE '
WRITE (numout,*) ' etm(:,:)= ',etm(:,:)
WRITE (numout,*) ' humrel(:,:)= ',humrel(:,:)
humrel(:,:)=0.5
WRITE (numout,*) ' humrel(:,:)= ',humrel(:,:)
WRITE (numout,*) '-------------------------'
RETURN
!
ENDIF
!
! computes some initialisation every SECHIBA's call
!
CALL sechiba_var_init (kjpindex, rau, pb, temp_air)
!
! computes slow variables
! ok_co2 and ok_stomate are interpreted as flags that determine whether the
! forcing files are written.
!
CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
ldrestart_read, myfalse, control%ok_co2, control%ok_stomate, &
index, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
t2mdiag, t2mdiag, temp_sol, stempdiag, &
vegstress, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, frac_bare, height, veget, frac_nobio, njsc, totfrac_nobio, qsintmax, &
rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux)
!
! computes diffusion coeff
!
CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, u, v, &
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb , &
& zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb , &
& rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
& swnet, swdown, ccanopy, humrel, frac_bare, veget, lai, qsintveg, qsintmax, assim_param, &
! & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
!MG
& vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, rstruct, cimean, rest_id, hist_id, hist2_id)
!
! computes energy bilan
!
CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, &
! & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
!MG
& index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
& qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, &
! & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
!MG
& rveget, rstruct, cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
& vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
! & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id)
!MG
& temp_sol_new, qsurf, evapot, evapot_corr, etm, rest_id, hist_id, hist2_id)
!
! computes hydrologie
!
IF ( .NOT. hydrol_cwrr ) THEN
CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, &
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, rsol, drysoil_frac, evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, &
& soilcap, rest_id, hist_id, hist2_id)
evap_bare_lim(:) = -un
k_litt(:) = huit
ELSE
CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, indexsoil, indexlayer, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, njsc,&
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, flood_frac, flood_res, &
& shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id)
rsol(:) = -un
ENDIF
!
! computes last part of energy bilan
!
CALL enerbil_fusion (kjpindex, dtradia, tot_melt, soilcap, temp_sol_new, fusion)
!
! computes condveg
!
CALL condveg_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index,&
& lalo, neighbours, resolution, contfrac, veget, frac_nobio, totfrac_nobio, &
& zlev, snow, snow_age, snow_nobio, snow_nobio_age, frac_bare, &
& drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, rest_id, hist_id, hist2_id)
!
! computes Soil Thermodynamic
!
CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexgrnd, &
& temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id)
!
! If we chose to route the water then we call the module. Else variables
! are set to zero.
!
!
IF ( river_routing .AND. kjpindex .GT. 1) THEN
CALL routing_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, &
& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget, floodout, runoff, &
! & drainage, evapot_corr, precip_rain, humrel, k_litt, flood_frac, flood_res, &
!MG
& drainage, evapot_corr, etm, precip_rain, humrel, k_litt, flood_frac, flood_res, &
& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
! returnflow(:) = returnflow(:) * 100.
ELSE
riverflow(:) = zero
coastalflow(:) = zero
returnflow(:) = zero
reinfiltration(:) = zero
irrigation(:) = zero
flood_frac(:) = zero
flood_res(:) = zero
ENDIF
!
! call swap from new computed variables
!
CALL sechiba_end (kjpindex, dtradia, temp_sol, temp_sol_new)
!
! Write the internal variables into the output fields
!
z0_out(:) = z0(:)
emis_out(:) = emis(:)
albedo_out(:,:) = albedo(:,:)
qsurf_out(:) = qsurf(:)
!
! Writing the global variables on the history tape
!
!
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'beta', kjit, vbeta, kjpindex, index)
CALL histwrite(hist_id, 'z0', kjit, z0, kjpindex, index)
CALL histwrite(hist_id, 'roughheight', kjit, roughheight, kjpindex, index)
CALL histwrite(hist_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist_id, 'lai', kjit, lai, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'subli', kjit, vevapsno, kjpindex, index)
CALL histwrite(hist_id, 'evapflo', kjit, vevapflo, kjpindex, index)
CALL histwrite(hist_id, 'evapnu', kjit, vevapnu, kjpindex, index)
CALL histwrite(hist_id, 'transpir', kjit, transpir, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'inter', kjit, vevapwet, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'vbeta1', kjit, vbeta1, kjpindex, index)
CALL histwrite(hist_id, 'vbeta2', kjit, vbeta2, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'vbeta3', kjit, vbeta3, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'vbeta4', kjit, vbeta4, kjpindex, index)
CALL histwrite(hist_id, 'vbeta5', kjit, vbeta5, kjpindex, index)
CALL histwrite(hist_id, 'drysoil_frac', kjit, drysoil_frac, kjpindex, index)
CALL histwrite(hist_id, 'rveget', kjit, rveget, kjpindex*nvm, indexveg)
!MG
CALL histwrite(hist_id, 'rstruct', kjit, rstruct, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'flood_frac', kjit, flood_frac, kjpindex, index)
CALL histwrite(hist_id, 'k_litt', kjit, k_litt, kjpindex, index)
CALL histwrite(hist_id, 'rsol', kjit, rsol, kjpindex, index)
CALL histwrite(hist_id, 'snow', kjit, snow, kjpindex, index)
CALL histwrite(hist_id, 'snowage', kjit, snow_age, kjpindex, index)
CALL histwrite(hist_id, 'snownobio', kjit, snow_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist_id, 'snownobioage', kjit, snow_nobio_age, kjpindex*nnobio, indexnobio)
!MG
CALL histwrite(hist_id, 'frac_bare', kjit, frac_bare, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'soiltile', kjit, soiltile, kjpindex*nstm, indexsoil)
CALL histwrite(hist_id, 'soilindex', kjit, REAL(njsc, r_std), kjpindex, index)
CALL histwrite(hist_id, 'reinf_slope', kjit, reinf_slope, kjpindex, index)
IF ( control%ok_co2 ) THEN
CALL histwrite(hist_id, 'vbetaco2', kjit, vbetaco2, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'gpp', kjit, gpp, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'cimean', kjit, cimean, kjpindex*nvm, indexveg)
ENDIF
ELSE
CALL histwrite(hist_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist_id, 'Qf', kjit, fusion, kjpindex, index)
CALL histwrite(hist_id, 'ESoil', kjit, vevapnu, kjpindex, index)
CALL histwrite(hist_id, 'EWater', kjit, vevapflo, kjpindex, index)
var_write(:)=zero
DO jv=1,nvm
var_write(:) = var_write(:) + transpir(:,jv)
ENDDO
CALL histwrite(hist_id, 'TVeg', kjit, var_write, kjpindex, index)
var_write(:)=zero
DO jv=1,nvm
var_write(:) = var_write(:) + vevapwet(:,jv)
ENDDO
CALL histwrite(hist_id, 'ECanop', kjit, var_write, kjpindex, index)
CALL histwrite(hist_id, 'ACond', kjit, tq_cdrag, kjpindex, index)
CALL histwrite(hist_id, 'SnowFrac', kjit, vbeta1, kjpindex, index)
IF ( control%ok_co2 ) THEN
CALL histwrite(hist_id, 'GPP', kjit, gpp, kjpindex*nvm, indexveg)
ENDIF
ENDIF
!
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist2_id, 'tsol_rad', kjit, tsol_rad, kjpindex, index)
CALL histwrite(hist2_id, 'qsurf', kjit, qsurf, kjpindex, index)
CALL histwrite(hist2_id, 'albedo', kjit, albedo, kjpindex*2, indexalb)
CALL histwrite(hist2_id, 'emis', kjit, emis, kjpindex, index)
!
CALL histwrite(hist2_id, 'beta', kjit, vbeta, kjpindex, index)
CALL histwrite(hist2_id, 'z0', kjit, z0, kjpindex, index)
CALL histwrite(hist2_id, 'roughheight', kjit, roughheight, kjpindex, index)
CALL histwrite(hist2_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist2_id, 'lai', kjit, lai, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'subli', kjit, vevapsno, kjpindex, index)
CALL histwrite(hist2_id, 'vevapflo', kjit, vevapflo, kjpindex, index)
CALL histwrite(hist2_id, 'vevapnu', kjit, vevapnu, kjpindex, index)
CALL histwrite(hist2_id, 'transpir', kjit, transpir, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'inter', kjit, vevapwet, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'vbeta1', kjit, vbeta1, kjpindex, index)
CALL histwrite(hist2_id, 'vbeta2', kjit, vbeta2, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'vbeta3', kjit, vbeta3, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'vbeta4', kjit, vbeta4, kjpindex, index)
CALL histwrite(hist2_id, 'vbeta5', kjit, vbeta5, kjpindex, index)
CALL histwrite(hist2_id, 'drysoil_frac', kjit, drysoil_frac, kjpindex, index)
CALL histwrite(hist2_id, 'rveget', kjit, rveget, kjpindex*nvm, indexveg)
!MG
CALL histwrite(hist2_id, 'rstruct', kjit, rstruct, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'flood_frac', kjit, flood_frac, kjpindex, index)
CALL histwrite(hist2_id, 'k_litt', kjit, k_litt, kjpindex, index)
CALL histwrite(hist2_id, 'rsol', kjit, rsol, kjpindex, index)
CALL histwrite(hist2_id, 'snow', kjit, snow, kjpindex, index)
CALL histwrite(hist2_id, 'snowage', kjit, snow_age, kjpindex, index)
CALL histwrite(hist2_id, 'snownobio', kjit, snow_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist2_id, 'snownobioage', kjit, snow_nobio_age, kjpindex*nnobio, indexnobio)
CALL histwrite(hist2_id, 'soiltile', kjit, soiltile, kjpindex*nstm, indexsoil)
CALL histwrite(hist2_id, 'soilindex', kjit, REAL(njsc, r_std), kjpindex, index)
CALL histwrite(hist2_id, 'reinf_slope', kjit, reinf_slope, kjpindex, index)
IF ( control%ok_co2 ) THEN
CALL histwrite(hist2_id, 'vbetaco2', kjit, vbetaco2, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'gpp', kjit, gpp, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'cimean', kjit, cimean, kjpindex*nvm, indexveg)
ENDIF
ELSE
CALL histwrite(hist2_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist2_id, 'Qf', kjit, fusion, kjpindex, index)
CALL histwrite(hist2_id, 'SWE', kjit, snow, kjpindex, index)
CALL histwrite(hist2_id, 'ESoil', kjit, vevapnu, kjpindex, index)
CALL histwrite(hist2_id, 'EWater', kjit, vevapflo, kjpindex, index)
var_write(:)=zero
DO jv=1,nvm
var_write(:) = var_write(:) + transpir(:,jv)
ENDDO
CALL histwrite(hist2_id, 'TVeg', kjit, var_write, kjpindex, index)
var_write(:)=zero
DO jv=1,nvm
var_write(:) = var_write(:) + vevapwet(:,jv)
ENDDO
CALL histwrite(hist2_id, 'ECanop', kjit, vevapwet, kjpindex, index)
CALL histwrite(hist2_id, 'ACond', kjit, tq_cdrag, kjpindex, index)
CALL histwrite(hist2_id, 'SnowFrac', kjit, vbeta1, kjpindex, index)
IF ( control%ok_co2 ) THEN
CALL histwrite(hist2_id, 'GPP', kjit, gpp, kjpindex*nvm, indexveg)
ENDIF
ENDIF
ENDIF
!
! prepares restart file for the next simulation from SECHIBA and from other modules
!
IF (ldrestart_write) THEN
IF (long_print) WRITE (numout,*) ' we have to write a restart file '
!
! call slowproc_main to write restart files
!
CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
ldrestart_read, ldrestart_write, control%ok_co2, control%ok_stomate, &
index, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
t2mdiag, t2mdiag, temp_sol, stempdiag, &
vegstress, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, frac_bare, height, veget, frac_nobio, njsc, totfrac_nobio, qsintmax, &
rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux)
!
! call diffuco_main to write restart files
!
CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, u, v, &
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb , &
& zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb , &
& rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
& swnet, swdown, ccanopy, humrel, frac_bare, veget, lai, qsintveg, qsintmax, assim_param, &
! & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
!MG
& vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, rstruct, cimean, rest_id, hist_id, hist2_id)
!
! call energy bilan to write restart files
!
CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
! & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
!MG
& index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
& qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, &
! & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
!MG
& rveget, rstruct, cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
& vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
! & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id)
!MG
& temp_sol_new, qsurf, evapot, evapot_corr, etm, rest_id, hist_id, hist2_id)
!
! call hydrologie to write restart files
!
IF ( .NOT. hydrol_cwrr ) THEN
CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare,&
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, rsol, drysoil_frac, evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, &
& soilcap, rest_id, hist_id, hist2_id)
evap_bare_lim(:) = -un
k_litt(:) = huit
ELSE
CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, indexsoil, indexlayer, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, njsc, &
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, flood_frac, flood_res, &
& shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id)
rsol(:) = -un
ENDIF
!
! call condveg to write restart files
!
CALL condveg_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
& lalo, neighbours, resolution, contfrac, veget, frac_nobio, totfrac_nobio, &
& zlev, snow, snow_age, snow_nobio, snow_nobio_age, frac_bare, &
& drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, rest_id, hist_id, hist2_id)
!
! call Soil Thermodynamic to write restart files
!
CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexgrnd, &
& temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id)
!
! If we chose to route the water then we call the module. Else variables
! are set to zero.
!
!
IF ( river_routing .AND. kjpindex .GT. 1) THEN
CALL routing_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget, floodout, runoff, &
! & drainage, evapot_corr, precip_rain, humrel, k_litt, flood_frac, flood_res, &
!MG
& drainage, evapot_corr, etm, precip_rain, humrel, k_litt, flood_frac, flood_res, &
& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
ELSE
riverflow(:) = zero
coastalflow(:) = zero
reinfiltration(:) = zero
returnflow(:) = zero
irrigation(:) = zero
flood_frac(:) = zero
flood_res(:) = zero
ENDIF
END IF
IF (long_print) WRITE (numout,*) ' sechiba_main done '
END SUBROUTINE sechiba_main
!! Initialisation for SECHIBA processes
!! - does dynamic allocation for local arrays
!! - reads _restart_ file or set initial values to a raisonable value
!! - reads initial map
!!
SUBROUTINE sechiba_init (kjit, ldrestart_read, kjpij, kjpindex, index, rest_id, control_in, lalo)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjit !! Time step number
LOGICAL,INTENT (in) :: ldrestart_read !! Logical for restart file to read
INTEGER(i_std), INTENT (in) :: kjpij !! Size of full domaine
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std), INTENT (in) :: rest_id !! _Restart_ file identifier
TYPE(control_type), INTENT(in) :: control_in !! Flags that (de)activate parts of the model
! input fields
REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geographical coordinates
! output scalar
! output fields
! local declaration
INTEGER(i_std) :: ier, ipdt, ji, jv
!
! initialisation
!
IF (l_first_sechiba) THEN
l_first_sechiba=.FALSE.
ELSE
WRITE (numout,*) ' l_first_sechiba false . we stop '
STOP 'sechiba_init'
ENDIF
! 1. make dynamic allocation with good dimension
! 1.0 The 3D vegetation indexation table
ALLOCATE (indexveg(kjpindex*nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (indexsoil(kjpindex*nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexsoil allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'sechiba_init'
END IF
ALLOCATE (indexnobio(kjpindex*nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexnobio allocation. We stop. We need kjpindex words = ',kjpindex*nnobio
STOP 'sechiba_init'
END IF
ALLOCATE (indexgrnd(kjpindex*ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexgrnd allocation. We stop. We need kjpindex words = ',kjpindex*ngrnd
STOP 'sechiba_init'
END IF
ALLOCATE (indexlayer(kjpindex*nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexlayer allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'sechiba_init'
END IF
ALLOCATE (indexalb(kjpindex*2),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexalb allocation. We stop. We need kjpindex words = ',kjpindex*2
STOP 'sechiba_init'
END IF
! 1.1 one dimension array allocation with restartable value
IF (long_print) WRITE (numout,*) 'Allocation of 1D variables. We need for each kjpindex words = ',kjpindex
ALLOCATE (flood_res(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in flood_res allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
flood_res(:) = undef_sechiba
IF (long_print) WRITE (numout,*) 'Allocation of 1D variables. We need for each kjpindex words = ',kjpindex
ALLOCATE (flood_frac(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in flood_frac allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
flood_frac(:) = undef_sechiba
IF (long_print) WRITE (numout,*) 'Allocation of 1D variables. We need for each kjpindex words = ',kjpindex
ALLOCATE (snow(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
snow(:) = undef_sechiba
ALLOCATE (snow_age(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_age allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
snow_age(:) = undef_sechiba
ALLOCATE (drysoil_frac(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in drysoil_frac allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (rsol(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rsol allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (evap_bare_lim(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in evap_bare_lim allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (evapot(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in evapot allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
evapot(:) = undef_sechiba
ALLOCATE (evapot_corr(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in evapot_corr allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
!MG
ALLOCATE (etm(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in etm allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (humrel(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in humrel allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
humrel(:,:) = undef_sechiba
ALLOCATE (vegstress(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vegstress allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
vegstress(:,:) = undef_sechiba
ALLOCATE (njsc(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in njsc allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
njsc(:)= undef_int
ALLOCATE (soiltile(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soiltile allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
soiltile(:,:)=undef_sechiba
ALLOCATE (reinf_slope(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in reinf_slope allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
reinf_slope(:)=undef_sechiba
ALLOCATE (vbeta1(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta1 allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vbeta4(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta4 allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vbeta5(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta5 allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (soilcap(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soilcap allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (soilflx(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soilflx allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (temp_sol(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in temp_sol allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
temp_sol(:) = undef_sechiba
ALLOCATE (qsurf(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsurf allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
qsurf(:) = undef_sechiba
! 1.2 two dimensions array allocation with restartable value
ALLOCATE (qsintveg(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsintveg allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm,' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
qsintveg(:,:) = undef_sechiba
ALLOCATE (vbeta2(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta2 allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (vbeta3(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta3 allocation. We stop.We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (vbetaco2(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbetaco2 allocation. We stop.We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (cimean(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in cimean allocation. We stop.We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (gpp(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in gpp allocation. We stop.We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
gpp(:,:) = undef_sechiba
ALLOCATE (veget(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in veget allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
veget(:,:)=undef_sechiba
ALLOCATE (lai(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in lai allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
lai(:,:)=undef_sechiba
ALLOCATE (frac_bare(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in frac_bare allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
frac_bare(:,:)=undef_sechiba
ALLOCATE (height(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in height allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
height(:,:)=undef_sechiba
ALLOCATE (frac_nobio(kjpindex,nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in frac_nobio allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
frac_nobio(:,:)=undef_sechiba
ALLOCATE (albedo(kjpindex,2),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in albedo allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (snow_nobio(kjpindex,nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_nobio allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
snow_nobio(:,:) = undef_sechiba
ALLOCATE (snow_nobio_age(kjpindex,nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_nobio_age allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
snow_nobio_age(:,:) = undef_sechiba
ALLOCATE (assim_param(kjpindex,nvm,npco2),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in assim_param allocation. We stop. We need kjpindex x nvm x npco2 words = ',&
& kjpindex,' x ' ,nvm,' x ',npco2, ' = ',kjpindex*nvm*npco2
STOP 'sechiba_init'
END IF
! 1.3 one dimension array allocation
ALLOCATE (vevapflo(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vevapflo allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vevapsno(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vevapsno allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vevapnu(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vevapnu allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (t2mdiag(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in t2mdiag allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (totfrac_nobio(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in totfrac_nobio allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (floodout(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in floodout allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (runoff(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in runoff allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (drainage(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in drainage allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (returnflow(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in returnflow allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
returnflow(:) = zero
ALLOCATE (reinfiltration(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in reinfiltration allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
reinfiltration(:) = zero
ALLOCATE (irrigation(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in irrigation allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
irrigation(:) = zero
ALLOCATE (z0(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in z0 allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (roughheight(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in roughheight allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (emis(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in emis allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (tot_melt(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_melt allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (valpha(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in valpha allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vbeta(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (fusion(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in fusion allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (rau(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rau allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (deadleaf_cover(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in deadleaf_cover allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (stempdiag(kjpindex, nbdl),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in stempdiag allocation. We stop. We need kjpindex*nbdl words = ',&
& kjpindex*nbdl
STOP 'sechiba_init'
END IF
ALLOCATE (co2_flux(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in co2_flux allocation. We stop. We need kjpindex words = ' ,kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (shumdiag(kjpindex,nbdl),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in shumdiag allocation. We stop. We need kjpindex*nbdl words = ',&
& kjpindex*nbdl
STOP 'sechiba_init'
END IF
ALLOCATE (litterhumdiag(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in litterhumdiag allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (k_litt(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in k_litt allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
! 1.4 two dimensions array allocation
ALLOCATE (vevapwet(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vevapwet allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
vevapwet(:,:)=undef_sechiba
ALLOCATE (transpir(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in transpir allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (qsintmax(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsintmax allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (rveget(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rveget allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
!MG
ALLOCATE (rstruct(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rstruct allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
!
! 1.5 Get the indexing table for the vegetation fields. In SECHIBA we work on reduced grids but to store in the
! full 3D filed vegetation variable we need another index table : indexveg, indexsoil, indexnobio and
! indexgrnd
!
DO ji = 1, kjpindex
!
DO jv = 1, nvm
indexveg((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, nstm
indexsoil((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, nnobio
indexnobio((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, ngrnd
indexgrnd((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, nslm
indexlayer((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, 2
indexalb((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
ENDDO
! tdo - diaglev is now computed in intersurf (for output reasons - see histvert)
!
! 2. restart value
!
! open restart input file if needed
! and read data from restart input file
!
IF (ldrestart_read) THEN
IF (long_print) WRITE (numout,*) ' we have to read a restart file for SECHIBA variables'
!
! Read the default value that will be put into variable which are not in the restart file
!
CALL ioget_expval(val_exp)
ENDIF
!
river_routing = control_in%river_routing
hydrol_cwrr = control_in%hydrol_cwrr
!
! 4. run control: store flags in a common variable
!
! tdo - ajout de hydrol_cwrr ici pour fonctionnement de diffuco
control%hydrol_cwrr = control_in%hydrol_cwrr
control%ok_co2 = control_in%ok_co2
control%ok_sechiba = control_in%ok_sechiba
control%ok_stomate = control_in%ok_stomate
control%ok_dgvm = control_in%ok_dgvm
control%ok_pheno = control_in%ok_pheno
control%stomate_watchout = control_in%stomate_watchout
IF (long_print) WRITE (numout,*) ' sechiba_init done '
END SUBROUTINE sechiba_init
!
!------------------------------------------------------------------
!
SUBROUTINE sechiba_clear (forcing_name,cforcing_name)
CHARACTER(LEN=100), INTENT(in) :: forcing_name
CHARACTER(LEN=100), INTENT(in) :: cforcing_name
!
! initialisation
!
l_first_sechiba=.TRUE.
! 1. Deallocate all dynamic variables
IF ( ALLOCATED (indexveg)) DEALLOCATE (indexveg)
IF ( ALLOCATED (indexsoil)) DEALLOCATE (indexsoil)
IF ( ALLOCATED (indexnobio)) DEALLOCATE (indexnobio)
IF ( ALLOCATED (indexgrnd)) DEALLOCATE (indexgrnd)
IF ( ALLOCATED (indexlayer)) DEALLOCATE (indexlayer)
IF ( ALLOCATED (indexalb)) DEALLOCATE (indexalb)
IF ( ALLOCATED (flood_res)) DEALLOCATE (flood_res)
IF ( ALLOCATED (flood_frac)) DEALLOCATE (flood_frac)
IF ( ALLOCATED (snow)) DEALLOCATE (snow)
IF ( ALLOCATED (snow_age)) DEALLOCATE (snow_age)
IF ( ALLOCATED (drysoil_frac)) DEALLOCATE (drysoil_frac)
IF ( ALLOCATED (rsol)) DEALLOCATE (rsol)
IF ( ALLOCATED (evap_bare_lim)) DEALLOCATE (evap_bare_lim)
IF ( ALLOCATED (evapot)) DEALLOCATE (evapot)
IF ( ALLOCATED (evapot_corr)) DEALLOCATE (evapot_corr)
!MG
IF ( ALLOCATED (etm)) DEALLOCATE (etm)
IF ( ALLOCATED (humrel)) DEALLOCATE (humrel)
IF ( ALLOCATED (vegstress)) DEALLOCATE (vegstress)
IF ( ALLOCATED (soiltile)) DEALLOCATE (soiltile)
IF ( ALLOCATED (njsc)) DEALLOCATE (njsc)
IF ( ALLOCATED (reinf_slope)) DEALLOCATE (reinf_slope)
IF ( ALLOCATED (vbeta1)) DEALLOCATE (vbeta1)
IF ( ALLOCATED (vbeta4)) DEALLOCATE (vbeta4)
IF ( ALLOCATED (vbeta5)) DEALLOCATE (vbeta5)
IF ( ALLOCATED (soilcap)) DEALLOCATE (soilcap)
IF ( ALLOCATED (soilflx)) DEALLOCATE (soilflx)
IF ( ALLOCATED (temp_sol)) DEALLOCATE (temp_sol)
IF ( ALLOCATED (qsurf)) DEALLOCATE (qsurf)
IF ( ALLOCATED (qsintveg)) DEALLOCATE (qsintveg)
IF ( ALLOCATED (vbeta2)) DEALLOCATE (vbeta2)
IF ( ALLOCATED (vbeta3)) DEALLOCATE (vbeta3)
IF ( ALLOCATED (vbetaco2)) DEALLOCATE (vbetaco2)
IF ( ALLOCATED (cimean)) DEALLOCATE (cimean)
IF ( ALLOCATED (gpp)) DEALLOCATE (gpp)
IF ( ALLOCATED (veget)) DEALLOCATE (veget)
IF ( ALLOCATED (lai)) DEALLOCATE (lai)
IF ( ALLOCATED (frac_bare)) DEALLOCATE (frac_bare)
IF ( ALLOCATED (height)) DEALLOCATE (height)
IF ( ALLOCATED (roughheight)) DEALLOCATE (roughheight)
IF ( ALLOCATED (frac_nobio)) DEALLOCATE (frac_nobio)
IF ( ALLOCATED (snow_nobio)) DEALLOCATE (snow_nobio)
IF ( ALLOCATED (snow_nobio_age)) DEALLOCATE (snow_nobio_age)
IF ( ALLOCATED (assim_param)) DEALLOCATE (assim_param)
IF ( ALLOCATED (vevapflo)) DEALLOCATE (vevapflo)
IF ( ALLOCATED (vevapsno)) DEALLOCATE (vevapsno)
IF ( ALLOCATED (vevapnu)) DEALLOCATE (vevapnu)
IF ( ALLOCATED (t2mdiag)) DEALLOCATE (t2mdiag)
IF ( ALLOCATED (totfrac_nobio)) DEALLOCATE (totfrac_nobio)
IF ( ALLOCATED (floodout)) DEALLOCATE (floodout)
IF ( ALLOCATED (runoff)) DEALLOCATE (runoff)
IF ( ALLOCATED (drainage)) DEALLOCATE (drainage)
IF ( ALLOCATED (reinfiltration)) DEALLOCATE (reinfiltration)
IF ( ALLOCATED (irrigation)) DEALLOCATE (irrigation)
IF ( ALLOCATED (tot_melt)) DEALLOCATE (tot_melt)
IF ( ALLOCATED (valpha)) DEALLOCATE (valpha)
IF ( ALLOCATED (vbeta)) DEALLOCATE (vbeta)
IF ( ALLOCATED (fusion)) DEALLOCATE (fusion)
IF ( ALLOCATED (rau)) DEALLOCATE (rau)
IF ( ALLOCATED (deadleaf_cover)) DEALLOCATE (deadleaf_cover)
IF ( ALLOCATED (stempdiag)) DEALLOCATE (stempdiag)
IF ( ALLOCATED (co2_flux)) DEALLOCATE (co2_flux)
IF ( ALLOCATED (shumdiag)) DEALLOCATE (shumdiag)
IF ( ALLOCATED (litterhumdiag)) DEALLOCATE (litterhumdiag)
IF ( ALLOCATED (k_litt)) DEALLOCATE (k_litt)
IF ( ALLOCATED (vevapwet)) DEALLOCATE (vevapwet)
IF ( ALLOCATED (transpir)) DEALLOCATE (transpir)
IF ( ALLOCATED (qsintmax)) DEALLOCATE (qsintmax)
IF ( ALLOCATED (rveget)) DEALLOCATE (rveget)
!MG
IF ( ALLOCATED (rstruct)) DEALLOCATE (rstruct)
! 2. clear all modules
CALL slowproc_clear
CALL diffuco_clear
CALL enerbil_clear
IF ( hydrol_cwrr ) THEN
CALL hydrol_clear
ELSE
CALL hydrolc_clear
ENDIF
CALL condveg_clear
CALL thermosoil_clear
CALL routing_clear
!3. give name to next block
stomate_forcing_name=forcing_name
stomate_Cforcing_name=Cforcing_name
END SUBROUTINE sechiba_clear
!! SECHIBA's variables initialisation
!! called every time step
!!
SUBROUTINE sechiba_var_init (kjpindex, rau, pb, temp_air)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain dimension
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Air temperature
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: rau !! Density
! local declaration
INTEGER(i_std) :: ji
!
! initialisation
!
!
! 1. calcul of rau: air density
!
DO ji = 1,kjpindex
rau(ji) = pa_par_hpa * pb(ji) / (cte_molr*temp_air(ji))
END DO
IF (long_print) WRITE (numout,*) ' sechiba_var_init done '
END SUBROUTINE sechiba_var_init
!!
!! Swap new fields to previous fields
!!
SUBROUTINE sechiba_end (kjpindex, dtradia, temp_sol, temp_sol_new)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain dimension
REAL(r_std),INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol_new !! New soil temperature
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: temp_sol !! Soil temperature
! local declaration
INTEGER(i_std) :: ji
!
! swap
!
temp_sol(:) = temp_sol_new(:)
IF (long_print) WRITE (numout,*) ' sechiba_end done '
END SUBROUTINE sechiba_end
END MODULE sechiba
ORCHIDEE/src_sechiba/sechiba.f90 0000754 0103600 0005670 00000215216 11205035677 016122 0 ustar acamlmd lmdjus !! This module computes continental processes SECHIBA
!!
!! See also this graph
!!
!! @author Marie-Alice Foujols and Jan Polcher
!! @Version : $Revision: 1.37 $, $Date: 2007/06/12 19:55:02 $
!!
!! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_sechiba/sechiba.f90,v 1.37 2007/06/12 19:55:02 ssipsl Exp $
!! IPSL (2006)
!! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!!
MODULE sechiba
! routines called : diffuco_main, enerbil_main, hydrolc_main, enrbil_fusion, condveg_main, thermosoil_main
!
USE ioipsl
!
! modules used :
USE constantes
USE constantes_veg
USE constantes_co2
USE diffuco
USE condveg
USE enerbil
USE hydrol
USE hydrolc
USE thermosoil
USE sechiba_io
USE slowproc
USE routing
! USE write_field_p, only : WriteFieldI_p
IMPLICIT NONE
! public routines :
! sechiba_main
! sechiba_clear
PRIVATE
PUBLIC sechiba_main,sechiba_clear
! Index arrays we need internaly
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexveg !! indexing array for the 3D fields of vegetation
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexnobio !! indexing array for the 3D fields of other surf(ice,lakes ...)
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexsoil !! indexing array for the 3D fields of soil types
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexgrnd !! indexing array for the 3D ground heat profiles
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexlayer !! indexing array for the 3D fields of soil layers
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexalb !! indexing array for the 2 fields of albedo
! three dimensions array allocated, computed, saved and got in sechiba module
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:):: assim_param !! min+max+opt temps, vcmax, vjmax for photosynthesis
! two dimensions array allocated, computed, saved and got in sechiba module
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: veget !! Fraction of vegetation type
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: height !! Vegetation Height (m)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: frac_bare !! Bare soil fraction for each tile
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: lai !! Surface foliaire
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: gpp !! STOMATE: GPP. gC/m**2 of total area
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: humrel !! Relative humidity
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vegstress !! Vegetation moisture stress (only for vegetation growth)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: soiltile !! Map of soil types, created in slowproc in the
!! order : silt, sand and clay.
!
! one dimension array allocated, computed and used in sechiba module and passed to other
! modules called
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: njsc !! Soilclass index
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vbeta1 !! Snow resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vbeta4 !! Bare soil resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vbeta5 !! Floodplains resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: soilcap !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: soilflx !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: temp_sol !! Soil temperature
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: qsurf !! near soil air moisture
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: flood_res !! flood reservoir estimate
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: flood_frac !! flooded fraction
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snow !! Snow mass [Kg/m^2]
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: snow_age !! Snow age
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: drysoil_frac !! Fraction of visibly (albedo) Dry soil (Between 0 and 1)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: rsol !! resistance to bare soil evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: evap_bare_lim !! Bare soil stress
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: evapot !! Soil Potential Evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: evapot_corr !! Soil Potential Evaporation Correction (Milly 1992)
!MG
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: etm !! Maximum 'evapo'transpir (taking into account the vegetation resistance)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vevapflo !! Floodplains evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vevapsno !! Snow evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vevapnu !! Bare soil evaporation
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: t2mdiag !! 2 meter temperature
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tot_melt !! Total melt
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: vbeta !! Resistance coefficient
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: valpha !! Resistance coefficient
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: fusion !!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: rau !! Density
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: deadleaf_cover !! Fraction of soil covered by dead leaves
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: co2_flux !! CO2 flux (gC/m**2 of average ground/s)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: totfrac_nobio !! Total fraction of continental ice+lakes+cities+...
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: floodout !! Flow out of floodplains from hydrol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: runoff !! Surface runoff generated by hydrol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: drainage !! Deep drainage generated by hydrol
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: returnflow !! Routed water which returns into the soil
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: reinfiltration !! Routed water which returns into the soil
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: irrigation !! irrigation going back into the soils
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: emis !! Surface emissivity
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: z0 !! Surface roughness
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: roughheight !! Effective height for roughness
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: reinf_slope !! slope coefficient (reinfiltration)
!
! Arrays which are diagnostics from the physical processes for
! for the biological processes. They are not saved in the restart file because at the first time step,
! they are recalculated. However, they must be saved in memory as they are in slowproc which is called
! before the modules which calculate them.
!
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: shumdiag !! Relative soil moisture
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: k_litt !! litter cond.
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: litterhumdiag!! litter humidity
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: stempdiag !! Temperature which controls canopy evolution
! two dimensions array allocated, computed and used in sechiba module and passed to other
! modules called
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: qsintveg !! Water on vegetation due to interception
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vbeta2 !! Interception resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vbeta3 !! Vegetation resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vbetaco2 !! STOMATE: Vegetation resistance to CO2
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: cimean !! STOMATE: Mean ci
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: vevapwet !! Interception
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: transpir !! Transpiration
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: qsintmax !! Maximum water on vegetation for interception
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: rveget !! Vegetation resistance
!MG
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: rstruct !! Vegetation structural resistance
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: snow_nobio !! Water balance over other surface types (that is snow !)
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: snow_nobio_age !! Snow age on other surface types
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: frac_nobio !! Fraction of continental ice, lakes, ...
REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:) :: albedo !! Surface albedo for visible and NIR
!
! variables used inside sechiba module : declaration and initialisation
!
LOGICAL, SAVE :: l_first_sechiba = .TRUE.!! Initialisation has to be done one time
CHARACTER(LEN=80) , SAVE :: file_ext !! Extention for I/O filename
CHARACTER(LEN=80) , SAVE :: var_name !! To store variables names for I/O
LOGICAL, SAVE :: river_routing !! Flag that decides if we route.
LOGICAL, SAVE :: hydrol_cwrr !! Selects the CWRR hydrology.
LOGICAL, SAVE :: myfalse=.FALSE.
LOGICAL, SAVE :: mytrue=.TRUE.
CONTAINS
!! Main routine for *sechiba* module.
!!
!! Should be called two times:
!! - first time to have initial values
!! - second time to have complete algorithm
!!
!! Algorithm:
!! 3 series of called SECHIBA processes
!! - initialisation (first time only)
!! - time step evolution (every time step)
!! - prepares output and storage of restart arrays (last time only)
!!
!! One serie consists of:
!! - call sechiba_var_init to do some initialisation
!! - call slowproc_main to do some daily initialisation
!! - call diffuco_main for diffusion coefficient calculation
!! - call enerbil_main for energy bilan calculation
!! - call hydrolc_main for hydrologic processes calculation
!! - call enerbil_fusion : last part with fusion
!! - call condveg_main for surface conditions such as roughness, albedo, and emmisivity
!! - call thermosoil_main for soil thermodynamic calculation
!! - call sechiba_end to swap new fields to previous
!!
!! @call sechiba_var_init
!! @call slowproc_main
!! @call diffuco_main
!! @call enerbil_main
!! @call hydrolc_main
!! @call enerbil_fusion
!! @call condveg_main
!! @call thermosoil_main
!! @call sechiba_end
!!
SUBROUTINE sechiba_main (kjit, kjpij, kjpindex, index, dtradia, date0, &
& ldrestart_read, ldrestart_write, control_in, &
& lalo, contfrac, neighbours, resolution,&
! First level conditions
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! & zlev, u, v, qair, temp_air, epot_air, ccanopy, &
& zlev, u, v, qair, q2m, t2m, temp_air, epot_air, ccanopy, &
! Variables for the implicit coupling
& tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
! Rain, snow, radiation and surface pressure
& precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
! Output : Fluxes
& vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
! Surface temperatures and surface properties
& tsol_rad, temp_sol_new, qsurf_out, albedo_out, emis_out, z0_out, &
! File ids
&rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom)
! interface description for dummy arguments
! input scalar
INTEGER(i_std), INTENT(in) :: kjit !! Time step number
INTEGER(i_std), INTENT(in) :: kjpij !! Total size of size. This is the un-compressed grid
INTEGER(i_std), INTENT(in) :: kjpindex !! Domain size
INTEGER(i_std),INTENT (in) :: rest_id !! _Restart_ file identifier
INTEGER(i_std),INTENT (in) :: hist_id !! _History_ file identifier
INTEGER(i_std),INTENT (in) :: hist2_id !! _History_ file 2 identifier
INTEGER(i_std),INTENT (in) :: rest_id_stom !! STOMATE's _Restart_ file identifier
INTEGER(i_std),INTENT (in) :: hist_id_stom !! STOMATE's _History_ file identifier
REAL(r_std), INTENT (in) :: dtradia !! Time step in seconds
REAL(r_std), INTENT (in) :: date0 !! initial date
LOGICAL, INTENT(in) :: ldrestart_read !! Logical for _restart_ file to read
LOGICAL, INTENT(in) :: ldrestart_write !! Logical for _restart_ file to write
TYPE(control_type), INTENT(in) :: control_in !! Flags that (de)activate parts of the model
! input fields
REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geographical coordinates
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: contfrac !! Fraction of continent in the grid
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
!
INTEGER(i_std), DIMENSION (kjpindex,8), INTENT(in) :: neighbours !! neighoring grid points if land
REAL(r_std), DIMENSION (kjpindex,2), INTENT(in) :: resolution !! size in x an y of the grid (m)
!
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: u !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: v !! Lowest level wind speed
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: zlev !! Height of first layer
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: qair !! Lowest level specific humidity
! Ajout Nathalie - Juin 2006 - Q2M/t2m pour calcul Rveget
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: q2m !! 2m specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: t2m !! 2m air temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_rain !! Rain precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: precip_snow !! Snow precipitation
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: lwdown !! Down-welling long-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swnet !! Net surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: swdown !! Down-welling surface short-wave flux
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Air temperature in Kelvin
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: epot_air !! Air potential energy
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: ccanopy !! CO2 concentration in the canopy
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: petAcoef !! Coeficients A from the PBL resolution
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: peqAcoef !! One for T and another for q
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: petBcoef !! Coeficients B from the PBL resolution
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: peqBcoef !! One for T and another for q
REAL(r_std),DIMENSION (kjpindex), INTENT (inout) :: tq_cdrag !! This is the cdrag without the wind multiplied
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: coastalflow !! Diffuse water flow to the oceans
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: riverflow !! River outflow to the oceans
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: tsol_rad !! Radiative surface temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: vevapp !! Total of evaporation
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: temp_sol_new !! New soil temperature
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: qsurf_out !! Surface specific humidity
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: z0_out !! Surface roughness (output diagnostic)
REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo_out !! Albedo (output diagnostic)
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxsens !! Sensible chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: fluxlat !! Latent chaleur flux
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: emis_out !! Emissivity
REAL(r_std),DIMENSION (kjpindex) :: var_write !! Variable to write
INTEGER(i_std) :: i, iloc, jv
IF (long_print) WRITE(numout,*) ' kjpindex =',kjpindex
! do SECHIBA'S first call initialisation
IF (l_first_sechiba) THEN
CALL sechiba_init (kjit, ldrestart_read, kjpij, kjpindex, index, rest_id, control_in, lalo)
!
! computes slow variables
!
CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
ldrestart_read, ldrestart_write, control%ok_co2, control%ok_stomate, &
index, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
t2mdiag, t2mdiag, temp_sol, stempdiag, &
vegstress, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, frac_bare, height, veget, frac_nobio, njsc, totfrac_nobio, qsintmax, &
rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux)
!
! computes initialisation of diffusion coeff
!
CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, u, v, &
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb , &
& zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb , &
& rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
& swnet, swdown, ccanopy, humrel, frac_bare, veget, lai, qsintveg, qsintmax, assim_param, &
!MG
! & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
& vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, rstruct, cimean, rest_id, hist_id, hist2_id)
!
! computes initialisation of energy bilan
!
CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
! & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
!MG
& index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
& qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, &
!MG
! & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
& rveget, rstruct, cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
& vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
! & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id)
!MG
& temp_sol_new, qsurf, evapot, evapot_corr, etm, rest_id, hist_id, hist2_id)
!
! computes initialisation of hydrology
!
IF ( .NOT. hydrol_cwrr ) THEN
CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare,&
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, rsol, drysoil_frac, evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, &
& soilcap, rest_id, hist_id, hist2_id)
evap_bare_lim(:) = -un
k_litt(:) = huit
ELSE
CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, indexsoil, indexlayer,&
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, njsc,&
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, flood_frac, flood_res, &
& shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id)
rsol(:) = -un
ENDIF
!
! computes initialisation of condveg
!
CALL condveg_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
& lalo, neighbours, resolution, contfrac, veget, frac_nobio, totfrac_nobio, &
& zlev, snow, snow_age, snow_nobio, snow_nobio_age, frac_bare, &
& drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, rest_id, hist_id, hist2_id)
!
! computes initialisation of Soil Thermodynamic
!
CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
& index, indexgrnd, temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id)
!
! If we chose to route the water then we call the module. Else variables
! are set to zero.
!
!
IF ( river_routing .AND. kjpindex .GT. 1) THEN
CALL routing_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget, floodout, runoff, &
!MG
! & drainage, evapot_corr, precip_rain, humrel, k_litt, flood_frac, flood_res, &
& drainage, evapot_corr, etm, precip_rain, humrel, k_litt, flood_frac, flood_res, &
& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
ELSE
riverflow(:) = zero
coastalflow(:) = zero
returnflow(:) = zero
reinfiltration(:) = zero
irrigation(:) = zero
flood_frac(:) = zero
flood_res(:) = zero
ENDIF
!
! Write the internal variables into the output fields
!
z0_out(:) = z0(:)
emis_out(:) = emis(:)
albedo_out(:,:) = albedo(:,:)
qsurf_out(:) = qsurf(:)
!
! This line should remain last as it ends the initialisation and returns to the caling
! routine.
!
!Aurélien 2009
WRITE (numout,*) '-------------------------'
WRITE (numout,*) ' INITIALISATION TERMINEE '
WRITE (numout,*) ' etm(:,:)= ',etm(:,:)
WRITE (numout,*) ' humrel(:,:)= ',humrel(:,:)
WRITE (numout,*) '-------------------------'
RETURN
!
ENDIF
!
! computes some initialisation every SECHIBA's call
!
CALL sechiba_var_init (kjpindex, rau, pb, temp_air)
!
! computes slow variables
! ok_co2 and ok_stomate are interpreted as flags that determine whether the
! forcing files are written.
!
CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
ldrestart_read, myfalse, control%ok_co2, control%ok_stomate, &
index, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
t2mdiag, t2mdiag, temp_sol, stempdiag, &
vegstress, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, frac_bare, height, veget, frac_nobio, njsc, totfrac_nobio, qsintmax, &
rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux)
!
! computes diffusion coeff
!
CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, u, v, &
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb , &
& zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb , &
& rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
& swnet, swdown, ccanopy, humrel, frac_bare, veget, lai, qsintveg, qsintmax, assim_param, &
! & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
!MG
& vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, rstruct, cimean, rest_id, hist_id, hist2_id)
!
! computes energy bilan
!
CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, &
! & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
!MG
& index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
& qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, &
! & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
!MG
& rveget, rstruct, cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
& vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
! & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id)
!MG
& temp_sol_new, qsurf, evapot, evapot_corr, etm, rest_id, hist_id, hist2_id)
!
! computes hydrologie
!
IF ( .NOT. hydrol_cwrr ) THEN
CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, &
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, rsol, drysoil_frac, evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, &
& soilcap, rest_id, hist_id, hist2_id)
evap_bare_lim(:) = -un
k_litt(:) = huit
ELSE
CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, indexsoil, indexlayer, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, njsc,&
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, flood_frac, flood_res, &
& shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id)
rsol(:) = -un
ENDIF
!
! computes last part of energy bilan
!
CALL enerbil_fusion (kjpindex, dtradia, tot_melt, soilcap, temp_sol_new, fusion)
!
! computes condveg
!
CALL condveg_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index,&
& lalo, neighbours, resolution, contfrac, veget, frac_nobio, totfrac_nobio, &
& zlev, snow, snow_age, snow_nobio, snow_nobio_age, frac_bare, &
& drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, rest_id, hist_id, hist2_id)
!
! computes Soil Thermodynamic
!
CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexgrnd, &
& temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id)
!
! If we chose to route the water then we call the module. Else variables
! are set to zero.
!
!
IF ( river_routing .AND. kjpindex .GT. 1) THEN
CALL routing_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, &
& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget, floodout, runoff, &
! & drainage, evapot_corr, precip_rain, humrel, k_litt, flood_frac, flood_res, &
!MG
& drainage, evapot_corr, etm, precip_rain, humrel, k_litt, flood_frac, flood_res, &
& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
! returnflow(:) = returnflow(:) * 100.
ELSE
riverflow(:) = zero
coastalflow(:) = zero
returnflow(:) = zero
reinfiltration(:) = zero
irrigation(:) = zero
flood_frac(:) = zero
flood_res(:) = zero
ENDIF
!
! call swap from new computed variables
!
CALL sechiba_end (kjpindex, dtradia, temp_sol, temp_sol_new)
!
! Write the internal variables into the output fields
!
z0_out(:) = z0(:)
emis_out(:) = emis(:)
albedo_out(:,:) = albedo(:,:)
qsurf_out(:) = qsurf(:)
!
! Writing the global variables on the history tape
!
!
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist_id, 'beta', kjit, vbeta, kjpindex, index)
CALL histwrite(hist_id, 'z0', kjit, z0, kjpindex, index)
CALL histwrite(hist_id, 'roughheight', kjit, roughheight, kjpindex, index)
CALL histwrite(hist_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist_id, 'lai', kjit, lai, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'subli', kjit, vevapsno, kjpindex, index)
CALL histwrite(hist_id, 'evapflo', kjit, vevapflo, kjpindex, index)
CALL histwrite(hist_id, 'evapnu', kjit, vevapnu, kjpindex, index)
CALL histwrite(hist_id, 'transpir', kjit, transpir, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'inter', kjit, vevapwet, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'vbeta1', kjit, vbeta1, kjpindex, index)
CALL histwrite(hist_id, 'vbeta2', kjit, vbeta2, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'vbeta3', kjit, vbeta3, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'vbeta4', kjit, vbeta4, kjpindex, index)
CALL histwrite(hist_id, 'vbeta5', kjit, vbeta5, kjpindex, index)
CALL histwrite(hist_id, 'drysoil_frac', kjit, drysoil_frac, kjpindex, index)
CALL histwrite(hist_id, 'rveget', kjit, rveget, kjpindex*nvm, indexveg)
!MG
CALL histwrite(hist_id, 'rstruct', kjit, rstruct, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'flood_frac', kjit, flood_frac, kjpindex, index)
CALL histwrite(hist_id, 'k_litt', kjit, k_litt, kjpindex, index)
CALL histwrite(hist_id, 'rsol', kjit, rsol, kjpindex, index)
CALL histwrite(hist_id, 'snow', kjit, snow, kjpindex, index)
CALL histwrite(hist_id, 'snowage', kjit, snow_age, kjpindex, index)
CALL histwrite(hist_id, 'snownobio', kjit, snow_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist_id, 'snownobioage', kjit, snow_nobio_age, kjpindex*nnobio, indexnobio)
!MG
CALL histwrite(hist_id, 'frac_bare', kjit, frac_bare, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'soiltile', kjit, soiltile, kjpindex*nstm, indexsoil)
CALL histwrite(hist_id, 'soilindex', kjit, REAL(njsc, r_std), kjpindex, index)
CALL histwrite(hist_id, 'reinf_slope', kjit, reinf_slope, kjpindex, index)
IF ( control%ok_co2 ) THEN
CALL histwrite(hist_id, 'vbetaco2', kjit, vbetaco2, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'gpp', kjit, gpp, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'cimean', kjit, cimean, kjpindex*nvm, indexveg)
ENDIF
ELSE
CALL histwrite(hist_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
CALL histwrite(hist_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist_id, 'Qf', kjit, fusion, kjpindex, index)
CALL histwrite(hist_id, 'ESoil', kjit, vevapnu, kjpindex, index)
CALL histwrite(hist_id, 'EWater', kjit, vevapflo, kjpindex, index)
var_write(:)=zero
DO jv=1,nvm
var_write(:) = var_write(:) + transpir(:,jv)
ENDDO
CALL histwrite(hist_id, 'TVeg', kjit, var_write, kjpindex, index)
var_write(:)=zero
DO jv=1,nvm
var_write(:) = var_write(:) + vevapwet(:,jv)
ENDDO
CALL histwrite(hist_id, 'ECanop', kjit, var_write, kjpindex, index)
CALL histwrite(hist_id, 'ACond', kjit, tq_cdrag, kjpindex, index)
CALL histwrite(hist_id, 'SnowFrac', kjit, vbeta1, kjpindex, index)
IF ( control%ok_co2 ) THEN
CALL histwrite(hist_id, 'GPP', kjit, gpp, kjpindex*nvm, indexveg)
ENDIF
ENDIF
!
IF ( hist2_id > 0 ) THEN
IF ( .NOT. almaoutput ) THEN
CALL histwrite(hist2_id, 'tsol_rad', kjit, tsol_rad, kjpindex, index)
CALL histwrite(hist2_id, 'qsurf', kjit, qsurf, kjpindex, index)
CALL histwrite(hist2_id, 'albedo', kjit, albedo, kjpindex*2, indexalb)
CALL histwrite(hist2_id, 'emis', kjit, emis, kjpindex, index)
!
CALL histwrite(hist2_id, 'beta', kjit, vbeta, kjpindex, index)
CALL histwrite(hist2_id, 'z0', kjit, z0, kjpindex, index)
CALL histwrite(hist2_id, 'roughheight', kjit, roughheight, kjpindex, index)
CALL histwrite(hist2_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist2_id, 'lai', kjit, lai, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'subli', kjit, vevapsno, kjpindex, index)
CALL histwrite(hist2_id, 'vevapflo', kjit, vevapflo, kjpindex, index)
CALL histwrite(hist2_id, 'vevapnu', kjit, vevapnu, kjpindex, index)
CALL histwrite(hist2_id, 'transpir', kjit, transpir, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'inter', kjit, vevapwet, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'vbeta1', kjit, vbeta1, kjpindex, index)
CALL histwrite(hist2_id, 'vbeta2', kjit, vbeta2, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'vbeta3', kjit, vbeta3, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'vbeta4', kjit, vbeta4, kjpindex, index)
CALL histwrite(hist2_id, 'vbeta5', kjit, vbeta5, kjpindex, index)
CALL histwrite(hist2_id, 'drysoil_frac', kjit, drysoil_frac, kjpindex, index)
CALL histwrite(hist2_id, 'rveget', kjit, rveget, kjpindex*nvm, indexveg)
!MG
CALL histwrite(hist2_id, 'rstruct', kjit, rstruct, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'flood_frac', kjit, flood_frac, kjpindex, index)
CALL histwrite(hist2_id, 'k_litt', kjit, k_litt, kjpindex, index)
CALL histwrite(hist2_id, 'rsol', kjit, rsol, kjpindex, index)
CALL histwrite(hist2_id, 'snow', kjit, snow, kjpindex, index)
CALL histwrite(hist2_id, 'snowage', kjit, snow_age, kjpindex, index)
CALL histwrite(hist2_id, 'snownobio', kjit, snow_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist2_id, 'snownobioage', kjit, snow_nobio_age, kjpindex*nnobio, indexnobio)
CALL histwrite(hist2_id, 'soiltile', kjit, soiltile, kjpindex*nstm, indexsoil)
CALL histwrite(hist2_id, 'soilindex', kjit, REAL(njsc, r_std), kjpindex, index)
CALL histwrite(hist2_id, 'reinf_slope', kjit, reinf_slope, kjpindex, index)
IF ( control%ok_co2 ) THEN
CALL histwrite(hist2_id, 'vbetaco2', kjit, vbetaco2, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'gpp', kjit, gpp, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'cimean', kjit, cimean, kjpindex*nvm, indexveg)
ENDIF
ELSE
CALL histwrite(hist2_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
CALL histwrite(hist2_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
CALL histwrite(hist2_id, 'Qf', kjit, fusion, kjpindex, index)
CALL histwrite(hist2_id, 'SWE', kjit, snow, kjpindex, index)
CALL histwrite(hist2_id, 'ESoil', kjit, vevapnu, kjpindex, index)
CALL histwrite(hist2_id, 'EWater', kjit, vevapflo, kjpindex, index)
var_write(:)=zero
DO jv=1,nvm
var_write(:) = var_write(:) + transpir(:,jv)
ENDDO
CALL histwrite(hist2_id, 'TVeg', kjit, var_write, kjpindex, index)
var_write(:)=zero
DO jv=1,nvm
var_write(:) = var_write(:) + vevapwet(:,jv)
ENDDO
CALL histwrite(hist2_id, 'ECanop', kjit, vevapwet, kjpindex, index)
CALL histwrite(hist2_id, 'ACond', kjit, tq_cdrag, kjpindex, index)
CALL histwrite(hist2_id, 'SnowFrac', kjit, vbeta1, kjpindex, index)
IF ( control%ok_co2 ) THEN
CALL histwrite(hist2_id, 'GPP', kjit, gpp, kjpindex*nvm, indexveg)
ENDIF
ENDIF
ENDIF
!
! prepares restart file for the next simulation from SECHIBA and from other modules
!
IF (ldrestart_write) THEN
IF (long_print) WRITE (numout,*) ' we have to write a restart file '
!
! call slowproc_main to write restart files
!
CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
ldrestart_read, ldrestart_write, control%ok_co2, control%ok_stomate, &
index, indexveg, lalo, neighbours, resolution, contfrac, soiltile, reinf_slope, &
t2mdiag, t2mdiag, temp_sol, stempdiag, &
vegstress, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
deadleaf_cover, &
assim_param, &
lai, frac_bare, height, veget, frac_nobio, njsc, totfrac_nobio, qsintmax, &
rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, &
co2_flux)
!
! call diffuco_main to write restart files
!
CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, u, v, &
! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
! & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb , &
& zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb , &
& rsol, evap_bare_lim, evapot, evapot_corr, snow, flood_frac, flood_res, frac_nobio, snow_nobio, totfrac_nobio, &
& swnet, swdown, ccanopy, humrel, frac_bare, veget, lai, qsintveg, qsintmax, assim_param, &
! & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
!MG
& vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, rveget, rstruct, cimean, rest_id, hist_id, hist2_id)
!
! call energy bilan to write restart files
!
CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
! & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
!MG
& index, indexveg, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
& qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbeta5, vbetaco2, &
! & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
!MG
& rveget, rstruct, cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
& vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, vevapflo, t2mdiag, temp_sol, tsol_rad, &
! & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id)
!MG
& temp_sol_new, qsurf, evapot, evapot_corr, etm, rest_id, hist_id, hist2_id)
!
! call hydrologie to write restart files
!
IF ( .NOT. hydrol_cwrr ) THEN
CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare,&
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, rsol, drysoil_frac, evapot, evapot_corr, flood_frac, flood_res, shumdiag, litterhumdiag, &
& soilcap, rest_id, hist_id, hist2_id)
evap_bare_lim(:) = -un
k_litt(:) = huit
ELSE
CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, indexsoil, indexlayer, &
& temp_sol_new, floodout, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, frac_bare, njsc, &
& qsintmax, qsintveg, vevapnu, vevapsno, vevapflo, snow, snow_age, snow_nobio, snow_nobio_age,&
& tot_melt, transpir, precip_rain, precip_snow, returnflow, reinfiltration, irrigation, humrel, &
& vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, flood_frac, flood_res, &
& shumdiag, k_litt, litterhumdiag, soilcap, soiltile, reinf_slope, rest_id, hist_id, hist2_id)
rsol(:) = -un
ENDIF
!
! call condveg to write restart files
!
CALL condveg_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
& lalo, neighbours, resolution, contfrac, veget, frac_nobio, totfrac_nobio, &
& zlev, snow, snow_age, snow_nobio, snow_nobio_age, frac_bare, &
& drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, rest_id, hist_id, hist2_id)
!
! call Soil Thermodynamic to write restart files
!
CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexgrnd, &
& temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id)
!
! If we chose to route the water then we call the module. Else variables
! are set to zero.
!
!
IF ( river_routing .AND. kjpindex .GT. 1) THEN
CALL routing_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
& lalo, neighbours, resolution, contfrac, totfrac_nobio, veget, floodout, runoff, &
! & drainage, evapot_corr, precip_rain, humrel, k_litt, flood_frac, flood_res, &
!MG
& drainage, evapot_corr, etm, precip_rain, humrel, k_litt, flood_frac, flood_res, &
& stempdiag, reinf_slope, returnflow, reinfiltration, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
ELSE
riverflow(:) = zero
coastalflow(:) = zero
reinfiltration(:) = zero
returnflow(:) = zero
irrigation(:) = zero
flood_frac(:) = zero
flood_res(:) = zero
ENDIF
END IF
IF (long_print) WRITE (numout,*) ' sechiba_main done '
END SUBROUTINE sechiba_main
!! Initialisation for SECHIBA processes
!! - does dynamic allocation for local arrays
!! - reads _restart_ file or set initial values to a raisonable value
!! - reads initial map
!!
SUBROUTINE sechiba_init (kjit, ldrestart_read, kjpij, kjpindex, index, rest_id, control_in, lalo)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjit !! Time step number
LOGICAL,INTENT (in) :: ldrestart_read !! Logical for restart file to read
INTEGER(i_std), INTENT (in) :: kjpij !! Size of full domaine
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain size
INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index !! Indeces of the points on the map
INTEGER(i_std), INTENT (in) :: rest_id !! _Restart_ file identifier
TYPE(control_type), INTENT(in) :: control_in !! Flags that (de)activate parts of the model
! input fields
REAL(r_std),DIMENSION (kjpindex,2), INTENT (in) :: lalo !! Geographical coordinates
! output scalar
! output fields
! local declaration
INTEGER(i_std) :: ier, ipdt, ji, jv
!
! initialisation
!
IF (l_first_sechiba) THEN
l_first_sechiba=.FALSE.
ELSE
WRITE (numout,*) ' l_first_sechiba false . we stop '
STOP 'sechiba_init'
ENDIF
! 1. make dynamic allocation with good dimension
! 1.0 The 3D vegetation indexation table
ALLOCATE (indexveg(kjpindex*nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexveg allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (indexsoil(kjpindex*nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexsoil allocation. We stop. We need kjpindex words = ',kjpindex*nstm
STOP 'sechiba_init'
END IF
ALLOCATE (indexnobio(kjpindex*nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexnobio allocation. We stop. We need kjpindex words = ',kjpindex*nnobio
STOP 'sechiba_init'
END IF
ALLOCATE (indexgrnd(kjpindex*ngrnd),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexgrnd allocation. We stop. We need kjpindex words = ',kjpindex*ngrnd
STOP 'sechiba_init'
END IF
ALLOCATE (indexlayer(kjpindex*nslm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexlayer allocation. We stop. We need kjpindex words = ',kjpindex*nslm
STOP 'sechiba_init'
END IF
ALLOCATE (indexalb(kjpindex*2),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in indexalb allocation. We stop. We need kjpindex words = ',kjpindex*2
STOP 'sechiba_init'
END IF
! 1.1 one dimension array allocation with restartable value
IF (long_print) WRITE (numout,*) 'Allocation of 1D variables. We need for each kjpindex words = ',kjpindex
ALLOCATE (flood_res(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in flood_res allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
flood_res(:) = undef_sechiba
IF (long_print) WRITE (numout,*) 'Allocation of 1D variables. We need for each kjpindex words = ',kjpindex
ALLOCATE (flood_frac(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in flood_frac allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
flood_frac(:) = undef_sechiba
IF (long_print) WRITE (numout,*) 'Allocation of 1D variables. We need for each kjpindex words = ',kjpindex
ALLOCATE (snow(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
snow(:) = undef_sechiba
ALLOCATE (snow_age(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_age allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
snow_age(:) = undef_sechiba
ALLOCATE (drysoil_frac(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in drysoil_frac allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (rsol(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rsol allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (evap_bare_lim(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in evap_bare_lim allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (evapot(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in evapot allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
evapot(:) = undef_sechiba
ALLOCATE (evapot_corr(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in evapot_corr allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
!MG
ALLOCATE (etm(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in etm allocation. We stop. We need kjpindex words = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (humrel(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in humrel allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
humrel(:,:) = undef_sechiba
ALLOCATE (vegstress(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vegstress allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
vegstress(:,:) = undef_sechiba
ALLOCATE (njsc(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in njsc allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
njsc(:)= undef_int
ALLOCATE (soiltile(kjpindex,nstm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soiltile allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
soiltile(:,:)=undef_sechiba
ALLOCATE (reinf_slope(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in reinf_slope allocation. We stop. we need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
reinf_slope(:)=undef_sechiba
ALLOCATE (vbeta1(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta1 allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vbeta4(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta4 allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vbeta5(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta5 allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (soilcap(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soilcap allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (soilflx(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in soilflx allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (temp_sol(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in temp_sol allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
temp_sol(:) = undef_sechiba
ALLOCATE (qsurf(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsurf allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
qsurf(:) = undef_sechiba
! 1.2 two dimensions array allocation with restartable value
ALLOCATE (qsintveg(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsintveg allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm,' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
qsintveg(:,:) = undef_sechiba
ALLOCATE (vbeta2(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta2 allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (vbeta3(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta3 allocation. We stop.We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (vbetaco2(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbetaco2 allocation. We stop.We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (cimean(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in cimean allocation. We stop.We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (gpp(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in gpp allocation. We stop.We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
gpp(:,:) = undef_sechiba
ALLOCATE (veget(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in veget allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
veget(:,:)=undef_sechiba
ALLOCATE (lai(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in lai allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
lai(:,:)=undef_sechiba
ALLOCATE (frac_bare(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in frac_bare allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
frac_bare(:,:)=undef_sechiba
ALLOCATE (height(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in height allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
height(:,:)=undef_sechiba
ALLOCATE (frac_nobio(kjpindex,nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in frac_nobio allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
frac_nobio(:,:)=undef_sechiba
ALLOCATE (albedo(kjpindex,2),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in albedo allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (snow_nobio(kjpindex,nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_nobio allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
snow_nobio(:,:) = undef_sechiba
ALLOCATE (snow_nobio_age(kjpindex,nnobio),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in snow_nobio_age allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
snow_nobio_age(:,:) = undef_sechiba
ALLOCATE (assim_param(kjpindex,nvm,npco2),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in assim_param allocation. We stop. We need kjpindex x nvm x npco2 words = ',&
& kjpindex,' x ' ,nvm,' x ',npco2, ' = ',kjpindex*nvm*npco2
STOP 'sechiba_init'
END IF
! 1.3 one dimension array allocation
ALLOCATE (vevapflo(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vevapflo allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vevapsno(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vevapsno allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vevapnu(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vevapnu allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (t2mdiag(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in t2mdiag allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (totfrac_nobio(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in totfrac_nobio allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (floodout(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in floodout allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (runoff(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in runoff allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (drainage(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in drainage allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (returnflow(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in returnflow allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
returnflow(:) = zero
ALLOCATE (reinfiltration(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in reinfiltration allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
reinfiltration(:) = zero
ALLOCATE (irrigation(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in irrigation allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
irrigation(:) = zero
ALLOCATE (z0(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in z0 allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (roughheight(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in roughheight allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (emis(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in emis allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (tot_melt(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in tot_melt allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (valpha(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in valpha allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (vbeta(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vbeta allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (fusion(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in fusion allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (rau(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rau allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (deadleaf_cover(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in deadleaf_cover allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (stempdiag(kjpindex, nbdl),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in stempdiag allocation. We stop. We need kjpindex*nbdl words = ',&
& kjpindex*nbdl
STOP 'sechiba_init'
END IF
ALLOCATE (co2_flux(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in co2_flux allocation. We stop. We need kjpindex words = ' ,kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (shumdiag(kjpindex,nbdl),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in shumdiag allocation. We stop. We need kjpindex*nbdl words = ',&
& kjpindex*nbdl
STOP 'sechiba_init'
END IF
ALLOCATE (litterhumdiag(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in litterhumdiag allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
ALLOCATE (k_litt(kjpindex),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in k_litt allocation. We stop. We need kjpindex words = ',kjpindex
STOP 'sechiba_init'
END IF
! 1.4 two dimensions array allocation
ALLOCATE (vevapwet(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in vevapwet allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
vevapwet(:,:)=undef_sechiba
ALLOCATE (transpir(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in transpir allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (qsintmax(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in qsintmax allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
ALLOCATE (rveget(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rveget allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
!MG
ALLOCATE (rstruct(kjpindex,nvm),stat=ier)
IF (ier.NE.0) THEN
WRITE (numout,*) ' error in rstruct allocation. We stop. We need kjpindex x nvm words = ',&
& kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
STOP 'sechiba_init'
END IF
!
! 1.5 Get the indexing table for the vegetation fields. In SECHIBA we work on reduced grids but to store in the
! full 3D filed vegetation variable we need another index table : indexveg, indexsoil, indexnobio and
! indexgrnd
!
DO ji = 1, kjpindex
!
DO jv = 1, nvm
indexveg((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, nstm
indexsoil((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, nnobio
indexnobio((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, ngrnd
indexgrnd((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, nslm
indexlayer((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
DO jv = 1, 2
indexalb((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
ENDDO
!
ENDDO
! tdo - diaglev is now computed in intersurf (for output reasons - see histvert)
!
! 2. restart value
!
! open restart input file if needed
! and read data from restart input file
!
IF (ldrestart_read) THEN
IF (long_print) WRITE (numout,*) ' we have to read a restart file for SECHIBA variables'
!
! Read the default value that will be put into variable which are not in the restart file
!
CALL ioget_expval(val_exp)
ENDIF
!
river_routing = control_in%river_routing
hydrol_cwrr = control_in%hydrol_cwrr
!
! 4. run control: store flags in a common variable
!
! tdo - ajout de hydrol_cwrr ici pour fonctionnement de diffuco
control%hydrol_cwrr = control_in%hydrol_cwrr
control%ok_co2 = control_in%ok_co2
control%ok_sechiba = control_in%ok_sechiba
control%ok_stomate = control_in%ok_stomate
control%ok_dgvm = control_in%ok_dgvm
control%ok_pheno = control_in%ok_pheno
control%stomate_watchout = control_in%stomate_watchout
IF (long_print) WRITE (numout,*) ' sechiba_init done '
END SUBROUTINE sechiba_init
!
!------------------------------------------------------------------
!
SUBROUTINE sechiba_clear (forcing_name,cforcing_name)
CHARACTER(LEN=100), INTENT(in) :: forcing_name
CHARACTER(LEN=100), INTENT(in) :: cforcing_name
!
! initialisation
!
l_first_sechiba=.TRUE.
! 1. Deallocate all dynamic variables
IF ( ALLOCATED (indexveg)) DEALLOCATE (indexveg)
IF ( ALLOCATED (indexsoil)) DEALLOCATE (indexsoil)
IF ( ALLOCATED (indexnobio)) DEALLOCATE (indexnobio)
IF ( ALLOCATED (indexgrnd)) DEALLOCATE (indexgrnd)
IF ( ALLOCATED (indexlayer)) DEALLOCATE (indexlayer)
IF ( ALLOCATED (indexalb)) DEALLOCATE (indexalb)
IF ( ALLOCATED (flood_res)) DEALLOCATE (flood_res)
IF ( ALLOCATED (flood_frac)) DEALLOCATE (flood_frac)
IF ( ALLOCATED (snow)) DEALLOCATE (snow)
IF ( ALLOCATED (snow_age)) DEALLOCATE (snow_age)
IF ( ALLOCATED (drysoil_frac)) DEALLOCATE (drysoil_frac)
IF ( ALLOCATED (rsol)) DEALLOCATE (rsol)
IF ( ALLOCATED (evap_bare_lim)) DEALLOCATE (evap_bare_lim)
IF ( ALLOCATED (evapot)) DEALLOCATE (evapot)
IF ( ALLOCATED (evapot_corr)) DEALLOCATE (evapot_corr)
!MG
IF ( ALLOCATED (etm)) DEALLOCATE (etm)
IF ( ALLOCATED (humrel)) DEALLOCATE (humrel)
IF ( ALLOCATED (vegstress)) DEALLOCATE (vegstress)
IF ( ALLOCATED (soiltile)) DEALLOCATE (soiltile)
IF ( ALLOCATED (njsc)) DEALLOCATE (njsc)
IF ( ALLOCATED (reinf_slope)) DEALLOCATE (reinf_slope)
IF ( ALLOCATED (vbeta1)) DEALLOCATE (vbeta1)
IF ( ALLOCATED (vbeta4)) DEALLOCATE (vbeta4)
IF ( ALLOCATED (vbeta5)) DEALLOCATE (vbeta5)
IF ( ALLOCATED (soilcap)) DEALLOCATE (soilcap)
IF ( ALLOCATED (soilflx)) DEALLOCATE (soilflx)
IF ( ALLOCATED (temp_sol)) DEALLOCATE (temp_sol)
IF ( ALLOCATED (qsurf)) DEALLOCATE (qsurf)
IF ( ALLOCATED (qsintveg)) DEALLOCATE (qsintveg)
IF ( ALLOCATED (vbeta2)) DEALLOCATE (vbeta2)
IF ( ALLOCATED (vbeta3)) DEALLOCATE (vbeta3)
IF ( ALLOCATED (vbetaco2)) DEALLOCATE (vbetaco2)
IF ( ALLOCATED (cimean)) DEALLOCATE (cimean)
IF ( ALLOCATED (gpp)) DEALLOCATE (gpp)
IF ( ALLOCATED (veget)) DEALLOCATE (veget)
IF ( ALLOCATED (lai)) DEALLOCATE (lai)
IF ( ALLOCATED (frac_bare)) DEALLOCATE (frac_bare)
IF ( ALLOCATED (height)) DEALLOCATE (height)
IF ( ALLOCATED (roughheight)) DEALLOCATE (roughheight)
IF ( ALLOCATED (frac_nobio)) DEALLOCATE (frac_nobio)
IF ( ALLOCATED (snow_nobio)) DEALLOCATE (snow_nobio)
IF ( ALLOCATED (snow_nobio_age)) DEALLOCATE (snow_nobio_age)
IF ( ALLOCATED (assim_param)) DEALLOCATE (assim_param)
IF ( ALLOCATED (vevapflo)) DEALLOCATE (vevapflo)
IF ( ALLOCATED (vevapsno)) DEALLOCATE (vevapsno)
IF ( ALLOCATED (vevapnu)) DEALLOCATE (vevapnu)
IF ( ALLOCATED (t2mdiag)) DEALLOCATE (t2mdiag)
IF ( ALLOCATED (totfrac_nobio)) DEALLOCATE (totfrac_nobio)
IF ( ALLOCATED (floodout)) DEALLOCATE (floodout)
IF ( ALLOCATED (runoff)) DEALLOCATE (runoff)
IF ( ALLOCATED (drainage)) DEALLOCATE (drainage)
IF ( ALLOCATED (reinfiltration)) DEALLOCATE (reinfiltration)
IF ( ALLOCATED (irrigation)) DEALLOCATE (irrigation)
IF ( ALLOCATED (tot_melt)) DEALLOCATE (tot_melt)
IF ( ALLOCATED (valpha)) DEALLOCATE (valpha)
IF ( ALLOCATED (vbeta)) DEALLOCATE (vbeta)
IF ( ALLOCATED (fusion)) DEALLOCATE (fusion)
IF ( ALLOCATED (rau)) DEALLOCATE (rau)
IF ( ALLOCATED (deadleaf_cover)) DEALLOCATE (deadleaf_cover)
IF ( ALLOCATED (stempdiag)) DEALLOCATE (stempdiag)
IF ( ALLOCATED (co2_flux)) DEALLOCATE (co2_flux)
IF ( ALLOCATED (shumdiag)) DEALLOCATE (shumdiag)
IF ( ALLOCATED (litterhumdiag)) DEALLOCATE (litterhumdiag)
IF ( ALLOCATED (k_litt)) DEALLOCATE (k_litt)
IF ( ALLOCATED (vevapwet)) DEALLOCATE (vevapwet)
IF ( ALLOCATED (transpir)) DEALLOCATE (transpir)
IF ( ALLOCATED (qsintmax)) DEALLOCATE (qsintmax)
IF ( ALLOCATED (rveget)) DEALLOCATE (rveget)
!MG
IF ( ALLOCATED (rstruct)) DEALLOCATE (rstruct)
! 2. clear all modules
CALL slowproc_clear
CALL diffuco_clear
CALL enerbil_clear
IF ( hydrol_cwrr ) THEN
CALL hydrol_clear
ELSE
CALL hydrolc_clear
ENDIF
CALL condveg_clear
CALL thermosoil_clear
CALL routing_clear
!3. give name to next block
stomate_forcing_name=forcing_name
stomate_Cforcing_name=Cforcing_name
END SUBROUTINE sechiba_clear
!! SECHIBA's variables initialisation
!! called every time step
!!
SUBROUTINE sechiba_var_init (kjpindex, rau, pb, temp_air)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain dimension
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: pb !! Lowest level pressure
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_air !! Air temperature
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: rau !! Density
! local declaration
INTEGER(i_std) :: ji
!
! initialisation
!
!
! 1. calcul of rau: air density
!
DO ji = 1,kjpindex
rau(ji) = pa_par_hpa * pb(ji) / (cte_molr*temp_air(ji))
END DO
IF (long_print) WRITE (numout,*) ' sechiba_var_init done '
END SUBROUTINE sechiba_var_init
!!
!! Swap new fields to previous fields
!!
SUBROUTINE sechiba_end (kjpindex, dtradia, temp_sol, temp_sol_new)
! interface description
! input scalar
INTEGER(i_std), INTENT (in) :: kjpindex !! Domain dimension
REAL(r_std),INTENT (in) :: dtradia !! Time step in seconds
! input fields
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: temp_sol_new !! New soil temperature
! output fields
REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: temp_sol !! Soil temperature
! local declaration
INTEGER(i_std) :: ji
!
! swap
!
temp_sol(:) = temp_sol_new(:)
IF (long_print) WRITE (numout,*) ' sechiba_end done '
END SUBROUTINE sechiba_end
END MODULE sechiba
ORCHIDEE/src_stomate/ 0000754 0103600 0005670 00000000000 11202267447 014247 5 ustar acamlmd lmdjus ORCHIDEE/src_stomate/CVS/ 0000754 0103600 0005670 00000000000 11164403473 014700 5 ustar acamlmd lmdjus ORCHIDEE/src_stomate/CVS/Root 0000754 0103600 0005670 00000000071 11164403473 015547 0 ustar acamlmd lmdjus :pserver:sechiba@cvs.ipsl.jussieu.fr:/home/ssipsl/CVSREP
ORCHIDEE/src_stomate/CVS/Repository 0000754 0103600 0005670 00000000025 11164403473 017002 0 ustar acamlmd lmdjus ORCHIDEE/src_stomate
ORCHIDEE/src_stomate/CVS/Entries 0000754 0103600 0005670 00000003434 11164403473 016243 0 ustar acamlmd lmdjus /AA_make/1.21/Wed Jun 13 08:06:56 2007//Torchidee_1_9
/AA_make.ldef/1.8/Tue Nov 7 07:57:08 2006//Torchidee_1_9
/lpj_constraints.f90/1.7/Mon May 28 14:49:02 2007//Torchidee_1_9
/lpj_cover.f90/1.7/Mon May 28 14:49:02 2007//Torchidee_1_9
/lpj_crown.f90/1.11/Mon May 28 14:49:02 2007//Torchidee_1_9
/lpj_establish.f90/1.8/Mon May 28 14:49:02 2007//Torchidee_1_9
/lpj_fire.f90/1.9/Wed Jun 13 07:44:34 2007//Torchidee_1_9
/lpj_gap.f90/1.8/Wed Jun 13 07:44:34 2007//Torchidee_1_9
/lpj_kill.f90/1.7/Mon May 28 14:49:02 2007//Torchidee_1_9
/lpj_light.f90/1.7/Mon May 28 14:49:02 2007//Torchidee_1_9
/lpj_pftinout.f90/1.7/Mon May 28 14:49:02 2007//Torchidee_1_9
/stomate.f90/1.30/Wed Jun 13 08:04:56 2007//Torchidee_1_9
/stomate_alloc.f90/1.9/Mon May 28 14:49:02 2007//Torchidee_1_9
/stomate_assimtemp.f90/1.6/Mon May 28 14:49:02 2007//Torchidee_1_9
/stomate_constants.f90/1.17/Mon May 28 14:41:53 2007//Torchidee_1_9
/stomate_data.f90/1.10/Mon May 28 14:51:50 2007//Torchidee_1_9
/stomate_deforestation.f90/1.5/Wed Jun 13 07:55:43 2007//Torchidee_1_9
/stomate_io.f90/1.16/Wed Jun 13 07:53:08 2007//Torchidee_1_9
/stomate_litter.f90/1.7/Mon May 28 15:03:35 2007//Torchidee_1_9
/stomate_lpj.f90/1.14/Wed Jun 13 07:44:34 2007//Torchidee_1_9
/stomate_natagritot.f90/1.6/Mon May 28 14:49:02 2007//Torchidee_1_9
/stomate_npp.f90/1.10/Mon May 28 14:49:02 2007//Torchidee_1_9
/stomate_phenology.f90/1.9/Mon May 28 14:49:02 2007//Torchidee_1_9
/stomate_prescribe.f90/1.9/Mon May 28 14:49:02 2007//Torchidee_1_9
/stomate_resp.f90/1.6/Mon May 28 14:57:23 2007//Torchidee_1_9
/stomate_season.f90/1.11/Mon May 28 14:49:02 2007//Torchidee_1_9
/stomate_soilcarbon.f90/1.6/Mon May 28 14:49:02 2007//Torchidee_1_9
/stomate_turnover.f90/1.11/Mon May 28 14:44:55 2007//Torchidee_1_9
/stomate_vmax.f90/1.8/Mon May 28 14:49:02 2007//Torchidee_1_9
D
ORCHIDEE/src_stomate/CVS/Tag 0000754 0103600 0005670 00000000016 11164403473 015336 0 ustar acamlmd lmdjus Norchidee_1_9
ORCHIDEE/src_stomate/CVS/Template 0000754 0103600 0005670 00000000000 11164403473 016367 0 ustar acamlmd lmdjus ORCHIDEE/src_stomate/AA_make 0000754 0103600 0005670 00000013774 11164403473 015465 0 ustar acamlmd lmdjus #-
#- $Id: AA_make,v 1.24 2008/01/08 11:49:08 ssipsl Exp $
#-
PARAM_LIB = $(LIBDIR)/libparameters.a
SXPARAM_LIB = $(PARAM_LIB)
#-Q- sxnec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-Q- sx6nec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-Q- eshpux SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-Q- sx8brodie SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
#-
PARALLEL_LIB = $(LIBDIR)/libparallel.a
SXPARALLEL_LIB = $(PARALLEL_LIB)
#-Q- sxnec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
#-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
#-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
#-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
#-
MODS1 = stomate_constants.f90 \
stomate_natagritot.f90 \
lpj_constraints.f90 \
lpj_cover.f90 \
lpj_crown.f90 \
lpj_establish.f90 \
lpj_fire.f90 \
lpj_gap.f90 \
lpj_kill.f90 \
lpj_light.f90 \
lpj_pftinout.f90 \
stomate_alloc.f90 \
stomate_data.f90 \
stomate_io.f90 \
stomate_litter.f90 \
stomate_npp.f90 \
stomate_phenology.f90 \
stomate_prescribe.f90 \
stomate_season.f90 \
stomate_soilcarbon.f90 \
stomate_turnover.f90 \
stomate_vmax.f90 \
stomate_assimtemp.f90 \
stomate_deforestation.f90 \
stomate_lpj.f90 \
stomate_resp.f90 \
stomate.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-Q- sxnec .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
#-
all:
$(M_K) libparameters
$(M_K) libparallel
$(M_K) m_all
@echo stomate is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
#-Q- intel m_all: WORK_MOD $(MODEL_LIB)($(OBJSMODS1))
memory:
#-Q- sxnec @echo maximum memory must be defined on Rhodes
#-Q- sxnec @echo in sh or ksh : ulimit -v unlimited
#-Q- sxnec @echo in csh or tcsh : limit vmemoryuse unlimited
#-Q- sxnec -/sbin/ulimit -v unlimited
#-Q- sxnec -limit vmemoryuse unlimited
libparameters:
(cd ../src_parameters; $(M_K) -f Makefile)
libparallel:
(cd ../src_parallel; $(M_K) -f Makefile)
$(MODEL_LIB)(%.o): %.f90
$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
$(A_C) $(MODEL_LIB) $*.o
#-Q- sxnec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sxnec mv $*.mod $(MODDIR)
#-Q- sx6nec $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx6nec mv $*.mod $(MODDIR)
#-Q- eshpux $(A_X) $(SXMODEL_LIB) $*.o
#-Q- eshpux mv $*.mod $(MODDIR)
#-Q- sx8mercure mv $*.mod $(MODDIR)
#-Q- sx8brodie $(A_X) $(SXMODEL_LIB) $*.o
#-Q- sx8brodie mv $*.mod $(MODDIR)
#-Q- solaris mv $*.mod $(MODDIR)
$(RM) $*.o
#-Q- intel
#-Q- intel WORK_MOD:
#-Q- intel $(RM) work.pcl
#-Q- intel @echo "work.pc" > work.pcl
#-Q- intel @echo "../src_parameters/work.pc" >> work.pcl
#-Q- intel @echo "../../IOIPSL/src/work.pc" >> work.pcl
config:
$(BINDIR)/Fparser -name STOMATE $(MODS1)
echo 'Configuration of STOMATE done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(stomate.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(MODEL_LIB)(stomate_lpj.o)
$(MODEL_LIB)(stomate_constants.o): \
$(PARAM_LIB)(constantes_veg.o)
$(MODEL_LIB)(stomate_natagritot.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_constraints.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_cover.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_crown.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_establish.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_fire.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_gap.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_kill.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_light.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_pftinout.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_alloc.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_data.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_io.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_litter.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_npp.o): \
$(MODEL_LIB)(stomate_natagritot.o)
$(MODEL_LIB)(stomate_phenology.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_prescribe.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_resp.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_season.o): \
$(MODEL_LIB)(stomate_natagritot.o)
$(MODEL_LIB)(stomate_soilcarbon.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_turnover.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_vmax.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_assimtemp.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_deforestation.o): \
$(MODEL_LIB)(stomate_data.o)
$(MODEL_LIB)(stomate_lpj.o): \
$(MODEL_LIB)(stomate_natagritot.o) \
$(MODEL_LIB)(lpj_constraints.o) \
$(MODEL_LIB)(lpj_cover.o) \
$(MODEL_LIB)(lpj_crown.o) \
$(MODEL_LIB)(lpj_establish.o) \
$(MODEL_LIB)(lpj_fire.o) \
$(MODEL_LIB)(lpj_gap.o) \
$(MODEL_LIB)(lpj_kill.o) \
$(MODEL_LIB)(lpj_light.o) \
$(MODEL_LIB)(lpj_pftinout.o) \
$(MODEL_LIB)(stomate_alloc.o) \
$(MODEL_LIB)(stomate_data.o) \
$(MODEL_LIB)(stomate_io.o) \
$(MODEL_LIB)(stomate_litter.o) \
$(MODEL_LIB)(stomate_npp.o) \
$(MODEL_LIB)(stomate_phenology.o) \
$(MODEL_LIB)(stomate_prescribe.o) \
$(MODEL_LIB)(stomate_season.o) \
$(MODEL_LIB)(stomate_soilcarbon.o) \
$(MODEL_LIB)(stomate_turnover.o) \
$(MODEL_LIB)(stomate_vmax.o) \
$(MODEL_LIB)(stomate_assimtemp.o) \
$(MODEL_LIB)(stomate_resp.o) \
$(MODEL_LIB)(stomate_deforestation.o)
ORCHIDEE/src_stomate/AA_make.ldef 0000754 0103600 0005670 00000001346 11164403473 016366 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.9 2008/01/08 11:49:08 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a STOMATE
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/libstomate.a
SXMODEL_LIB = $(MODEL_LIB)
#-Q- sxnec SXMODEL_LIB = $(LIBDIR)/libsxstomate.a
#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxstomate.a
#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxstomate.a
#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxstomate.a
ORCHIDEE/src_stomate/lpj_constraints.f90 0000754 0103600 0005670 00000012721 11164403473 020007 0 ustar acamlmd lmdjus ! determine whether a PFT is adapted and can regenerate
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_constraints.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE lpj_constraints
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC constraints,constraints_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE constraints_clear
firstcall = .TRUE.
END SUBROUTINE constraints_clear
SUBROUTINE constraints (npts, dt, &
t2m_month, t2m_min_daily, when_growthinit, &
adapted, regenerate)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step (in days)
REAL(r_std), INTENT(in) :: dt
! "monthly" 2-meter temperature (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
! Daily minimum 2-meter temperature (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_min_daily
! how many days ago was the beginning of the growing season
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: when_growthinit
! 0.2 output fields
! Winter too cold? between 0 and 1
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: adapted
! Winter sufficiently cold? between 0 and 1
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: regenerate
! 0.3 local
! Memory length for adaption (d)
REAL(r_std) :: tau_adapt
! Memory length for regeneration (d)
REAL(r_std) :: tau_regenerate
! longest sustainable time without regeneration (vernalization)
REAL(r_std), PARAMETER :: too_long = 5.
! critical value of "regenerate" below which plant dies
REAL(r_std) :: regenerate_min
! index
INTEGER(i_std) :: j
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering constraints'
!
! 1 Initializations
!
tau_adapt = one_year
tau_regenerate = one_year
!
! 1.1 Messages
!
IF ( firstcall ) THEN
WRITE(numout,*) 'constraints:'
WRITE(numout,*) ' > Memory length for adaption (d): ',tau_adapt
WRITE(numout,*) ' > Memory length for regeneration (d): ',tau_regenerate
WRITE(numout,*) ' > Longest sustainable time without vernalization (y):', too_long
WRITE(numout,*) ' > For trees, longest sustainable time without growth init (y):', &
too_long
firstcall = .FALSE.
ENDIF
!
! 1.2 critical value for "regenerate": below this value, the last vernalization
! belong to a too distant past. PFT is then not adapted.
!
regenerate_min = exp ( - too_long * one_year / tau_regenerate )
!
! 2 Loop over all PFTs
!
DO j = 1, npft
IF ( natural(j) .OR. agriculture ) THEN
!
! 2.1 climate criteria
!
! 2.1.1 Test if PFT is adapted: check daily temperature.
! If too cold, PFT is not adapted.
IF ( tmin_crit(j) .EQ. undef ) THEN
! 2.1.1.1 some PFTs always survive.
adapted(:,j) = 1.
ELSE
! 2.1.1.2 frost-sensitive PFTs
WHERE ( t2m_min_daily(:) .LT. tmin_crit(j) )
adapted(:,j) = 0.
ENDWHERE
! limited memory: after some time, the cold shock is forgotten.
! ( adapted will approach 1)
adapted(:,j) = 1. - ( 1. - adapted(:,j) ) * (tau_adapt- dt)/tau_adapt
ENDIF
!
! 2.1.2 seasonal trees die if leafage does not show a clear seasonality.
! (i.e. if the start of the growing season is never detected).
!
IF ( tree(j) .AND. ( pheno_crit%pheno_model(j) .NE. 'none' ) ) THEN
WHERE ( when_growthinit(:,j) .GT. too_long*one_year )
adapted(:,j) = 0.
ENDWHERE
ENDIF
! 2.1.3 Test if PFT is regenerative
! check monthly temperature. If sufficiently cold, PFT will be able to
! regenerate for some time.
IF ( tcm_crit(j) .EQ. undef ) THEN
! 2.1.3.1 several PFTs (ex: evergreen) don't need vernalization
regenerate(:,j) = 1.
ELSE
! 2.1.3.2 PFT needs vernaliztion
WHERE ( t2m_month(:) .LE. tcm_crit(j) )
regenerate(:,j) = 1.
ENDWHERE
! limited memory: after some time, the winter is forgotten.
! (regenerate will approach 0)
regenerate(:,j) = regenerate(:,j) * (tau_regenerate-dt)/tau_regenerate
ENDIF
! 2.1.4 Plants that need vernalization die after a few years if they don't
! vernalize (even if they would not loose their leaves).
WHERE ( regenerate(:,j) .LE. regenerate_min )
adapted(:,j) = 0.
ENDWHERE
ELSE
!
! 2.2 PFT is not natural and agriculture is not allowed -> remove
!
adapted(:,j) = 0.
regenerate(:,j) = 0.
ENDIF
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving constraints'
END SUBROUTINE constraints
END MODULE lpj_constraints
ORCHIDEE/src_stomate/lpj_cover.f90 0000754 0103600 0005670 00000004450 11164403473 016556 0 ustar acamlmd lmdjus ! recalculate vegetation cover and LAI
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_cover.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE lpj_cover
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC cover
CONTAINS
SUBROUTINE cover (npts, cn_ind, ind, biomass, &
veget_max, veget, lai)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! crown area (m**2) per ind.
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: cn_ind
! density of individuals (1/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ind
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: biomass
! 0.2 modified fields
! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
! 0.3 output
! fractional coverage on natural/agricultural ground, taking into
! account LAI (=grid-scale fpc)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
! leaf area index OF AN INDIVIDUAL PLANT
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
! 0.4 local
! index
INTEGER(i_std) :: j
! =========================================================================
!
! 1 If the vegetation is dynamic, calculate new maximum vegetation cover for
! natural plants
!
IF ( control%ok_dgvm ) THEN
DO j = 1, npft
IF ( natural(j) ) THEN
veget_max(:,j) = ind(:,j) * cn_ind(:,j)
ENDIF
ENDDO
ENDIF
!
! 2 Calculate LAI
! The LAI is defined on the space covered by the crown of the plant.
! ( biomass / veget_max ) is in gC/(m**2 covered by the crown)
!
!
! 3 calculate grid-scale fpc (foliage protected cover)
!
DO j = 1, npft
veget(:,j) = veget_max(:,j) * ( 1. - exp( - lai(:,j) * ext_coeff(j) ) )
ENDDO
END SUBROUTINE cover
END MODULE lpj_cover
ORCHIDEE/src_stomate/lpj_crown.f90 0000754 0103600 0005670 00000007162 11164403473 016573 0 ustar acamlmd lmdjus ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_crown.f90,v 1.11 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!-
MODULE lpj_crown
!---------------------------------------------------------------------
!- calculate individual crown area from stem mass.
!---------------------------------------------------------------------
USE ioipsl
USE stomate_constants
USE constantes_veg
!-
IMPLICIT NONE
!-
! private & public routines
!-
PRIVATE
PUBLIC crown
!-
CONTAINS
!-
!===
!-
SUBROUTINE crown &
& (npts, PFTpresent, ind, biomass, veget_max, cn_ind, height)
!---------------------------------------------------------------------
! 0 declarations
!-
! 0.1 input
!-
! Domain size
INTEGER(i_std),INTENT(in) :: npts
! Is pft there
LOGICAL,DIMENSION(npts,npft),INTENT(in) :: PFTpresent
! density of individuals (1/(m**2 of nat/agri ground))
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: ind
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: biomass
!-
! 0.2 modified fields
!-
! "maximal" coverage fraction of a PFT (LAI -> infinity)
! on nat/agri ground
!-
REAL(r_std),DIMENSION(npts,npft),INTENT(inout) :: veget_max
!-
! 0.3 output
!-
! crown area (m**2) per ind.
!-
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: cn_ind
!-
! height of vegetation (m)
!-
REAL(r_std),DIMENSION(npts,npft),INTENT(inout) :: height
!-
! 0.4 local
!-
! wood mass of an individual
!-
REAL(r_std),DIMENSION(npts) :: woodmass
!-
! index
!-
INTEGER(i_std) :: j
!-
! stem diameter
!-
REAL(r_std),DIMENSION(npts) :: dia
REAL(r_std),DIMENSION(npft) :: height_presc_12
!---------------------------------------------------------------------
!-
! 1 initializations
!-
! 1.1 check if DGVM activated
!-
IF (.NOT.control%ok_dgvm) THEN
STOP 'crown: not to be called with static vegetation.'
ENDIF
!-
! 1.2 initialize output to zero
!-
cn_ind(:,:) = 0.0
! convert prescribed height from sechiba (nvm) to stomate (npft)
height_presc_12(1:npft) = height_presc(2:nvm)
!-
! 2 calculate (or prescribe) crown area
!-
DO j = 1,npft
IF (tree(j)) THEN
!-----
!---- 2.1 trees
!-----
IF (natural(j)) THEN
!------ 2.1.1 natural
WHERE (PFTpresent(:,j))
!-------- 2.1.1.1 calculate individual wood mass
woodmass(:) = &
& (biomass(:,j,isapabove)+biomass(:,j,isapbelow) &
& +biomass(:,j,iheartabove)+biomass(:,j,iheartbelow))/ind(:,j)
!-------- 2.1.1.2 stem diameter (pipe model)
dia(:) = (woodmass(:)/(pipe_density*pi/4.*pipe_tune2)) &
& **(1./(2.+pipe_tune3))
!-------- 2.1.1.3 height
height(:,j) = pipe_tune2*(dia(:)**pipe_tune3)
WHERE (height(:,j) > height_presc_12(j))
dia(:) = (height_presc_12(j)/pipe_tune2)**(1./pipe_tune3)
height(:,j) = height_presc_12(j)
ENDWHERE
!-------- 2.1.1.4 crown area: for large truncs, crown area cannot
!-------- exceed a certain value, prescribed through maxdia.
cn_ind(:,j) = pipe_tune1*MIN(dia(:),maxdia(j))**1.6
ENDWHERE
ELSE
!------ 2.1.2 tree is agricultural - stop
STOP 'crown: cannot treat agricultural trees.'
ENDIF
ELSE
!-----
!---- 2.2 grasses
!-----
WHERE (PFTpresent(:,j))
!------ 2.2.1 an "individual" is 1 m**2 of grass
cn_ind(:,j) = 1.
ENDWHERE
ENDIF
!---
!-- 2.3 recalculate vegetation cover if natural
! ind and cn_ind are 0 if not present
!---
IF (natural(j)) THEN
veget_max(:,j) = ind(:,j) * cn_ind(:,j)
ENDIF
ENDDO
!-------------------
END SUBROUTINE crown
!-
!===
!-
END MODULE lpj_crown
ORCHIDEE/src_stomate/lpj_establish.f90 0000754 0103600 0005670 00000043274 11164403473 017425 0 ustar acamlmd lmdjus ! establishment routine
! Suppose seed pool >> establishment rate.
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_establish.f90,v 1.8 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE lpj_establish
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC establish,establish_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE establish_clear
firstcall = .TRUE.
END SUBROUTINE establish_clear
SUBROUTINE establish (npts, dt, PFTpresent, regenerate, &
neighbours, resolution, space_nat, need_adjacent, herbivores, &
precip_annual, gdd0, lm_lastyearmax, &
cn_ind, lai, avail_tree, avail_grass, &
leaf_age, leaf_frac, &
ind, biomass, age, everywhere, co2_to_bm)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! Time step of vegetation dynamics (days)
REAL(r_std), INTENT(in) :: dt
! Is pft there
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! Winter sufficiently cold
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: regenerate
! indices of the 8 neighbours of each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
INTEGER(i_std), DIMENSION(npts,8), INTENT(in) :: neighbours
! resolution at each grid point in m (1=E-W, 2=N-S)
REAL(r_std), DIMENSION(npts,2), INTENT(in) :: resolution
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! in order for this PFT to be introduced, does it have to be present in an
! adjacent grid box?
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: need_adjacent
! time constant of probability of a leaf to be eaten by a herbivore (days)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: herbivores
! annual precipitation (mm/year)
REAL(r_std), DIMENSION(npts), INTENT(in) :: precip_annual
! growing degree days (C)
REAL(r_std), DIMENSION(npts), INTENT(in) :: gdd0
! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lm_lastyearmax
! crown area of individuals (m**2)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: cn_ind
! leaf area index OF AN INDIVIDUAL PLANT
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
! space availability for trees
REAL(r_std), DIMENSION(npts), INTENT(in) :: avail_tree
! space availability for grasses
REAL(r_std), DIMENSION(npts), INTENT(in) :: avail_grass
! 0.2 modified fields
! leaf age (days)
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! Number of individuals / m2
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! mean age (years)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
! is the PFT everywhere in the grid box or very localized (after its introduction)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
! biomass uptaken (gC/(m**2 of total ground)/day)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: co2_to_bm
! 0.3 local
! time during which a sapling can be entirely eaten by herbivores (d)
REAL(r_std) :: tau_eatup
! new fpc ( foliage protected cover: fractional coverage )
REAL(r_std), DIMENSION(npts,npft) :: fpc_nat
! maximum tree establishment rate, based on climate only
REAL(r_std), DIMENSION(npts) :: estab_rate_max_climate_tree
! maximum grass establishment rate, based on climate only
REAL(r_std), DIMENSION(npts) :: estab_rate_max_climate_grass
! maximum tree establishment rate, based on climate and fpc
REAL(r_std), DIMENSION(npts) :: estab_rate_max_tree
! maximum grass establishment rate, based on climate and fpc
REAL(r_std), DIMENSION(npts) :: estab_rate_max_grass
! total natural fpc
REAL(r_std), DIMENSION(npts) :: sumfpc
! total woody fpc
REAL(r_std), DIMENSION(npts) :: sumfpc_wood
! for trees, measures the total concurrence for available space
REAL(r_std), DIMENSION(npts) :: spacefight_tree
! for grasses, measures the total concurrence for available space
REAL(r_std), DIMENSION(npts) :: spacefight_grass
! change in number of individuals /m2 per time step (per day in history file)
REAL(r_std), DIMENSION(npts,npft) :: d_ind
! biomass increase (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts) :: bm_new
! stem diameter (m)
REAL(r_std), DIMENSION(npts) :: dia
! temporary variable
REAL(r_std), DIMENSION(npts) :: b1
! new sap mass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts) :: sm2
! woodmass of an individual
REAL(r_std), DIMENSION(npts) :: woodmass
! ratio of hw(above) to total hw, sm(above) to total sm
REAL(r_std), DIMENSION(npts) :: sm_at
! reduction factor for establishment if many trees or grasses are present
REAL(r_std), DIMENSION(npts) :: factor
! from how many sides is the grid box invaded
INTEGER(i_std) :: nfrontx
INTEGER(i_std) :: nfronty
! daily establishment rate is large compared to present number of individuals
LOGICAL, DIMENSION(npts) :: many_new
! indices
INTEGER(i_std) :: i,j,k,m
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering establish'
!
! 1 messages and initialization
!
tau_eatup = one_year/2.
IF ( firstcall ) THEN
WRITE(numout,*) 'establish:'
WRITE(numout,*) ' > time during which a sapling can be entirely eaten by herbivores (d): ', &
tau_eatup
firstcall = .FALSE.
ENDIF
!
! 2 recalculate fpc
!
!
! 2.1 Only natural part of the grid cell
!
DO j = 1, npft
IF ( natural(j) ) THEN
fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) * ( 1. - exp( -lai(:,j) * ext_coeff(j) ) )
ELSE
fpc_nat(:,j) = 0.0
ENDIF
ENDDO
!
! 2.2 total natural fpc on grid
!
sumfpc(:) = SUM( fpc_nat(:,:), DIM=2 )
!
! 2.3 total woody fpc on grid and number of regenerative tree pfts
!
sumfpc_wood(:) = 0.0
spacefight_tree(:) = 0.0
DO j = 1, npft
IF ( tree(j) .AND. natural(j) ) THEN
! total woody fpc
WHERE ( PFTpresent(:,j) )
sumfpc_wood(:) = sumfpc_wood(:) + fpc_nat(:,j)
ENDWHERE
! how many trees are competing? Count a PFT fully only if it is present
! on the whole grid box.
WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) )
spacefight_tree(:) = spacefight_tree(:) + everywhere(:,j)
ENDWHERE
ENDIF
ENDDO
!
! 2.4 number of natural grasses
!
spacefight_grass(:) = 0.0
DO j = 1, npft
IF ( .NOT. tree(j) .AND. natural(j) ) THEN
! how many grasses are competing? Count a PFT fully only if it is present
! on the whole grid box.
WHERE ( PFTpresent(:,j) )
spacefight_grass(:) = spacefight_grass(:) + everywhere(:,j)
ENDWHERE
ENDIF
ENDDO
!
! 3 establishment rate
!
!
! 3.1 maximum establishment rate, based on climate only
!
WHERE ( ( precip_annual(:) .GE. precip_crit ) .AND. ( gdd0(:) .GE. gdd_crit ) )
estab_rate_max_climate_tree(:) = estab_max_tree
estab_rate_max_climate_grass(:) = estab_max_grass
ELSEWHERE
estab_rate_max_climate_tree(:) = 0.0
estab_rate_max_climate_grass(:) = 0.0
ENDWHERE
!
! 3.2 reduce maximum tree establishment rate if many trees present.
! In the original DGVM, this is done using a step function which yields a
! reduction by factor 4 if sumfpc_wood(i) .GT. fpc_crit - 0.05.
! This can lead to small oscillations (without consequences however).
! Here, a steady linear transition is used between fpc_crit-0.075 and
! fpc_crit-0.025.
!
factor(:) = 1. - 15. * ( sumfpc_wood(:) - (fpc_crit-.075) )
factor(:) = MAX( 0.25_r_std, MIN( 1._r_std, factor(:) ) )
estab_rate_max_tree(:) = estab_rate_max_climate_tree(:) * factor(:)
!
! 3.3 Modulate grass establishment rate.
! If canopy is not closed (fpc < fpc_crit-0.05), normal establishment.
! If canopy is closed, establishment is reduced by a factor 4.
! Factor is linear between these two bounds.
! This is different from the original DGVM where a step function is
! used at fpc_crit-0.05 (This can lead to small oscillations,
! without consequences however).
!
factor(:) = 1. - 15. * ( sumfpc(:) - (fpc_crit-.05) )
factor(:) = MAX( 0.25_r_std, MIN( 1._r_std, factor(:) ) )
estab_rate_max_grass(:) = estab_rate_max_climate_grass(:) * factor(:)
!
! 4 do establishment for natural PFTs
!
d_ind(:,:) = 0.0
DO j = 1, npft
! only for natural PFTs
IF ( natural(j) ) THEN
!
! 4.1 PFT expansion across the grid box. Not to be confused with areal
! coverage.
!
IF ( treat_expansion ) THEN
! only treat plants that are regenerative and present and still can expand
DO i = 1, npts
IF ( PFTpresent(i,j) .AND. &
( everywhere(i,j) .LT. 1. ) .AND. &
( regenerate(i,j) .GT. regenerate_crit ) ) THEN
! from how many sides is the grid box invaded (separate x and y directions
! because resolution may be strongly anisotropic)
!
! For the moment we only look into 4 direction but that can be extanded (JP)
!
nfrontx = 0
IF ( neighbours(i,3) .GT. 0 ) THEN
IF ( everywhere(neighbours(i,3),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1
ENDIF
IF ( neighbours(i,7) .GT. 0 ) THEN
IF ( everywhere(neighbours(i,7),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1
ENDIF
nfronty = 0
IF ( neighbours(i,1) .GT. 0 ) THEN
IF ( everywhere(neighbours(i,1),j) .GT. 1.-min_stomate ) nfronty = nfronty+1
ENDIF
IF ( neighbours(i,5) .GT. 0 ) THEN
IF ( everywhere(neighbours(i,5),j) .GT. 1.-min_stomate ) nfronty = nfronty+1
ENDIF
everywhere(i,j) = &
everywhere(i,j) + migrate(j) * dt/one_year * &
( nfrontx / resolution(i,1) + nfronty / resolution(i,2) )
IF ( .NOT. need_adjacent(i,j) ) THEN
! in that case, we also assume that the PFT expands from places within
! the grid box (e.g., oasis).
everywhere(i,j) = &
everywhere(i,j) + migrate(j) * dt/one_year * &
2. * SQRT( pi*everywhere(i,j)/(resolution(i,1)*resolution(i,2)) )
ENDIF
everywhere(i,j) = MIN( everywhere(i,j), 1._r_std )
ENDIF
ENDDO
ENDIF ! treat expansion?
!
! 4.2 establishment rate
! - Is lower if the PFT is only present in a small part of the grid box
! (after its introduction), therefore multiplied by "everywhere".
! - Is divided by the number of PFTs that compete ("spacefight").
! - Is modulated by space availability (avail_tree, avail_grass).
!
IF ( tree(j) ) THEN
! 4.2.1 present and regenerative trees
WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) )
d_ind(:,j) = estab_rate_max_tree(:)*everywhere(:,j)/spacefight_tree(:) * &
avail_tree(:) * dt/one_year
ENDWHERE
ELSE
! 4.2.2 present and regenerative grasses
WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) )
d_ind(:,j) = estab_rate_max_grass(:)*everywhere(:,j)/spacefight_grass(:) * &
avail_grass(:) * dt/one_year
ENDWHERE
ENDIF ! tree/grass
!
! 4.3 herbivores reduce establishment rate
! We suppose that saplings are vulnerable during a given time after establishment.
! This is taken into account by preventively reducing the establishment rate.
!
IF ( ok_herbivores ) THEN
d_ind(:,j) = d_ind(:,j) * EXP( - tau_eatup/herbivores(:,j) )
ENDIF
!
! 4.4 be sure that ind*cn_ind does not exceed 1
!
WHERE ( ( d_ind(:,j) .GT. 0.0 ) .AND. &
( (ind(:,j)+d_ind(:,j))*cn_ind(:,j) .GT. 1. ) )
d_ind(:,j) = MAX( 1._r_std / cn_ind(:,j) - ind(:,j), 0._r_std )
ENDWHERE
!
! 4.5 new properties where there is establishment ( d_ind > 0 )
!
! 4.5.1 biomass.
! Add biomass only if d_ind, over one year, is of the order of ind.
! (If we don't do this, the biomass density can become very low).
! In that case, take biomass from the atmosphere.
! As we are talking about a flux from the atmosphere, we transform
! space_nat from gC/(m**2 of natural ground) to
! gC/(m**2 of total ground).
! compare establishment rate and present number of inidivuals
many_new(:) = ( d_ind(:,j) .GT. 0.1 * ind(:,j) )
! gives a better vectorization of the VPP
IF ( ANY( many_new(:) ) ) THEN
DO k = 1, nparts
WHERE ( many_new(:) )
bm_new(:) = d_ind(:,j) * bm_sapl(j,k)
biomass(:,j,k) = biomass(:,j,k) + bm_new(:)
co2_to_bm(:) = co2_to_bm(:) + bm_new(:) * space_nat(:) / dt
ENDWHERE
ENDDO
! reset leaf ages. Should do a real calculation like in the npp routine,
! but this case is rare and not worth messing around.
WHERE ( many_new(:) )
leaf_age(:,j,1) = 0.0
leaf_frac(:,j,1) = 1.0
ENDWHERE
DO m = 2, nleafages
WHERE ( many_new(:) )
leaf_age(:,j,m) = 0.0
leaf_frac(:,j,m) = 0.0
ENDWHERE
ENDDO
ENDIF ! establishment rate is large
WHERE ( d_ind(:,j) .GT. 0.0 )
! 4.5.2 age decreases
age(:,j) = age(:,j) * ind(:,j) / ( ind(:,j) + d_ind(:,j) )
! 4.5.3 new number of individuals
ind(:,j) = ind(:,j) + d_ind(:,j)
ENDWHERE
!
! 4.6 eventually convert excess sapwood to heartwood
!
IF ( tree(j) ) THEN
sm2(:) = 0.0
WHERE ( d_ind(:,j) .GT. 0.0 )
! ratio of above / total sap parts
sm_at(:) = biomass(:,j,isapabove) / &
( biomass(:,j,isapabove) + biomass(:,j,isapbelow) )
! woodmass of an individual
woodmass(:) = &
( biomass(:,j,isapabove) + biomass(:,j,isapbelow) + &
biomass(:,j,iheartabove) + biomass(:,j,iheartbelow) ) / ind(:,j)
! crown area (m**2) depends on stem diameter (pipe model)
dia(:) = ( woodmass(:) / ( pipe_density * pi/4. * pipe_tune2 ) ) &
** ( 1. / ( 2. + pipe_tune3 ) )
b1(:) = pipe_k1 / ( sla(j) * pipe_density*pipe_tune2 * dia(:)**pipe_tune3 ) * &
ind(:,j)
sm2(:) = lm_lastyearmax(:,j) / b1(:)
ENDWHERE
WHERE ( ( d_ind(:,j) .GT. 0.0 ) .AND. &
( biomass(:,j,isapabove) + biomass(:,j,isapbelow) ) .GT. sm2(:) )
biomass(:,j,iheartabove) = biomass(:,j,iheartabove) + &
( biomass(:,j,isapabove) - sm2(:) * sm_at(:) )
biomass(:,j,isapabove) = sm2(:) * sm_at(:)
biomass(:,j,iheartbelow) = biomass(:,j,iheartbelow) + &
( biomass(:,j,isapbelow) - sm2(:) * (1. - sm_at) )
biomass(:,j,isapbelow) = sm2(:) * (1. - sm_at(:))
ENDWHERE
ENDIF ! tree
ENDIF ! natural
ENDDO ! loop over pfts
!
! 5 history
!
d_ind = d_ind / dt
CALL histwrite (hist_id_stomate, 'IND_ESTAB', itime, d_ind, npts*npft, horipft_index)
IF (bavard.GE.4) WRITE(numout,*) 'Leaving establish'
END SUBROUTINE establish
END MODULE lpj_establish
ORCHIDEE/src_stomate/lpj_fire.f90 0000754 0103600 0005670 00000050303 11164403473 016363 0 ustar acamlmd lmdjus ! calculate fire extent and impact on plants.
! This is treated on a pseudo-daily basis (fireindex has a long-term memory).
! We only take into account the natural litter, as agricultural and
! natural PFTs are usually spatially separated.
! Fire decreases the biomass per m**2 of natural ground.
! Grasses are totally burned.
! When the vegetation is dynamic, it also decreases the density of individuals.
! Fire burns litter on the ground.
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_fire.f90,v 1.9 2007/06/13 07:44:34 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE lpj_fire
! modules used:
USE ioipsl
USE stomate_constants
USE parallel
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC fire,fire_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
! flag that disable fire
LOGICAL, SAVE :: disable_fire
CONTAINS
SUBROUTINE fire_clear
firstcall = .TRUE.
END SUBROUTINE fire_clear
SUBROUTINE fire (npts, dt, space_nat, litterpart, &
litterhum_daily, t2m_daily, lignin_struc, &
fireindex, firelitter, biomass, ind, &
litter, dead_leaves, bm_to_litter, black_carbon, &
co2_fire)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! Time step in days
REAL(r_std), INTENT(in) :: dt
! fraction of total space that is natural
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! fraction of litter above the ground belonging to different PFTs
REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(in) :: litterpart
! Daily litter moisture (between 0 and 1)
REAL(r_std), DIMENSION(npts), INTENT(in) :: litterhum_daily
! Daily 2 meter temperature (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_daily
! ratio Lignine/Carbon in structural litter, above and below ground,
! natural and agricultural (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,nvegtypes,nlevs), INTENT(in) :: lignin_struc
! 0.2 modified fields
! Probability of fire
REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: fireindex
! Longer term total natural litter above the ground, gC/m**2 of natural ground
REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: firelitter
! biomass (gC/m**2)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! density of individuals (1/m**2)
REAl(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
! metabolic and structural litter, natural and agricultural,
! above and below ground (gC/m**2)
REAL(r_std), DIMENSION(npts,nlitt,nvegtypes,nlevs), INTENT(inout):: litter
! dead leaves on ground, per PFT, metabolic and structural,
! in gC/(m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: dead_leaves
! conversion of biomass to litter (gC/(m**2 of average nat/agri ground)) / day
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
! black carbon on the ground (gC/(m**2 of total ground))
REAL(r_std), DIMENSION(npts), INTENT(inout) :: black_carbon
! 0.3 output
! carbon emitted into the atmosphere by fire (living and dead biomass)
! (in gC/m**2/day)
REAL(r_std), DIMENSION(npts), INTENT(out) :: co2_fire
! 0.4 local
! Time scale for memory of the fire index (days). Validated for one year in the DGVM.
REAL(r_std), PARAMETER :: tau_fire = 30. ! GKtest
! Critical litter quantity for fire
REAL(r_std), PARAMETER :: litter_crit = 200.
! fire perturbation
REAL(r_std), DIMENSION(npts) :: fire_disturb
! what fraction of the plants is burned each day?
REAL(r_std), DIMENSION(npts,npft) :: firedeath
! What fraction of a burned plant compartment goes into the atmosphere
! (rest into litter)
REAL(r_std), SAVE, DIMENSION(nparts) :: co2frac
! Moisture limit (critical moisture limit)
REAL(r_std), DIMENSION(npts) :: moistlimit
! total litter above the ground for a vegetation type (gC/m**2)
REAL(r_std), DIMENSION(npts) :: litter_above
! daily fire index
REAL(r_std), DIMENSION(npts,nvegtypes) :: fireindex_daily
! fire extent, on natural and agricultural ground
REAL(r_std), DIMENSION(npts, nvegtypes) :: firefrac
! residual fraction of exposed structural litter, depending on lignin fraction
REAL(r_std), DIMENSION(npts) :: struc_residual
! residue, i.e. exposed carbon - volatilized carbon ( gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts) :: residue
! fraction of residue transformed into black carbon
REAL(r_std), DIMENSION(npts) :: bcfrac
! fraction of total space that is natural/agricultural. Allows to transform from
! 1/(m**2 of nat/agri ground) to 1/(m**2 of total ground)
REAL(r_std), DIMENSION(npts,nvegtypes) :: fracspace_vegtype
! intermediate variable
REAL(r_std), DIMENSION(npts) :: x
! annual fire fraction
REAL(r_std), DIMENSION(npts) :: aff
! are we talking about natural or agricultural ground?
INTEGER(i_std) :: ivegtype
! index
INTEGER(i_std) :: j,k,m
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering fire'
!
! 1 Initializations
!
IF ( firstcall ) THEN
!
! 1.1 What fraction of the plant compartment, if burned, is transformed into CO2
!
co2frac(ileaf) = .95
co2frac(isapabove) = .95
co2frac(isapbelow) = 0.
co2frac(iheartabove) = 0.3
co2frac(iheartbelow) = 0.
co2frac(iroot) = 0.
co2frac(ifruit) = .95
co2frac(icarbres) = 0.95
!
! 1.2 messages
!
WRITE(numout,*) 'fire:'
WRITE(numout,*) ' > temporal inertia of fire probability (d): ',tau_fire
WRITE(numout,*) ' > fraction of burned biomass that becomes CO2:'
WRITE(numout,*) ' leaves: ', co2frac(ileaf)
WRITE(numout,*) ' sap above ground: ', co2frac(isapabove)
WRITE(numout,*) ' sap below ground: ', co2frac(isapbelow)
WRITE(numout,*) ' heartwood above ground: ', co2frac(iheartabove)
WRITE(numout,*) ' heartwood below ground: ', co2frac(iheartbelow)
WRITE(numout,*) ' roots: ', co2frac(iroot)
WRITE(numout,*) ' fruits: ', co2frac(ifruit)
WRITE(numout,*) ' carbohydrate reserve: ', co2frac(icarbres)
WRITE(numout,*) ' > critical litter quantity (gC/m**2): ',litter_crit
WRITE(numout,*) ' > We calculate a fire probability on agricultural ground, but'
WRITE(numout,*) ' the effective fire fraction is zero.'
firstcall = .FALSE.
!
! 1.3 read the flag that disable fire
!
!Config Key = FIRE_DISABLE
!Config Desc = no fire allowed
!Config Def = n
!Config Help = With this variable, you can allow or not
!Config the estimation of CO2 lost by fire
!
disable_fire=.FALSE.
CALL getin_p('FIRE_DISABLE', disable_fire)
ENDIF
!
! 1.4 Initialize output
!
co2_fire(:) = 0.0
firedeath(:,:) = 0.0
!
! 1.5 fraction of total space reserved for vegetation type
!
fracspace_vegtype(:,inat) = space_nat(:)
fracspace_vegtype(:,iagri) = 1. - space_nat(:)
!
! 2 Determine fire probability. We calculate this probability (and long-term litter)
! also for agricultural ground, but the fire fraction on agricultural ground is set
! to 0 for the moment.
!
DO ivegtype = 1, nvegtypes
! total litter above the ground, for the vegetation type we are talking about
litter_above(:) = litter(:,imetabolic,ivegtype,iabove) + &
litter(:,istructural,ivegtype,iabove)
!
! 2.1 calculate moisture limit. If it stays 0, this means that there is no litter
! on the ground, and this means that there can be no fore.
! Sum over different litter parts from the various PFTs, taking into account the
! litter flamability which is a function of the PFT.
! Difference to Stephen Sitch's approach: Daily litter, not annual mean.
! Reason: 1. seems more reasonable.
! 2. easier to implement (otherwise, would need moisture limit
! from previous year)
!
moistlimit(:) = 0.
DO j = 1, npft
! If we are on natural ground, only take natural PFTs, and vice versa
IF ( ( ( ivegtype .EQ. inat ) .AND. natural(j) ) .OR. &
( ( ivegtype .EQ. iagri ) .AND. .NOT. natural(j) ) ) THEN
! fire only when above feezing point and when there is litter
! (structural or metabolic) above the ground.
! Loop over grid points is the innermost because of vectorization.
! (Makes the code unreadable.)
WHERE ( ( t2m_daily(:) .GT. ZeroCelsius ) .AND. &
( litter_above(:) .GT. min_stomate ) )
moistlimit(:) = moistlimit(:) + &
( litterpart(:,j,imetabolic)*litter(:,imetabolic,ivegtype,iabove) + &
litterpart(:,j,istructural)*litter(:,istructural,ivegtype,iabove) ) / &
litter_above(:) * flam(j)
ENDWHERE
ENDIF ! PFT and vegetation type coherent?
ENDDO ! PFT
!
! 2.2 daily fire index.
!
WHERE ( moistlimit(:) .GT. 0.0 )
! is a function of litter humidity. Very sensible to STOMATE's time step as
! with larger dt, one misses dry days with very high fireindex ( strongly
! nonlinear: exp(-x^2)! )
x(:) = litterhum_daily(:)/moistlimit(:)
fireindex_daily(:,ivegtype) = EXP( - pi * x(:) * x(:) )
ELSEWHERE
fireindex_daily(:,ivegtype) = 0.0
ENDWHERE
!
! 2.3 increase long-term fire index (mean probability)
!
fireindex(:,ivegtype) = &
( ( tau_fire - dt ) * fireindex(:,ivegtype) + &
( dt ) * fireindex_daily(:,ivegtype) ) / tau_fire
!
! 2.4 litter influences fire intensity.
! We use longer-term litter to be consistent with the fire index.
!
firelitter(:,ivegtype) = &
( ( tau_fire-dt ) * firelitter(:,ivegtype) + dt * litter_above(:) ) / tau_fire
ENDDO
!
! 3 Calculate fire fraction from litter and fireindex (i.e. basically drought)
! We assume that agricultural space is separated from natural space so that
! the fire occurence on natural ground does not depend on the litter
! on agricultural ground.
!
!
! 3.1 natural ground
!
! This formulation has been developped for annual fire indices!
! original form: firefrac(i) = fireindex(i) * EXP( f(fireindex(i)) )
! Transform into daily fire fraction.
! annual fire fraction
aff(:) = firefrac_func (npts, fireindex(:,inat))
! transform from annual fraction to daily fraction.
! annual fire fraction = 1. - (fraction of tree that survives each day) ** 365 =
! = 1. - ( 1. - daily fire fraction )**365
! Thus, daily fire fraction = 1. - ( 1. - annual fire fraction )**(1/365)
! If annual firefrac<<1, then firefrac_daily = firefrac * dt/one_year
! This approximation avoids numerical problems.
WHERE ( aff(:) .GT. 0.1 )
firefrac(:,inat) = 1. - ( 1. - aff(:) ) ** (dt/one_year)
ELSEWHERE
firefrac(:,inat) = aff(:) * dt/one_year
ENDWHERE
! No fire if litter is below critical value
WHERE ( firelitter(:,inat) .LT. litter_crit )
firefrac(:,inat) = 0.0
ENDWHERE
! However, there is a minimum fire extent
firefrac(:,inat) = MAX( 0.001_r_std * dt/one_year, firefrac(:,inat) )
! if FIRE_DISABLE flag is set no fire
IF (disable_fire) firefrac=0
!
! 3.2 agricultural ground: no fire for the moment
!
firefrac(:,iagri) = 0.0
!
! 4 Determine fire impact: calculate fire disturbance for each PFT
!
DO j = 1, npft
!
! 4.1 are we talking about a natural or an agricultural PFT?
!
IF ( natural(j) ) THEN
ivegtype = inat
ELSE
ivegtype = iagri
ENDIF
!
! 4.2 fire disturbance
!
IF ( tree(j) ) THEN
! 4.2.1 Trees: always disturbed
fire_disturb(:) = ( 1. - resist(j) ) * firefrac(:,ivegtype)
ELSE
! 4.2.2 Grasses are not disturbed if they are not in their growing season
WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
fire_disturb(:) = ( 1. - resist(j) ) * firefrac(:,ivegtype)
ELSEWHERE
fire_disturb(:) = 0.0
ENDWHERE
ENDIF
!
! 4.3 litter and co2 created through fire on living biomass
!
! biomass can go into litter or atmosphere, depending on what plant compartment
! we are talking about.
DO k = 1, nparts
! grass roots and reserve survive.
IF ( .NOT. ( ( .NOT. tree(j) ) .AND. ( ( k.EQ.iroot ) .OR. ( k.EQ.icarbres ) ) ) ) THEN
! 4.3.1 A fraction goes directly into the atmosphere.
! CO2 flux in gC/m**2 of total ground/day.
co2_fire(:) = co2_fire(:) + biomass(:,j,k) * fire_disturb(:) * co2frac(k) * &
fracspace_vegtype(:,ivegtype) / dt
! 4.3.2 Determine the residue, in gC/m**2 of natural/agricultural ground.
residue(:) = biomass(:,j,k) * fire_disturb(:) * ( 1. - co2frac(k) )
! 4.3.2.1 determine fraction of black carbon. Only for plant parts above the
! ground, i.e. when co2_frac > 0.
! A small part of the residue, which can be expressed as a function of
! the fraction of volatilized carbon (assimilated to co2frac here),
! becomes black carbon, and thus withdrawn from the soil carbon cycle (added
! to the "geologic carbon cycle we don't care about here).
! [Kuhlbusch et al. JGR 101, 23651-23665, 1996; Kuhlbusch & Crutzen, GBC 9,
! 491-501, 1995].
IF ( co2frac(k) .GT. 0.0 ) THEN
bcfrac(:) = .3 / ( 1.3 ** ( 88.2 - 100.*co2frac(k) ) + 1. )
ELSE
bcfrac(:) = 0.0
ENDIF
! 4.3.2.2 Add this fraction of the residue to the black carbon "reservoir", in
! gC/(m**2 of total ground).
black_carbon(:) = &
black_carbon(:) + bcfrac(:) * residue(:) * fracspace_vegtype(:,ivegtype)
! 4.3.2.3 The rest (largest part) of the residue becomes litter.
bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + residue(:) * ( 1 - bcfrac(:) )
ENDIF ! not for grass roots
ENDDO
!
! 4.4 new vegetation characteristics
!
! 4.4.1 decrease biomass per m**2 of natural(/agricultural) ground
! except for grass roots.
DO k = 1, nparts
IF ( .NOT. ( ( .NOT. tree(j) ) .AND. ( ( k.EQ.iroot ) .OR. ( k.EQ.icarbres) ) ) ) THEN
biomass(:,j,k) = ( 1. - fire_disturb(:) ) * biomass(:,j,k)
ENDIF
ENDDO
! 4.4.2 If vegetation is dynamic, then decrease the density of tree
! individuals.
IF ( control%ok_dgvm .AND. tree(j) ) THEN
! fraction of plants that dies each day.
! exact formulation: 1. - (1.-fire_disturb(:)) ** (1./dt)
firedeath(:,j) = fire_disturb(:) / dt
ind(:,j) = ( 1. - fire_disturb(:) ) * ind(:,j)
ENDIF
ENDDO ! loop over PFTs
!
! 5 A fraction of the (natural) litter is burned by the fire
!
DO ivegtype = 1,nvegtypes
!
! 5.1 exposed metabolic litter burns totally and goes directly into the atmosphere as
! CO2.
!
! 5.1.1 CO2 flux, in gC/(m**2 of total ground)/day.
co2_fire(:) = co2_fire(:) + litter(:,imetabolic,ivegtype,iabove) * &
firefrac(:,ivegtype) * fracspace_vegtype(:,ivegtype) / dt
! 5.1.2 decrease metabolic litter
litter(:,imetabolic,ivegtype,iabove) = litter(:,imetabolic,ivegtype,iabove) * &
( 1. - firefrac(:,ivegtype) )
!
! 5.2 exposed structural litter is not totally transformed into CO2.
!
! 5.2.1 Fraction of exposed structural litter that does not
! burn totally should depend on lignin content (lignin_struc). VERY TENTATIVE!
struc_residual(:) = 0.5 * lignin_struc(:,ivegtype,iabove)
! 5.2.2 CO2 flux, in gC/(m**2 of total ground)/day.
co2_fire(:) = co2_fire(:) + &
litter(:,istructural,ivegtype,iabove) * firefrac(:,ivegtype) * &
( 1. - struc_residual(:) ) * fracspace_vegtype(:,ivegtype) / dt
! 5.2.3 determine residue (litter that undergoes fire, but is not transformed
! into CO2)
residue(:) = litter(:,istructural,ivegtype,iabove) * firefrac(:,ivegtype) * &
struc_residual(:)
! 5.2.4 determine fraction of black carbon in the residue.
! depends on volatilized fraction of carbon (see 4.3.2.1)
bcfrac(:) = .3 / ( 1.3 ** ( 88.2 - 100.*(1.-struc_residual(:)) ) + 1. )
! 5.2.5 Add this fraction of the residue to the black carbon "reservoir", in
! gC/(m**2 of total ground).
black_carbon(:) = &
black_carbon(:) + bcfrac(:) * residue(:) * fracspace_vegtype(:,ivegtype)
! 5.2.6 The rest (largest part) of the residue remains litter. Remaining litter
! is the sum of this and of the litter which has not undergone a fire.
litter(:,istructural,ivegtype,iabove) = &
litter(:,istructural,ivegtype,iabove) * ( 1. - firefrac(:,ivegtype) ) + &
residue(:) * ( 1. - bcfrac(:) )
ENDDO ! natural/agricultural ground
!
! 5.3 diagnose fraction of leaves burned.
! exposed leaves are burned entirely, even their structural part
!
DO j = 1, npft
IF ( natural(j) ) THEN
m = inat
ELSE
m = iagri
ENDIF
DO k = 1, nlitt
dead_leaves(:,j,k) = dead_leaves(:,j,k) * ( 1. - firefrac(:,m) )
ENDDO
ENDDO
!
! 6 history
!
! output in 1/day
firefrac = firefrac / dt
CALL histwrite (hist_id_stomate, 'FIREFRAC_NAT', itime, &
firefrac(:,inat), npts, hori_index)
CALL histwrite (hist_id_stomate, 'FIREFRAC_AGRI', itime, &
firefrac(:,iagri), npts, hori_index)
CALL histwrite (hist_id_stomate, 'FIREDEATH', itime, &
firedeath(:,:), npts*npft, horipft_index)
IF (bavard.GE.4) WRITE(numout,*) 'Leaving fire'
END SUBROUTINE fire
FUNCTION firefrac_func (npts, x) RESULT (firefrac_result)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! fire index
REAL(r_std), DIMENSION(npts), INTENT(in) :: x
! 0.2 result
! fire fraction
REAL(r_std), DIMENSION(npts) :: firefrac_result
! 0.3 local
! intermediate variable
REAL(r_std), DIMENSION(npts) :: xm1
xm1(:) = x(:) - 1.
firefrac_result(:) = &
x(:) * EXP( xm1(:) / ( -.13*xm1(:)*xm1(:)*xm1(:) + .6*xm1(:)*xm1(:) + .8*xm1(:) + .45 ) )
END FUNCTION firefrac_func
END MODULE lpj_fire
ORCHIDEE/src_stomate/lpj_gap.f90 0000754 0103600 0005670 00000015207 11164403473 016211 0 ustar acamlmd lmdjus ! gap routine - place for new plants
!
! Death rate of trees is estimated by evaluating their vigour (based on npp).
! For large availabilities, lifetime is 50 years (!?).
! Age of stands is not considered, although availability death rate should probably
! depend on age.
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_gap.f90,v 1.8 2007/06/13 07:44:34 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE lpj_gap
! modules used:
USE ioipsl
USE stomate_constants
USE parallel
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC gap,gap_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE gap_clear
firstcall = .TRUE.
END SUBROUTINE gap_clear
SUBROUTINE gap (npts, dt, &
npp_longterm, turnover_longterm, lm_lastyearmax, &
PFTpresent, biomass, ind, bm_to_litter)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! Time step (days)
REAL(r_std), INTENT(in) :: dt
! "long term" net primary productivity (gC/(m**2 of nat/agri ground)/year)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: npp_longterm
! "long term" turnover rate (gC/(m**2 of nat/agri ground)/year)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: turnover_longterm
! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lm_lastyearmax
! 0.2 modified fields
! Is pft there
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! Number of individuals / (m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
! biomass taken away (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
! 0.3 local
! which kind of mortality
LOGICAL, SAVE :: constant_mortality
! biomass increase
REAL(r_std), DIMENSION(npts) :: delta_biomass
! vigour
REAL(r_std), DIMENSION(npts) :: vigour
! natural availability, based on vigour
REAL(r_std), DIMENSION(npts) :: availability
! mortality (fraction of trees that is dying per time step), per day in history file
REAL(r_std), DIMENSION(npts,npft) :: mortality
! indices
INTEGER(i_std) :: j,k
! =========================================================================
IF ( firstcall ) THEN
firstcall = .FALSE.
!Config Key = LPJ_GAP_CONST_MORT
!Config Desc = constant tree mortality
!Config Def = y
!Config Help = If yes, then a constant mortality is applied to trees.
!Config Otherwise, mortality is a function of the trees'
!Config vigour (as in LPJ).
constant_mortality = .TRUE.
CALL getin_p('LPJ_GAP_CONST_MORT', constant_mortality)
WRITE(numout,*) 'gap: constant mortality:', constant_mortality
ENDIF
IF (bavard.GE.3) WRITE(numout,*) 'Entering gap'
DO j = 1, npft
mortality(:,j) = 0.0
! only trees
IF ( tree(j) ) THEN
!
! 1 determine availability
!
IF ( .NOT. constant_mortality ) THEN
!
! 1.1 original formulation: mortality depends on vigour
!
WHERE ( PFTpresent(:,j) .AND. ( lm_lastyearmax(:,j) .GT. min_stomate ) )
! how much did the tree grow per year?
delta_biomass(:) = &
MAX( npp_longterm(:,j) - ( turnover_longterm(:,j,ileaf) + &
turnover_longterm(:,j,iroot) + turnover_longterm(:,j,ifruit) ), &
0._r_std )
! scale this to the leaf surface of the tree
vigour(:) = delta_biomass(:) / (lm_lastyearmax(:,j)*sla(j)) / 70.
ELSEWHERE
vigour(:) = 0.0
ENDWHERE
WHERE ( PFTpresent(:,j) )
! note that availability is never above 0.02, i.e. lifetime of 50 years when very
! low vigour.
availability(:) = 0.02 / ( 1.+vigour(:)/0.17 )
! Mortality (fraction per time step).
! In the original DGVM, mortality was set to zero if there was strong fire
! perturbation.
! This has been de-activated since the npp is not influenced by fire,
! as opposed to the original DGVM. Instead, mortality is simply
! equal to the availability, modulated by the time step.
! Exact formulation: mor = 1. - ( 1. - availability ) ** (dt/one_year)
! approximation ok as availability < 0.02 << 1
mortality(:,j) = availability(:) * dt/one_year
ENDWHERE
ELSE
!
! 1.2 Alternative version: Constant mortality
!
WHERE ( PFTpresent(:,j) )
mortality(:,j) = dt/(residence_time(j)*one_year)
ENDWHERE
ENDIF
!
! 2 Special for the DGVM:
! mortality is one if npp is zero or negative.
!
IF ( control%ok_dgvm ) THEN
WHERE ( PFTpresent(:,j) .AND. ( npp_longterm(:,j) .LE. min_stomate ) )
mortality(:,j) = 1.
ENDWHERE
ENDIF
!
! 3 update biomass, create litter
!
DO k = 1, nparts
WHERE ( PFTpresent(:,j) )
bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + mortality(:,j) * biomass(:,j,k)
biomass(:,j,k) = biomass(:,j,k) * ( 1. - mortality(:,j) )
ENDWHERE
ENDDO
!
! 4 update number of individuals
!
IF ( control%ok_dgvm ) THEN
WHERE ( PFTpresent(:,j) )
ind(:,j) = ind(:,j) * ( 1. - mortality(:,j) )
ENDWHERE
ENDIF
ENDIF ! only trees
ENDDO ! loop over pfts
!
! 5 history
!
! output in fraction of trees that dies/day.
! exact formulation: 1. - ( 1. - mortality ) ** (1./dt)
mortality = mortality / dt
CALL histwrite (hist_id_stomate, 'MORTALITY', itime, &
mortality, npts*npft, horipft_index)
IF (bavard.GE.4) WRITE(numout,*) 'Leaving gap'
END SUBROUTINE gap
END MODULE lpj_gap
ORCHIDEE/src_stomate/lpj_kill.f90 0000754 0103600 0005670 00000014023 11164403473 016370 0 ustar acamlmd lmdjus ! kills pfts that obviously fare badly
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_kill.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE lpj_kill
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC kill
CONTAINS
SUBROUTINE kill (npts, whichroutine, lm_lastyearmax, &
ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
lai, age, leaf_age, leaf_frac, &
when_growthinit, everywhere, veget, veget_max, bm_to_litter)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! message
CHARACTER*10, INTENT(in) :: whichroutine
! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lm_lastyearmax
! 0.2 modified fields
! Number of individuals / m**2
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
! Is pft there
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
! crown area of individuals (m**2)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: cn_ind
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: senescence
! How much time ago was the PFT eliminated for the last time (y)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: RIP_time
! leaf area index OF AN INDIVIDUAL PLANT
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
! mean age (years)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
! leaf age (days)
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! how many days ago was the beginning of the growing season
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
! is the PFT everywhere in the grid box or very localized (after its introduction)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
! fractional coverage on natural/agricultural ground, taking into
! account LAI (=grid-scale fpc)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
! 0.3 local
! indices
INTEGER(i_std) :: j,m
! bookkeeping
LOGICAL, DIMENSION(npts) :: was_killed
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering kill'
DO j = 1, npft
was_killed(:) = .FALSE.
! only kill natural PFTs
IF ( natural(j) ) THEN
! kill present plants if number of individuals or last year's leaf
! mass is close to zero.
! the "was_killed" business is necessary for a more efficient code on the VPP
WHERE ( PFTpresent(:,j) .AND. &
( ( ind(:,j) .LT. min_stomate ) .OR. &
( lm_lastyearmax(:,j) .LT. min_stomate ) ) )
was_killed(:) = .TRUE.
ENDWHERE
IF ( ANY( was_killed(:) ) ) THEN
WHERE ( was_killed(:) )
ind(:,j) = 0.0
bm_to_litter(:,j,ileaf) = bm_to_litter(:,j,ileaf) + biomass(:,j,ileaf)
bm_to_litter(:,j,isapabove) = bm_to_litter(:,j,isapabove) + biomass(:,j,isapabove)
bm_to_litter(:,j,isapbelow) = bm_to_litter(:,j,isapbelow) + biomass(:,j,isapbelow)
bm_to_litter(:,j,iheartabove) = bm_to_litter(:,j,iheartabove) + &
biomass(:,j,iheartabove)
bm_to_litter(:,j,iheartbelow) = bm_to_litter(:,j,iheartbelow) + &
biomass(:,j,iheartbelow)
bm_to_litter(:,j,iroot) = bm_to_litter(:,j,iroot) + biomass(:,j,iroot)
bm_to_litter(:,j,ifruit) = bm_to_litter(:,j,ifruit) + biomass(:,j,ifruit)
bm_to_litter(:,j,icarbres) = bm_to_litter(:,j,icarbres) + biomass(:,j,icarbres)
biomass(:,j,ileaf) = 0.0
biomass(:,j,isapabove) = 0.0
biomass(:,j,isapbelow) = 0.0
biomass(:,j,iheartabove) = 0.0
biomass(:,j,iheartbelow) = 0.0
biomass(:,j,iroot) = 0.0
biomass(:,j,ifruit) = 0.0
biomass(:,j,icarbres) = 0.0
PFTpresent(:,j) = .FALSE.
cn_ind(:,j) = 0.0
senescence(:,j) = .FALSE.
age(:,j) = 0.0
when_growthinit(:,j) = undef
everywhere(:,j) = 0.0
veget(:,j) = 0.0
veget_max(:,j) = 0.0
RIP_time(:,j) = 0.0
ENDWHERE ! number of individuals very low
DO m = 1, nleafages
WHERE ( was_killed(:) )
leaf_age(:,j,m) = 0.0
leaf_frac(:,j,m) = 0.0
ENDWHERE
ENDDO
IF ( bavard .GE. 2 ) THEN
WRITE(numout,*) 'kill: eliminated ',PFT_name(j)
WRITE(numout,*) ' at ',COUNT( was_killed(:) ),' points after '//whichroutine
ENDIF
ENDIF ! PFT must be killed at at least one place
ENDIF ! PFT is natural
ENDDO ! loop over PFTs
IF (bavard.GE.4) WRITE(numout,*) 'Leaving kill'
END SUBROUTINE kill
END MODULE lpj_kill
ORCHIDEE/src_stomate/lpj_light.f90 0000754 0103600 0005670 00000034303 11164403473 016547 0 ustar acamlmd lmdjus ! Light competition
!
! If canopy is almost closed (fpc > fpc_crit), then trees outcompete grasses.
! fpc_crit is normally fpc_crit.
! Here, fpc ("foilage protected cover") also takes into account the minimum fraction
! of space covered by trees through branches etc. This is done to prevent strong relative
! changes of fpc from one day to another for deciduous trees at the beginning of their
! growing season, which would yield to strong cutbacks (see 3.2.1.1.2)
! No competition between woody pfts (height of individuals is not considered) !
! Exception: when one woody pft is overwhelming (i.e. fpc > fpc_crit). In that
! case, eliminate all other woody pfts and reduce dominant pft to fpc_crit.
! Age of individuals is not considered. In reality, light competition would more
! easily kill young individuals, thus increasing the mean age of the stand.
! Exclude agricultural pfts from competition
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_light.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE lpj_light
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC light, light_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE light_clear
firstcall=.TRUE.
END SUBROUTINE light_clear
SUBROUTINE light (npts, dt, &
PFTpresent, cn_ind, lai, maxfpc_lastyear, &
ind, biomass, veget_lastlight, bm_to_litter)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! Time step (days)
REAL(r_std), INTENT(in) :: dt
! Is pft there
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! crown area of individuals (m**2)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: cn_ind
! leaf area index OF AN INDIVIDUAL PLANT
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
! last year's maximum fpc for each natural PFT, on *natural* ground
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxfpc_lastyear
! 0.2 modified fields
! Number of individuals / m2
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! Vegetation cover after last light competition
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_lastlight
! biomass taken away (gC/m**2)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
! 0.3 local
! maximum total number of grass individuals in a closed canopy
REAL(r_std), PARAMETER :: grass_mercy = 0.01
! minimum fraction of trees that survive even in a closed canopy
REAL(r_std), PARAMETER :: tree_mercy = 0.01
! for diagnosis of fpc increase, compare today's fpc to last year's maximum (T) or
! to fpc of last time step (F)?
LOGICAL, PARAMETER :: annual_increase = .TRUE.
! index
INTEGER(i_std) :: i,j
! total natural fpc
REAL(r_std), DIMENSION(npts) :: sumfpc
! total natural woody fpc
REAL(r_std) :: sumfpc_wood
! change in total woody fpc
REAL(r_std) :: sumdelta_fpc_wood
! maximum wood fpc
REAL(r_std) :: maxfpc_wood
! which woody pft is maximum
INTEGER(i_std) :: optpft_wood
! total natural grass fpc
REAL(r_std) :: sumfpc_grass
! this year's foliage protected cover on natural part of the grid cell
REAL(r_std), DIMENSION(npts,npft) :: fpc_nat
! fpc change within last year
REAL(r_std), DIMENSION(npft) :: deltafpc
! Relative change of number of individuals for trees
REAL(r_std) :: reduct
! Fraction of plants that survive
REAL(r_std), DIMENSION(npft) :: survive
! number of grass PFTs present in the grid box
INTEGER(i_std) :: num_grass
! New total grass fpc
REAL(r_std) :: sumfpc_grass2
! fraction of plants that dies each day (1/day)
REAL(r_std), DIMENSION(npts,npft) :: light_death
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering light'
!
! 1 first call
!
IF ( firstcall ) THEN
WRITE(numout,*) 'light:'
WRITE(numout,*) ' > Maximum total number of grass individuals in'
WRITE(numout,*) ' a closed canopy: ', grass_mercy
WRITE(numout,*) ' > Minimum fraction of trees that survive even in'
WRITE(numout,*) ' a closed canopy: ', tree_mercy
WRITE(numout,*) ' > For trees, minimum fraction of crown area covered'
WRITE(numout,*) ' (due to its branches etc.)', min_cover
WRITE(numout,*) ' > for diagnosis of fpc increase, compare today''s fpc'
IF ( annual_increase ) THEN
WRITE(numout,*) ' to last year''s maximum.'
ELSE
WRITE(numout,*) ' to fpc of the last time step.'
ENDIF
firstcall = .FALSE.
ENDIF
!
! 2 fpc characteristics
!
!
! 2.1 calculate fpc on natural part of grid cell.
!
DO j = 1, npft
IF ( natural(j) ) THEN
! 2.1.1 natural PFTs
IF ( tree(j) ) THEN
! 2.1.1.1 trees: minimum cover due to stems, branches etc.
DO i = 1, npts
fpc_nat(i,j) = &
cn_ind(i,j) * ind(i,j) * &
MAX( ( 1._r_std - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover )
ENDDO
ELSE
! 2.1.1.2 grasses
fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) * &
( 1. - exp( -lai(:,j) * ext_coeff(j) ) )
ENDIF ! tree/grass
ELSE
! 2.1.2 agricultural PFTs: not present on natural part
fpc_nat(:,j) = 0.0
ENDIF ! natural/agricultural
ENDDO
!
! 2.2 sum natural fpc for every grid point
!
sumfpc(:) = zero
DO j = 1, npft
sumfpc(:) = sumfpc(:) + fpc_nat(:,j)
ENDDO
!
! 3 Light competition
!
light_death(:,:) = 0.0
DO i = 1, npts
! Only if vegetation cover is dense
IF ( sumfpc(i) .GT. fpc_crit ) THEN
! fpc change for each pft
! There are two possibilities: either we compare today's fpc with the fpc after the last
! time step, or we compare it to last year's maximum fpc of that PFT. In the first case,
! the fpc increase will be strong for seasonal PFTs at the beginning of the growing season.
! As for trees, the cutback is proportional to this increase, this means that seasonal trees
! will be disadvantaged compared to evergreen trees. In the original LPJ model, with its
! annual time step, the second method was used (this corresponds to annual_increase=.TRUE.)
IF ( annual_increase ) THEN
deltafpc(:) = MAX( (fpc_nat(i,:)-maxfpc_lastyear(i,:)), 0._r_std )
ELSE
deltafpc(:) = MAX( (fpc_nat(i,:)-veget_lastlight(i,:)), 0._r_std )
ENDIF
! default: survive
survive(:) = 1.0
!
! 3.1 determine some characteristics of the fpc distribution
!
sumfpc_wood = 0.0
sumdelta_fpc_wood = 0.0
maxfpc_wood = 0.0
optpft_wood = 0
sumfpc_grass = 0.0
num_grass = 0
DO j = 1, npft
! only natural pfts
IF ( natural(j) ) THEN
IF ( tree(j) ) THEN
! trees
! total woody fpc
sumfpc_wood = sumfpc_wood + fpc_nat(i,j)
! how much did the woody fpc increase
sumdelta_fpc_wood = sumdelta_fpc_wood + deltafpc(j)
! which woody pft is preponderant
IF ( fpc_nat(i,j) .GT. maxfpc_wood ) THEN
optpft_wood = j
maxfpc_wood = fpc_nat(i,j)
ENDIF
ELSE
! grasses
! total (natural) grass fpc
sumfpc_grass = sumfpc_grass + fpc_nat(i,j)
! number of grass PFTs present in the grid box
IF ( PFTpresent(i,j) ) THEN
num_grass = num_grass + 1
ENDIF
ENDIF ! tree or grass
ENDIF ! natural
ENDDO ! loop over pfts
!
! 3.2 light competition: assume wood outcompetes grass
!
IF (sumfpc_wood .GE. fpc_crit ) THEN
!
! 3.2.1 all allowed natural space is covered by wood:
! cut back trees to fpc_crit.
! Original DGVM: kill grasses. Modified: we let a very
! small fraction of grasses survive.
!
DO j = 1, npft
! only present and natural pfts compete
IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
IF ( tree(j) ) THEN
!
! 3.2.1.1 tree
!
IF ( maxfpc_wood .GE. fpc_crit ) THEN
! 3.2.1.1.1 one single woody pft is overwhelming
IF ( j .eq. optpft_wood ) THEN
! reduction for this dominant pft
reduct = 1. - fpc_crit / fpc_nat(i,j)
ELSE
! strongly reduce all other woody pfts
! (original DGVM: tree_mercy = 0.0 )
reduct = 1. - tree_mercy
ENDIF ! pft = dominant woody pft
ELSE
! 3.2.1.1.2 no single woody pft is overwhelming
! (original DGVM: tree_mercy = 0.0 )
! The reduction rate is proportional to the ratio deltafpc/fpc.
IF ( fpc_nat(i,j) .GE. min_stomate ) THEN
reduct = MIN( ( ( deltafpc(j)/sumdelta_fpc_wood * &
(sumfpc_wood-fpc_crit) ) / fpc_nat(i,j) ), &
( 1._r_std - tree_mercy ) )
ELSE
! tree fpc didn't icrease or it started from nothing
reduct = 0.
ENDIF
ENDIF ! maxfpc_wood > fpc_crit
survive(j) = 1. - reduct
ELSE
!
! 3.2.1.2 grass: let a very small fraction survive (the sum of all
! grass individuals may make up a maximum cover of
! grass_mercy [for lai -> infinity]).
! In the original DGVM, grasses were killed in that case,
! corresponding to grass_mercy = 0.
!
survive(j) = ( grass_mercy / REAL( num_grass,r_std ) ) / ind(i,j)
survive(j) = MIN( 1._r_std, survive(j) )
ENDIF ! tree or grass
ENDIF ! pft there and natural
ENDDO ! loop over pfts
ELSE
!
! 3.2.2 not too much wood so that grasses can subsist
!
! new total grass fpc
sumfpc_grass2 = fpc_crit - sumfpc_wood
DO j = 1, npft
! only present and natural PFTs compete
IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
IF ( tree(j) ) THEN
! no change for trees
survive(j) = 1.0
ELSE
! grass: fractional loss is the same for all grasses
IF ( sumfpc_grass .GT. min_stomate ) THEN
survive(j) = sumfpc_grass2 / sumfpc_grass
ELSE
survive(j)= 0.0
ENDIF
ENDIF
ENDIF ! pft there and natural
ENDDO ! loop over pfts
ENDIF ! sumfpc_wood > fpc_crit
!
! 3.3 update output variables
!
DO j = 1, npft
IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
bm_to_litter(i,j,:) = bm_to_litter(i,j,:) + &
biomass(i,j,:) * ( 1. - survive(j) )
biomass(i,j,:) = biomass(i,j,:) * survive(j)
IF ( control%ok_dgvm ) THEN
ind(i,j) = ind(i,j) * survive(j)
ENDIF
! fraction of plants that dies each day.
! exact formulation: light_death(i,j) = 1. - survive(j) ** (1/dt)
light_death(i,j) = ( 1. - survive(j) ) / dt
ENDIF ! pft there and natural
ENDDO ! loop over pfts
ENDIF ! sumfpc > fpc_crit
ENDDO ! loop over grid points
!
! 4 recalculate fpc on natural part of grid cell (for next light competition)
!
DO j = 1, npft
IF ( natural(j) ) THEN
!
! 4.1 natural PFTs
!
IF ( tree(j) ) THEN
! 4.1.1 trees: minimum cover due to stems, branches etc.
DO i = 1, npts
veget_lastlight(i,j) = &
cn_ind(i,j) * ind(i,j) * &
MAX( ( 1._r_std - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover )
ENDDO
ELSE
! 4.1.2 grasses
veget_lastlight(:,j) = &
cn_ind(:,j) * ind(:,j) * ( 1. - exp( -lai(:,j) * ext_coeff(j) ) )
ENDIF ! tree/grass
ELSE
!
! 4.2 agricultural PFTs: not present on natural part
!
veget_lastlight(:,j) = 0.0
ENDIF ! natural/agricultural
ENDDO
!
! 5 history
!
CALL histwrite (hist_id_stomate, 'LIGHT_DEATH', itime, &
light_death, npts*npft, horipft_index)
IF (bavard.GE.4) WRITE(numout,*) 'Leaving light'
END SUBROUTINE light
END MODULE lpj_light
ORCHIDEE/src_stomate/lpj_pftinout.f90 0000754 0103600 0005670 00000031346 11164403473 017314 0 ustar acamlmd lmdjus ! throw out respectively introduce some PFTS
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_pftinout.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE lpj_pftinout
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC pftinout,pftinout_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE pftinout_clear
firstcall = .TRUE.
END SUBROUTINE pftinout_clear
SUBROUTINE pftinout (npts, dt, adapted, regenerate, &
neighbours, space_nat, veget, veget_max, &
biomass, ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, &
PFTpresent, everywhere, when_growthinit, need_adjacent, RIP_time, &
co2_to_bm, &
avail_tree, avail_grass)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! Time step (days)
REAL(r_std), INTENT(in) :: dt
! Winter not too cold
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: adapted
! Winter sufficiently cold
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: regenerate
! indices of the 8 neighbours of each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
INTEGER(i_std), DIMENSION(npts,8), INTENT(in) :: neighbours
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! fractional coverage on natural/agricultural ground, taking into
! account LAI (=grid-scale fpc)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
! 0.2 modified fields
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! density of individuals 1/m**2
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
! mean age (years)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! "long term" net primary productivity (gC/(m**2 of nat/agri ground)/year)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: npp_longterm
! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_lastyearmax
! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
! set to .FALSE. if PFT is introduced or killed
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: senescence
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
! is the PFT everywhere in the grid box or very localized (after its introduction)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
! how many days ago was the beginning of the growing season
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
! in order for this PFT to be introduced, does it have to be present in an
! adjacent grid box?
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: need_adjacent
! How much time ago was the PFT eliminated for the last time (y)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: RIP_time
! biomass uptaken (gC/(m**2 of total ground)/day)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: co2_to_bm
! 0.3 output
! space availability for trees on natural ground
REAL(r_std), DIMENSION(npts), INTENT(out) :: avail_tree
! space availability for grasses on natural ground
REAL(r_std), DIMENSION(npts), INTENT(out) :: avail_grass
! 0.4 local
! minimum availability
REAL(r_std), PARAMETER :: min_avail = 0.01
! availability
REAL(r_std), DIMENSION(npts) :: avail
! indices
INTEGER(i_std) :: i,j
! total woody vegetation cover or natural ground
REAL(r_std), DIMENSION(npts) :: sumfrac_wood
! number of adjacent grid cells where PFT is ubiquitious
INTEGER(i_std), DIMENSION(npts) :: n_present
! we can introduce this PFT
LOGICAL, DIMENSION(npts) :: can_introduce
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering pftinout'
!
! 1 Messages
!
IF ( firstcall ) THEN
WRITE(numout,*) 'pftinout: Minimum space availability: ', min_avail
firstcall = .FALSE.
ENDIF
!
! 2 Space availability
!
! need to know total woody vegetation fraction
sumfrac_wood(:) = 0.0
DO j = 1, npft
IF ( tree(j) ) THEN
sumfrac_wood(:) = sumfrac_wood(:) + veget(:,j)
ENDIF
ENDDO
avail_grass(:) = MAX( ( 1._r_std - sumfrac_wood(:) ), min_avail )
avail_tree(:) = MAX( ( fpc_crit - sumfrac_wood(:) ), min_avail )
!
! 3 Time since last elimination (y)
!
RIP_time = RIP_time + dt / one_year
!
! 4 Agicultural PFTs: present if they are prescribed
!
DO j = 1, npft
IF ( .NOT. natural(j) ) THEN
IF (bavard.GE.4) WRITE(numout,*) 'pftinout: Agricultural PFTs'
IF ( tree(j) ) THEN
!
! 4.1 don't treat agricultural trees for the moment
!
WRITE(numout,*) 'pftinout: Agricultural trees not treated. We stop.'
STOP
ELSE
!
! 4.2 grasses
!
DO i = 1, npts
IF ( ( veget_max(i,j) .GT. 0.0 ) .AND. ( .NOT. PFTpresent(i,j) ) ) THEN
! prescribed, but not yet there.
ind(i,j) = veget_max(i,j)
biomass(i,j,:) = bm_sapl(j,:) * ind(i,j)
co2_to_bm(i) = co2_to_bm(i) + &
SUM( biomass(i,j,:) ) * ( 1. - space_nat(i) ) / dt
PFTpresent(i,j) = .TRUE.
everywhere(i,j) = 1.
senescence(i,j) = .FALSE.
age(i,j) = 0.
ENDIF ! prescribed, but PFT not yet present
ENDDO ! loop over grid points
ENDIF
ENDIF ! not natural
ENDDO ! loop over PFTs
!
! 5 Eliminate PFTs
!
DO j = 1, npft
! only for natural PFTs
IF ( natural(j) ) THEN
WHERE ( PFTpresent(:,j) .AND. ( adapted(:,j) .LT. adapted_crit ) )
! PFT there, but not adapted any more (ex: winter too cold): kill
! set number of individuals to zero - rest will be done in lpj_kill
ind(:,j) = 0.0
ENDWHERE
ENDIF ! natural
ENDDO ! loop over PFTs
!
! 6 Introduce PFTs
!
DO j = 1, npft
IF ( natural(j) ) THEN
! space availability for this PFT
IF ( tree(j) ) THEN
avail(:) = avail_tree(:)
ELSE
avail(:) = avail_grass(:)
ENDIF
!
! 6.1 Check if PFT not present but (adapted and regenerative)
!
can_introduce(:) = .FALSE.
DO i = 1, npts
IF ( .NOT. PFTpresent(i,j) .AND. &
( adapted(i,j) .GT. adapted_crit ) .AND. &
( regenerate(i,j) .GT. regenerate_crit ) ) THEN
! climate allows introduction
IF ( need_adjacent(i,j) ) THEN
! 6.1.1 climate allows introduction, but we need to look at the neighbours
! If the PFT has totally invaded at least one adjacent
! grid cell, it can be introduced.
! count number of totally invaded neighbours
! no loop so that it can vectorize
n_present(i) = 0
IF ( neighbours(i,1) .GT. 0 ) THEN
IF ( everywhere(neighbours(i,1),j) .GE. 1.-min_stomate ) THEN
n_present(i) = n_present(i)+1
ENDIF
ENDIF
IF ( neighbours(i,3) .GT. 0 ) THEN
IF ( everywhere(neighbours(i,3),j) .GE. 1.-min_stomate ) THEN
n_present(i) = n_present(i)+1
ENDIF
ENDIF
IF ( neighbours(i,5) .GT. 0 ) THEN
IF ( everywhere(neighbours(i,5),j) .GE. 1.-min_stomate ) THEN
n_present(i) = n_present(i)+1
ENDIF
ENDIF
IF ( neighbours(i,7) .GT. 0 ) THEN
IF ( everywhere(neighbours(i,7),j) .GE. 1.-min_stomate ) THEN
n_present(i) = n_present(i)+1
ENDIF
ENDIF
IF ( n_present(i) .GT. 0 ) THEN
! PFT is ubiquitious in at least one adjacent grid box
can_introduce(i) = .TRUE.
ENDIF
ELSE
! 6.1.2 we don't have to look at neighbours
can_introduce(i) = .TRUE.
ENDIF ! do we have to look at the neighbours?
ENDIF ! we'd like to introduce the PFT
ENDDO ! loop over grid points
!
! 6.2 additionally test whether the PFT has been eliminated lately, i.e.
! less than 1.25 years ago. Do not take full years as success of
! introduction might depend on season.
WHERE ( RIP_time(:,j) .LT. 1.25 )
! PFT was eliminated lately - cannot reintroduce
can_introduce(:) = .FALSE.
ENDWHERE
!
! 6.3 Introduce that PFT where possible
! "can_introduce" means that it either exists in neighbouring grid boxes
! or that we do not look at neighbours, that it has not been eliminated
! lately, and, of course, that the climate is good for that PFT.
!
WHERE ( can_introduce(:) )
PFTpresent(:,j) = .TRUE.
senescence(:,j) = .FALSE.
! introduce at least a few saplings, even if canopy is closed
ind(:,j) = ind_0 * (dt/one_year) * avail(:)
biomass(:,j,ileaf) = bm_sapl(j,ileaf) * ind(:,j)
biomass(:,j,isapabove) = bm_sapl(j,isapabove) * ind(:,j)
biomass(:,j,isapbelow) = bm_sapl(j,isapbelow) * ind(:,j)
biomass(:,j,iheartabove) = bm_sapl(j,iheartabove) * ind(:,j)
biomass(:,j,iheartbelow) = bm_sapl(j,iheartbelow) * ind(:,j)
biomass(:,j,iroot) = bm_sapl(j,iroot) * ind(:,j)
biomass(:,j,ifruit) = bm_sapl(j,ifruit) * ind(:,j)
biomass(:,j,icarbres) = bm_sapl(j,icarbres) * ind(:,j)
co2_to_bm(:) = &
co2_to_bm(:) + space_nat(:) / dt * &
( biomass(:,j,ileaf) + biomass(:,j,isapabove) + &
biomass(:,j,isapbelow) + biomass(:,j,iheartabove) + &
biomass(:,j,iheartbelow) + biomass(:,j,iroot) + &
biomass(:,j,ifruit) + biomass(:,j,icarbres) )
when_growthinit(:,j) = large_value
age(:,j) = 0.0
! all leaves are young
leaf_frac(:,j,1) = 1.0
! non-zero "long term" npp and last year's leaf mass for saplings -
! so they won't be killed off by gap or kill
npp_longterm(:,j) = 10.
lm_lastyearmax(:,j) = bm_sapl(j,ileaf) * ind(:,j)
ENDWHERE ! we can introduce the PFT
!
! 6.4 expansion of the PFT within the grid box (not to be confused with areal
! coverage)
!
IF ( treat_expansion ) THEN
WHERE ( can_introduce(:) )
! low value at the beginning
everywhere(:,j) = 0.05
ENDWHERE
ELSE
! expansion is not treated
WHERE ( can_introduce(:) )
everywhere(:,j) = 1.
ENDWHERE
ENDIF ! treat expansion
ENDIF ! only natural PFTs
ENDDO ! loop over PFTs
!
! 7 If a PFT has been present once in a grid box, we suppose that it will survive
! in isolated places (e.g., an oasis) within that grid box, even if it gets
! officially eliminated from it later. That means that if climate becomes favorable
! again, it will not need to get seeds from adjacent grid cells.
!
WHERE ( PFTpresent )
need_adjacent = .FALSE.
ENDWHERE
IF (bavard.GE.4) WRITE(numout,*) 'Leaving pftinout'
END SUBROUTINE pftinout
END MODULE lpj_pftinout
ORCHIDEE/src_stomate/stomate.f90 0000754 0103600 0005670 00000414672 11164403473 016262 0 ustar acamlmd lmdjus !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate.f90,v 1.30 2007/06/13 08:04:56 ssipsl Exp $
!IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate
!---------------------------------------------------------------------
! Daily update of leaf area index etc.
!---------------------------------------------------------------------
USE netcdf
!-
USE ioipsl
USE defprec
USE constantes
USE constantes_veg
USE constantes_co2
USE stomate_constants
USE stomate_io
USE stomate_data
USE stomate_natagritot
USE stomate_season
USE stomate_lpj
USE stomate_assimtemp
USE stomate_litter
USE stomate_vmax
USE stomate_soilcarbon
USE stomate_resp
USE parallel
! USE Write_field_p
!-
IMPLICIT NONE
PRIVATE
PUBLIC stomate_soil,stomate_main,stomate_clear, &
& pondere_nat,pondere_nat_vegfrac,pondere_vegfrac
!
INTEGER,PARAMETER :: r_typ =nf90_real4
!
! Do update of yearly variables ?
! This variable must be .TRUE. once a year
LOGICAL, SAVE :: EndOfYear = .FALSE.
PUBLIC EndOfYear
!-
! variables used inside stomate module : declaration and initialisation
!-
! total natural space (fraction of total space)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: veget_max
! total natural space (fraction of total space)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: space_nat
! carbon pool: active, slow, or passive, natural and agricultural
! (gC/(m**2 of nat/agri ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: carbon
! density of individuals (1/(m**2 of nat/agri ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: ind
! daily moisture availability
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: humrel_daily
! daily litter humidity
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: litterhum_daily
! daily 2 meter temperatures (K)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_daily
! daily minimum 2 meter temperatures (K)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_min_daily
! daily surface temperatures (K)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: tsurf_daily
! daily soil temperatures (K)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: tsoil_daily
! daily soil humidity
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: soilhum_daily
! daily precipitations (mm/day) (for phenology)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: precip_daily
! daily gross primary productivity (gC/(m**2 of nat/agri ground)/day)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: gpp_daily
! daily net primary productivity (gC/(m**2 of nat/agri ground)/day)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: npp_daily
! Turnover rates (gC/(m**2 of nat/agri ground)/day)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: turnover_daily
! Probability of fire
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: fireindex
! Longer term total litter above the ground
! (gC/m**2 of nat/agri ground)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: firelitter
! "monthly" moisture availability
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: humrel_month
! "weekly" moisture availability
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: humrel_week
! "long term" 2 meter temperatures (K)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_longterm
! "long term" 2 meter reference temperatures (K)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: tlong_ref
! "monthly" 2 meter temperatures (K)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_month
! "weekly" 2 meter temperatures (K)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_week
! "monthly" soil temperatures (K)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: tsoil_month
! "monthly" soil humidity
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: soilhum_month
! growing degree days, threshold -5 deg C (for phenology)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: gdd_m5_dormance
! growing degree days, since midwinter (for phenology)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: gdd_midwinter
! number of chilling days since leaves were lost (for phenology)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: ncd_dormance
! number of growing days, threshold -5 deg C (for phenology)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: ngd_minus5
! last year's maximum moisture availability
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxhumrel_lastyear
! this year's maximum moisture availability
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxhumrel_thisyear
! last year's minimum moisture availability
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: minhumrel_lastyear
! this year's minimum moisture availability
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: minhumrel_thisyear
! last year's maximum "weekly" GPP (gC/m**2 covered/day)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxgppweek_lastyear
! this year's maximum "weekly" GPP (gC/m**2 covered/day)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxgppweek_thisyear
! last year's annual GDD0
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: gdd0_lastyear
! this year's annual GDD0
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: gdd0_thisyear
! last year's annual precipitation (mm/year)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: precip_lastyear
! this year's annual precipitation (mm/year)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: precip_thisyear
! PFT exists (equivalent to veget > 0 for natural PFTs)
LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: PFTpresent
! "long term" net primary productivity
! (gC/(m**2 of nat/agri ground)/year)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: npp_longterm
! last year's maximum leaf mass, for each PFT
! (gC/(m**2 of nat/agri ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: lm_lastyearmax
! this year's maximum leaf mass, for each PFT
! (gC/(m**2 of nat/agri ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: lm_thisyearmax
! last year's maximum fpc for each natural PFT, on *natural* ground
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxfpc_lastyear
! this year's maximum fpc for each PFT, on *total* ground
! (see stomate_season)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxfpc_thisyear
! "long term" turnover rate (gC/(m**2 of nat/agri ground)/year)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: turnover_longterm
! "weekly" GPP (gC/day/(m**2 covered)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: gpp_week
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: biomass
! is the plant senescent?
! (only for deciduous trees - carbohydrate reserve)
LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: senescence
! how many days ago was the beginning of the growing season
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: when_growthinit
! age (years). For trees, mean stand age.
! For grasses, ears since introduction of PFT
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: age
! Winter too cold? between 0 and 1
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: adapted
! Winter sufficiently cold? between 0 and 1
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: regenerate
! fraction of litter above the ground belonging to different PFTs,
! separated for natural and agricultural PFTs
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: litterpart
! metabolic and structural litter,
! natural and agricultural, above and below ground
! (gC/(m**2 of nat/agri ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:):: litter
! dead leaves on ground, per PFT, metabolic and structural,
! in gC/(m**2 of nat/agri ground)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: dead_leaves
! black carbon on the ground (gC/(m**2 of total ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: black_carbon
! ratio Lignine/Carbon in structural litter,
! above and below ground, natural and agricultural
! (gC/(m**2 of nat/agri ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: lignin_struc
! carbon emitted into the atmosphere by fire (living and dead biomass)
! (in gC/m**2 of average ground/day)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: co2_fire
! co2 taken up (gC/(m**2 of total ground)/day)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: co2_to_bm_dgvm
! heterotrophic respiration (gC/day/m**2 of total ground)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_hetero
! maintenance respiration (gC/day/(m**2 of total ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_hetero_radia
! maintenance respiration (gC/day/(m**2 of total ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_maint
! growth respiration (gC/day/(m**2 of total ground))
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_growth
! vegetation fractions (on natural/agri ground)
! after last light competition
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: veget_lastlight
! is the PFT everywhere in the grid box or very localized
! (after its intoduction)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: everywhere
! in order for this PFT to be introduced,
! does it have to be present in an adjacent grid box?
LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: need_adjacent
! leaf age (d)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: leaf_frac
! How much time ago was the PFT eliminated for the last time (y)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: RIP_time
! duration of dormance (d)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: time_lowgpp
! time elapsed since strongest moisture availability (d)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: time_hum_min
! minimum moisture during dormance
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: hum_min_dormance
! factor that allows to transform "veget_max_x" (Sechiba)
! into "veget_max" (Stomate).
! veget_max_x takes into account the ice fraction,
! while veget_max is defined on ice_free
! land surface only. Moreover,
! PFTs between Sechiba and Stomate are not necessarily identical.
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: fvm
! factor that allows to transform
! "veget_x" (Sechiba) into "veget" (Stomate) [see "fvm"].
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: fv
! time constant of probability of a leaf to be eaten
! by a herbivore (days)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: herbivores
! npp total written for forcesoil...
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: npp_equil
! npp total ...
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: npp_tot
! moisture control of heterotrophic respiration
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: control_moist
! temperature control of heterotrophic respiration, above and below
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: control_temp
! quantity of carbon going into carbon pools from litter decomposition
! (gC/(m**2 of nat/agri ground)/day)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) :: soilcarbon_input
! times at which soil forcing file is written
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: times
! how many states were calculated for a given soil forcing time step
! turnover time of leaves
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: turnover_time
! daily total CO2 flux (gC/m**2/day)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: co2_flux_daily
! monthly total CO2 flux (gC/m**2)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: co2_flux_monthly
! conversion of biomass to litter (gC/(m**2 of nat/agri ground))/day
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: bm_to_litter
INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: nforce
! forcing data in memory
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: clay_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: humrel_daily_x_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: litterhum_daily_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: t2m_daily_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: t2m_min_daily_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: tsurf_daily_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: tsoil_daily_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: soilhum_daily_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: precip_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: gpp_daily_x_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: resp_maint_part_x_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: veget_x_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: veget_max_x_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: lai_x_fm
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: clay_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: humrel_daily_x_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: litterhum_daily_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: t2m_daily_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: t2m_min_daily_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: tsurf_daily_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: tsoil_daily_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: soilhum_daily_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: precip_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: gpp_daily_x_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: resp_maint_part_x_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: veget_x_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: veget_max_x_fm_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: lai_x_fm_g
INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: isf
LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:) :: nf_written
INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: nf_cumul
! first call
LOGICAL,SAVE :: l_first_stomate = .TRUE.
! flag for cumul of forcing if teststomate
LOGICAL,SAVE :: cumul_forcing=.FALSE.
!
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: resp_maint_part_radia
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: resp_maint_part
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_maint_radia
! deforestation variables
! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
! (10 or 100 + 1 : input from year of deforestation)
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: prod10
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: prod100
! annual release from the 10/100 year-turnover pool compartments
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: flux10
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: flux100
! new total natural space (fraction of total space)
REAL(r_std),ALLOCATABLE,SAVE, DIMENSION(:) :: space_nat_new
! new "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std),ALLOCATABLE,SAVE, DIMENSION(:,:) :: veget_max_new
! release during first year following deforestation
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: convflux
! total annual release from the 10/100 year-turnover pool
REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: cflux_prod10, cflux_prod100
! deforestation (land cover change) flag
LOGICAL,SAVE :: defor
CONTAINS
!
!=
!
SUBROUTINE stomate_main &
& (kjit, kjpij, kjpindex, dtradia, dt_slow, &
& ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
& index, lalo, neighbours, resolution, contfrac, fraction_nobio, clay, &
& t2m, t2m_min, temp_sol, stempdiag, &
& humrel_x, shumdiag, litterhumdiag, precip_rain, precip_snow, &
& gpp_x, deadleaf_cover, assim_param_x, &
& lai_x, height_x, veget_x, veget_max_x, qsintmax, &
& hist_id, hist2_id, rest_id_stom, hist_id_stom, &
& co2_flux,resp_maint_x,resp_hetero_x,resp_growth_x)
!---------------------------------------------------------------------
!
! 0 interface description
!
! 0.1 input
!
! 0.1.1 input scalar
!
! Time step number
INTEGER(i_std),INTENT(in) :: kjit
! Domain size
INTEGER(i_std),INTENT(in) :: kjpindex
! Total size of the un-compressed grid
INTEGER(i_std),INTENT(in) :: kjpij
! Time step of SECHIBA
REAL(r_std),INTENT(in) :: dtradia
! Time step of STOMATE
REAL(r_std),INTENT(in) :: dt_slow
! Logical for _restart_ file to read
LOGICAL,INTENT(in) :: ldrestart_read
! Logical for _restart_ file to write
LOGICAL,INTENT(in) :: ldrestart_write
! Logical for _forcing_ file to write
LOGICAL,INTENT(in) :: ldforcing_write
! Logical for _carbon_forcing_ file to write
LOGICAL,INTENT(in) :: ldcarbon_write
! SECHIBA's _history_ file identifier
INTEGER(i_std),INTENT(in) :: hist_id
! SECHIBA's _history_ file 2 identifier
INTEGER(i_std),INTENT(in) :: hist2_id
! STOMATE's _Restart_ file file identifier
INTEGER(i_std),INTENT(in) :: rest_id_stom
! STOMATE's _history_ file file identifier
INTEGER(i_std),INTENT(in) :: hist_id_stom
!
! 0.1.2 input fields
!
! Indeces of the points on the map
INTEGER(i_std),DIMENSION(kjpindex),INTENT(in) :: index
! Geogr. coordinates (latitude,longitude) (degrees)
REAL(r_std),DIMENSION(kjpindex,2),INTENT(in) :: lalo
! neighoring grid points if land
INTEGER(i_std),DIMENSION(kjpindex,8),INTENT(in) :: neighbours
! size in x an y of the grid (m)
REAL(r_std),DIMENSION(kjpindex,2),INTENT(in) :: resolution
! fraction of continent in the grid
REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: contfrac
! fraction of grid cell covered by lakes, land ice, cities, ...
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: fraction_nobio
! clay fraction
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: clay
! Relative humidity ("moisture availability")
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in) :: humrel_x
! 2 m air temperature (K)
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: t2m
! min. 2 m air temp. during forcing time step (K)
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: t2m_min
! Surface temperature
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: temp_sol
! Soil temperature
REAL(r_std),DIMENSION(kjpindex,nbdl),INTENT(in) :: stempdiag
! Relative soil moisture
REAL(r_std),DIMENSION(kjpindex,nbdl),INTENT(in) :: shumdiag
! Litter humidity
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: litterhumdiag
! Rain precipitation
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: precip_rain
! Snow precipitation
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: precip_snow
! GPP (gC/(m**2 of total ground)/time step)
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in) :: gpp_x
!
! 0.2 output
!
! 0.2.1 output scalar
!
! 0.2.2 output fields
!
! CO2 flux in gC/m**2 of average ground/dt
REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: co2_flux
! autotrophic respiration in gC/m**2 of surface/dt
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out) :: resp_maint_x
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out) :: resp_growth_x
REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: resp_hetero_x
!
! 0.3 modified
!
! 0.3.1 modified scalar
! 0.3.2 modified fields
!
! Surface foliere
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: lai_x
! Fraction of vegetation type from hydrological module.
! Takes into account ice etc.
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: veget_x
! Maximum fraction of vegetation type from hydrological module.
! Takes into account ice etc.
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: veget_max_x
! height (m)
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: height_x
! min+max+opt temps & vmax for photosynthesis
REAL(r_std),DIMENSION(kjpindex,nvm,npco2),INTENT(inout):: assim_param_x
! fraction of soil covered by dead leaves
REAL(r_std),DIMENSION(kjpindex),INTENT(inout) :: deadleaf_cover
! Maximum water on vegetation for interception
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: qsintmax
!
! 0.4 local declaration
!
! 0.4.1 variables defined on nvm in SECHIBA, npft in STOMATE/LPJ
!
! moisture availability
REAL(r_std),DIMENSION(kjpindex,npft) :: humrel
! gross primary productivity (gC/(m**2 of total ground)/day)
REAL(r_std),DIMENSION(kjpindex,npft) :: gpp
! fractional coverage: actually covered space,
! taking into account LAI (= grid scale fpc).
! Fraction of nat/agri ground.
REAL(r_std),DIMENSION(kjpindex,npft) :: veget
!
! 0.4.2 other
!
! time step of STOMATE in days
REAL(r_std),SAVE :: dt_days
! to check
REAL(r_std),SAVE :: day_counter
! date (d)
INTEGER(i_std),SAVE :: date
! soil level used for LAI
INTEGER(i_std),SAVE :: lcanop
! STOMATE time step read in restart file
REAL(r_std) :: dt_days_read
! Maximum STOMATE time step (days)
REAL(r_std),PARAMETER :: max_dt_days = 5.
! is it time for Stomate or update of LAI etc. ?
LOGICAL :: do_slow
! Writing frequency for history file (d)
REAL(r_std) :: hist_days
! precipitation (mm/day)
REAL(r_std),DIMENSION(kjpindex) :: precip
! Maximum rate of carboxylation
REAL(r_std),DIMENSION(kjpindex,npft) :: vcmax
! Maximum rate of RUbp regeneration
REAL(r_std),DIMENSION(kjpindex,npft) :: vjmax
! Min temperature for photosynthesis (deg C)
REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_min
! Opt temperature for photosynthesis (deg C)
REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_opt
! Max temperature for photosynthesis (deg C)
REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_max
! leaf area index
REAL(r_std),DIMENSION(kjpindex,npft) :: lai
! total autotrophic respiration (gC/day/(m**2 of total ground))
REAL(r_std),DIMENSION(kjpindex) :: resp_auto_tot
! total photosynthesis (gC/day/(m**2 of total ground))
REAL(r_std),DIMENSION(kjpindex) :: gpp_tot
! -- LOOP
REAL(r_std) :: net_co2_flux_monthly, net_co2_flux_monthly_sum
INTEGER :: ios
! for forcing file: "daily" moisture availability
REAL(r_std),DIMENSION(kjpindex,nvm) :: humrel_daily_x
! for forcing file: "daily" gpp
REAL(r_std),DIMENSION(kjpindex,nvm) :: gpp_daily_x
! for forcing file: "daily" auto resp
REAL(r_std),DIMENSION(kjpindex,nvm,nparts) :: resp_maint_part_x
! total "vegetation" cover
REAL(r_std),DIMENSION(kjpindex) :: cvegtot
! height of vegetation (m)
REAL(r_std),DIMENSION(kjpindex,npft) :: height
INTEGER(i_std) :: ji, jv, i, j
REAL(r_std) :: trans_veg
REAL(r_std) :: tmp_day(1)
!
INTEGER(i_std) :: ier
! moisture control of heterotrophic respiration
REAL(r_std),DIMENSION(kjpindex,nlevs) :: control_moist_inst
! temperature control of heterotrophic respiration, above and below
REAL(r_std),DIMENSION(kjpindex,nlevs) :: control_temp_inst
! quantity of carbon going into carbon pools from litter decomposition
! (gC/(m**2 of nat/agri ground)/day)
REAL(r_std),DIMENSION(kjpindex,ncarb,nvegtypes):: soilcarbon_input_inst
! time step of soil forcing file (in days)
REAL(r_std),SAVE :: dt_forcesoil
INTEGER(i_std),SAVE :: nparan
INTEGER(i_std),SAVE :: nbyear
INTEGER(i_std),PARAMETER :: nparanmax=36
REAL(r_std) :: sf_time
INTEGER(i_std),SAVE :: iatt=1
INTEGER(i_std) :: max_totsize, totsize_1step,totsize_tmp
REAL(r_std) :: xn
INTEGER(i_std),SAVE :: nsfm, nsft
INTEGER(i_std),SAVE :: iisf
!-
CHARACTER(LEN=100), SAVE :: forcing_name,Cforcing_name
INTEGER(i_std),SAVE :: Cforcing_id
INTEGER(i_std),PARAMETER :: ndm = 10
INTEGER(i_std) :: vid
INTEGER(i_std) :: nneigh,direct
INTEGER(i_std),DIMENSION(ndm) :: d_id
! root temperature (convolution of root and soil temperature profiles)
REAL(r_std),DIMENSION(kjpindex,npft) :: t_root
REAL(r_std),DIMENSION(kjpindex,npft,nparts) :: coeff_maint
! temperature which is pertinent for maintenance respiration (K)
REAL(r_std),DIMENSION(kjpindex,nparts) :: t_maint_radia
! integration constant for root profile
REAL(r_std),DIMENSION(kjpindex) :: rpc
! long term annual mean temperature, C
REAL(r_std),DIMENSION(kjpindex) :: tl
! slope of maintenance respiration coefficient (1/K)
REAL(r_std),DIMENSION(kjpindex) :: slope
! soil levels (m)
REAL(r_std),DIMENSION(0:nbdl) :: z_soil
! root depth. This will, one day, be a prognostic variable.
! It will be calculated by
! STOMATE (save in restart file & give to hydrology module!),
! probably somewhere
! in the allocation routine. For the moment, it is prescribed.
REAL(r_std),DIMENSION(kjpindex,npft) :: rprof
INTEGER(i_std) :: l,k
! litter heterotrophic respiration (gC/day/m**2 of total ground)
REAL(r_std),DIMENSION(kjpindex,nvegtypes) :: resp_hetero_litter
! soil heterotrophic respiration (gC/day/m**2 of total ground)
REAL(r_std),DIMENSION(kjpindex,nvegtypes) :: resp_hetero_soil
INTEGER(i_std) :: iyear
! for deforestation data reading loop
INTEGER(i_std) :: jyear
! to be returned by IOIPSL
INTEGER(i_std) :: year, month, day
REAL(r_std) :: sec
! calendar stuff not provided by IOIPSL
INTEGER(i_std) :: month_len
LOGICAL :: year_bissex
REAL(r_std),DIMENSION(nbp_glo) :: clay_g
REAL(r_std),DIMENSION(nbp_glo) :: space_nat_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: soilcarbon_input_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: control_moist_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: control_temp_g
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: npp_equil_g
!---------------------------------------------------------------------
! first of all: store time step in common value
itime = kjit
CALL itau2ymds(itime, dtradia, year, month, day, sec)
! ask for the calendar
CALL ioget_calendar(one_year, one_day)
month_len = ioget_mon_len (year,month)
! Height of vegetation must be initialized to height_x at each time step
DO j=1,npft
height(:,j)=height_x(:,j+1)
ENDDO
z_soil(0) = 0.
z_soil(1:nbdl) = diaglev(1:nbdl)
DO j=1,npft
rprof(:,j) = 1./humcste(ipft_sechiba(j))
ENDDO
!-
! 1 do initialisation
!-
resp_growth_x=0
IF (l_first_stomate) THEN
IF (long_print) THEN
WRITE (numout,*) ' l_first_stomate : call stomate_init'
ENDIF
!
! 1.1 allocation, file definitions. Set flags.
!
CALL stomate_init (kjpij, kjpindex, index, ldforcing_write, lalo, &
rest_id_stom, hist_id_stom)
co2_flux_monthly(:) = 0.0
!
! 1.2 read PFT data
!
CALL data (kjpindex, lalo)
!
! 1.3 read STOMATE's start file
!
CALL readstart &
& (kjpindex, index, lalo, resolution, &
day_counter, dt_days_read, date, &
ind, adapted, regenerate, &
humrel_daily, litterhum_daily, &
t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
soilhum_daily, precip_daily, &
gpp_daily, npp_daily, turnover_daily, &
humrel_month, humrel_week, t2m_longterm, &
tlong_ref, t2m_month, t2m_week, &
tsoil_month, soilhum_month, fireindex, firelitter, &
maxhumrel_lastyear, maxhumrel_thisyear, &
minhumrel_lastyear, minhumrel_thisyear, &
maxgppweek_lastyear, maxgppweek_thisyear, &
gdd0_lastyear, gdd0_thisyear, &
precip_lastyear, precip_thisyear, &
gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
maxfpc_lastyear, maxfpc_thisyear, &
turnover_longterm, gpp_week, biomass, resp_maint_part, &
fvm, fv, leaf_age, leaf_frac, &
senescence, when_growthinit, age, &
resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
veget_lastlight, everywhere, need_adjacent, &
RIP_time, time_lowgpp, &
time_hum_min, hum_min_dormance, &
litterpart, litter, dead_leaves, &
carbon, black_carbon, lignin_struc,turnover_time,&
prod10,prod100,flux10, flux100)
! deforestation variables added as arguments
! 1.4 read the boundary conditions
!
CALL readbc (kjpindex, lalo, resolution, tlong_ref)
!
! 1.5 check time step
!
! 1.5.1 allow STOMATE's time step to change
! although this is dangerous
!
dt_days = dt_slow/one_day
IF (dt_days /= dt_days_read) THEN
WRITE(numout,*) 'slow_processes: STOMATE time step changes:', &
dt_days_read,' -> ',dt_days
ENDIF
! 1.5.2 time step has to be a multiple of a full day
IF ( ( dt_days-REAL(NINT(dt_days),r_std) ) > min_stomate ) THEN
WRITE(numout,*) 'slow_processes: STOMATE time step is wrong:', &
& dt_days,' days.'
STOP
ENDIF
! 1.5.3 upper limit to STOMATE's time step
IF ( dt_days > max_dt_days ) THEN
WRITE(numout,*) 'slow_processes: STOMATE time step too large:', &
& dt_days,' days.'
STOP
ENDIF
! 1.5.4 STOMATE time step must not be less than the forcing time step
IF ( dtradia > dt_days*one_day ) THEN
WRITE(numout,*) &
& 'slow_processes: STOMATE time step smaller than forcing time step.'
STOP
ENDIF
! 1.5.5 some more messages
WRITE(numout,*) 'slow_processes, STOMATE time step (d): ', dt_days
!
! 1.6 write forcing file for stomate?
!
IF (ldforcing_write) THEN
!Config Key = STOMATE_FORCING_NAME
!Config Desc = Name of STOMATE's forcing file
!Config Def = NONE
!Config Help = Name that will be given
!Config to STOMATE's offline forcing file
!-
forcing_name = stomate_forcing_name ! compatibilité avec driver Nicolas
CALL getin_p('STOMATE_FORCING_NAME',forcing_name)
IF ( TRIM(forcing_name) /= 'NONE' ) THEN
IF (is_root_prc) CALL SYSTEM ('rm -f '//TRIM(forcing_name))
WRITE(numout,*) 'writing a forcing file for STOMATE.'
!Config Key = STOMATE_FORCING_MEMSIZE
!Config Desc = Size of STOMATE forcing data in memory (MB)
!Config Def = 50
!Config Help = This variable determines how many
!Config forcing states will be kept in memory.
!Config Must be a compromise between memory
!Config use and frequeny of disk access.
max_totsize = 50
CALL getin_p('STOMATE_FORCING_MEMSIZE', max_totsize)
max_totsize = max_totsize*1000000
totsize_1step = &
& SIZE(clay)*KIND(clay) &
& +SIZE(humrel_daily_x)*KIND(humrel_daily_x) &
& +SIZE(litterhum_daily)*KIND(litterhum_daily) &
& +SIZE(t2m_daily)*KIND(t2m_daily) &
& +SIZE(t2m_min_daily)*KIND(t2m_min_daily) &
& +SIZE(tsurf_daily)*KIND(tsurf_daily) &
& +SIZE(tsoil_daily)*KIND(tsoil_daily) &
& +SIZE(soilhum_daily)*KIND(soilhum_daily) &
& +SIZE(precip_daily)*KIND(precip_daily) &
& +SIZE(gpp_daily_x)*KIND(gpp_daily_x) &
& +SIZE(resp_maint_part_x)*KIND(resp_maint_part_x) &
& +SIZE(veget_x)*KIND(veget_x) &
& +SIZE(veget_max_x)*KIND(veget_max_x) &
& +SIZE(lai_x)*KIND(lai_x)
CALL reduce_sum(totsize_1step,totsize_tmp)
CALL bcast(totsize_tmp)
totsize_1step=totsize_tmp
! total number of forcing steps
nsft = INT(one_year/(dt_slow/one_day))
! number of forcing steps in memory
nsfm = MIN(nsft, &
& MAX(1,NINT( REAL(max_totsize,r_std) &
& /REAL(totsize_1step,r_std))))
CALL init_forcing (kjpindex,nsfm,nsft)
isf(:) = (/ (i,i=1,nsfm) /)
nf_written(:) = .FALSE.
nf_cumul(:) = 0
iisf = 0
!-
IF (is_root_prc) THEN
ier = NF90_CREATE (TRIM(forcing_name),NF90_SHARE,forcing_id)
ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL,'dtradia',dtradia)
ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL,'dt_slow',dt_slow)
ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL, &
& 'nsft',REAL(nsft,r_std))
ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL, &
& 'kjpij',REAL(iim_g*jjm_g,r_std))
ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL, &
& 'kjpindex',REAL(nbp_glo,r_std))
!-
ier = NF90_DEF_DIM (forcing_id,'points',nbp_glo,d_id(1))
ier = NF90_DEF_DIM (forcing_id,'layers',nbdl,d_id(2))
ier = NF90_DEF_DIM (forcing_id,'pft',nvm,d_id(3))
direct=2
ier = NF90_DEF_DIM (forcing_id,'direction',direct,d_id(4))
nneigh=8
ier = NF90_DEF_DIM (forcing_id,'nneigh',nneigh,d_id(5))
ier = NF90_DEF_DIM (forcing_id,'time',nsft,d_id(6))
ier = NF90_DEF_DIM (forcing_id,'nbparts',nparts,d_id(7))
!-
ier = NF90_DEF_VAR (forcing_id,'points', r_typ,d_id(1),vid)
ier = NF90_DEF_VAR (forcing_id,'layers', r_typ,d_id(2),vid)
ier = NF90_DEF_VAR (forcing_id,'pft', r_typ,d_id(3),vid)
ier = NF90_DEF_VAR (forcing_id,'direction', r_typ,d_id(4),vid)
ier = NF90_DEF_VAR (forcing_id,'nneigh', r_typ,d_id(5),vid)
ier = NF90_DEF_VAR (forcing_id,'time', r_typ,d_id(6),vid)
ier = NF90_DEF_VAR (forcing_id,'nbparts', r_typ,d_id(7),vid)
ier = NF90_DEF_VAR (forcing_id,'index', r_typ,d_id(1),vid)
ier = NF90_DEF_VAR (forcing_id,'contfrac', r_typ,d_id(1),vid)
ier = NF90_DEF_VAR (forcing_id,'lalo', &
& r_typ,(/ d_id(1),d_id(4) /),vid)
ier = NF90_DEF_VAR (forcing_id,'neighbours', &
& r_typ,(/ d_id(1),d_id(5) /),vid)
ier = NF90_DEF_VAR (forcing_id,'resolution', &
& r_typ,(/ d_id(1),d_id(4) /),vid)
ier = NF90_DEF_VAR (forcing_id,'clay', &
& r_typ,(/ d_id(1),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'humrel', &
& r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'litterhum', &
& r_typ,(/ d_id(1),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'t2m', &
& r_typ,(/ d_id(1),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'t2m_min', &
& r_typ,(/ d_id(1),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'tsurf', &
& r_typ,(/ d_id(1),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'tsoil', &
& r_typ,(/ d_id(1),d_id(2),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'soilhum', &
& r_typ,(/ d_id(1),d_id(2),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'precip', &
& r_typ,(/ d_id(1),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'gpp', &
& r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'veget', &
& r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'veget_max', &
& r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'lai', &
& r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
ier = NF90_DEF_VAR (forcing_id,'resp_maint_part', &
& r_typ,(/ d_id(1),d_id(3),d_id(6),d_id(7) /),vid)
ier = NF90_ENDDEF (forcing_id)
!-
ier = NF90_INQ_VARID (forcing_id,'points',vid)
ier = NF90_PUT_VAR (forcing_id,vid, &
& (/(REAL(i,r_std),i=1,nbp_glo) /))
ier = NF90_INQ_VARID (forcing_id,'layers',vid)
ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nbdl)/))
ier = NF90_INQ_VARID (forcing_id,'pft',vid)
ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nvm)/))
ier = NF90_INQ_VARID (forcing_id,'direction',vid)
ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,2)/))
ier = NF90_INQ_VARID (forcing_id,'nneigh',vid)
ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,8)/))
ier = NF90_INQ_VARID (forcing_id,'time',vid)
ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nsft)/))
ier = NF90_INQ_VARID (forcing_id,'index',vid)
ier = NF90_PUT_VAR (forcing_id,vid,REAL(index_g,r_std))
ier = NF90_INQ_VARID (forcing_id,'contfrac',vid)
ier = NF90_PUT_VAR (forcing_id,vid,REAL(contfrac_g,r_std))
ier = NF90_INQ_VARID (forcing_id,'lalo',vid)
ier = NF90_PUT_VAR (forcing_id,vid,lalo_g)
!ym attention a neighbours, a modifier plus tard
ier = NF90_INQ_VARID (forcing_id,'neighbours',vid)
ier = NF90_PUT_VAR (forcing_id,vid,REAL(neighbours_g,r_std))
ier = NF90_INQ_VARID (forcing_id,'resolution',vid)
ier = NF90_PUT_VAR (forcing_id,vid,resolution_g)
ENDIF
ENDIF
ENDIF
!
! 1.7 write forcing file for the soil?
!
IF (ldcarbon_write) THEN
!
!Config Key = STOMATE_CFORCING_NAME
!Config Desc = Name of STOMATE's carbon forcing file
!Config Def = NONE
!Config Help = Name that will be given to STOMATE's carbon
!Config offline forcing file
!-
Cforcing_name = stomate_Cforcing_name ! compatibilité avec driver Nicolas
CALL getin_p('STOMATE_CFORCING_NAME',Cforcing_name)
IF ( TRIM(Cforcing_name) /= 'NONE' ) THEN
IF (is_root_prc) CALL SYSTEM ('rm -f '//TRIM(Cforcing_name))
!
! time step of forcesoil
!
!Config Key = FORCESOIL_STEP_PER_YEAR
!Config Desc = Number of time steps per year for carbon spinup
!Config Def = 12
!Config Help = Number of time steps per year for carbon spinup
nparan = 12
CALL getin_p('FORCESOIL_STEP_PER_YEAR', nparan)
IF ( nparan < 1 ) nparan = 1
!Config Key = FORCESOIL_NB_YEAR
!Config Desc = ??
!Config Def = 1
!Config Help = ??
nbyear=1
CALL getin_p('FORCESOIL_NB_YEAR', nbyear)
dt_forcesoil = 0.
nparan = nparan+1
DO WHILE (dt_forcesoil < dt_slow/one_day)
nparan = nparan-1
IF (nparan < 1) THEN
STOP 'Problem 1 with number of soil forcing time steps.'
ENDIF
dt_forcesoil = one_year/REAL(nparan,r_std)
ENDDO
IF ( nparan > nparanmax ) THEN
STOP 'Problem 2 with number of soil forcing time steps.'
ENDIF
WRITE(numout,*) 'time step of soil forcing (d): ',dt_forcesoil
ALLOCATE(times(0:nparan))
times(:) = (/ ((REAL(i,r_std)*dt_forcesoil),i=0,nparan*nbyear) /)
ALLOCATE( nforce(nparan*nbyear))
nforce(:) = 0
ALLOCATE(control_moist(kjpindex,nlevs,nparan*nbyear))
ALLOCATE(npp_equil(kjpindex,nparan*nbyear))
ALLOCATE(npp_tot(kjpindex))
ALLOCATE(control_temp(kjpindex,nlevs,nparan*nbyear))
ALLOCATE(soilcarbon_input(kjpindex,ncarb,nvegtypes,nparan*nbyear))
npp_equil(:,:) = zero
npp_tot(:) = zero
control_moist(:,:,:) = zero
control_temp(:,:,:) = zero
soilcarbon_input(:,:,:,:) = zero
ENDIF
ENDIF
!
! 1.8 calculate STOMATE's vegetation fractions
! from veget_x, veget_max_x, fv, and fvm
!
CALL stomate_vegconvert (kjpindex,'in',fraction_nobio, &
veget_max_x,veget_x,veget_max,veget,fvm,fv)
!
! 1.9 initialize some variables
! STOMATE diagnoses some variables for SECHIBA :
! assim_param, deadleaf_cover, etc.
! These variables can be recalculated easily
! from STOMATE's prognostic variables.
! height is saved in Sechiba.
!
IF (control%ok_stomate) THEN
CALL stomate_var_init &
& (kjpindex, veget, veget_max, leaf_age, leaf_frac, &
& tlong_ref, t2m_month, dead_leaves, &
& veget_x, lai_x, qsintmax, deadleaf_cover, assim_param_x,&
& prod10, prod100, flux10, flux100, &
& convflux,cflux_prod10, cflux_prod100)
! deforestation variables added as arguments
ENDIF
!
! 1.10 reset flag
!
l_first_stomate = .FALSE.
!
! 1.11 return
!
RETURN
ENDIF ! first call
IF (bavard >= 4) THEN
WRITE(*,*) 'DATE ',date,' ymds', year, month, day, sec, '-- stp --', itime
ENDIF
!-
! 2 prepares restart file for the next simulation
!-
IF (ldrestart_write) THEN
IF (long_print) THEN
WRITE (numout,*) &
& ' we have to complete restart file with STOMATE variables'
ENDIF
CALL writerestart &
& (kjpindex, index, &
& day_counter, dt_days, date, &
& ind, adapted, regenerate, &
& humrel_daily, litterhum_daily, &
& t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
& soilhum_daily, precip_daily, &
& gpp_daily, npp_daily, turnover_daily, &
& humrel_month, humrel_week, t2m_longterm, &
& tlong_ref, t2m_month, t2m_week, &
& tsoil_month, soilhum_month, fireindex, firelitter, &
& maxhumrel_lastyear, maxhumrel_thisyear, &
& minhumrel_lastyear, minhumrel_thisyear, &
& maxgppweek_lastyear, maxgppweek_thisyear, &
& gdd0_lastyear, gdd0_thisyear, &
& precip_lastyear, precip_thisyear, &
& gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
& PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
& maxfpc_lastyear, maxfpc_thisyear, &
& turnover_longterm, gpp_week, biomass, resp_maint_part, &
& fvm, fv, leaf_age, leaf_frac, &
& senescence, when_growthinit, age, &
& resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
& veget_lastlight, everywhere, need_adjacent, &
& RIP_time, time_lowgpp, &
& time_hum_min, hum_min_dormance, &
& litterpart, litter, dead_leaves, &
& carbon, black_carbon, lignin_struc,turnover_time,&
& prod10,prod100,flux10, flux100)
! deforestation variables added as arguments
IF (ldforcing_write .AND. TRIM(forcing_name) /= 'NONE' ) THEN
CALL forcing_write(forcing_id,1,iisf)
!
IF (is_root_prc) ier = NF90_CLOSE (forcing_id)
forcing_id=-1
ENDIF
IF (ldcarbon_write .AND. TRIM(Cforcing_name) /= 'NONE' ) THEN
WRITE(numout,*) &
& 'stomate: writing the forcing file for carbon spinup'
!
DO iatt = 1, nparan*nbyear
IF ( nforce(iatt) > 0 ) THEN
soilcarbon_input(:,:,:,iatt) = &
& soilcarbon_input(:,:,:,iatt)/REAL(nforce(iatt),r_std)
control_moist(:,:,iatt) = &
& control_moist(:,:,iatt)/REAL(nforce(iatt),r_std)
control_temp(:,:,iatt) = &
& control_temp(:,:,iatt)/REAL(nforce(iatt),r_std)
npp_equil(:,iatt) = &
& npp_equil(:,iatt)/REAL(nforce(iatt),r_std)
ELSE
WRITE(numout,*) &
& 'We have no soil carbon forcing data for this time step:', &
& iatt
WRITE(numout,*) ' -> we set them to zero'
soilcarbon_input(:,:,:,iatt) = zero
control_moist(:,:,iatt) = zero
control_temp(:,:,iatt) = zero
npp_equil(:,iatt) = zero
ENDIF
ENDDO
!-
IF (is_root_prc) THEN
ier = NF90_CREATE (TRIM(Cforcing_name),NF90_WRITE,Cforcing_id)
ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
& 'kjpindex',REAL(nbp_glo,r_std))
ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
& 'nparan',REAL(nparan,r_std))
ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
& 'nbyear',REAL(nbyear,r_std))
ier = NF90_DEF_DIM (Cforcing_id,'points',nbp_glo,d_id(1))
ier = NF90_DEF_DIM (Cforcing_id,'carbtype',ncarb,d_id(2))
ier = NF90_DEF_DIM (Cforcing_id,'vegtype',nvegtypes,d_id(3))
ier = NF90_DEF_DIM (Cforcing_id,'level',nlevs,d_id(4))
ier = NF90_DEF_DIM (Cforcing_id,'time_step',nparan*nbyear,d_id(5))
!-
ier = NF90_DEF_VAR (Cforcing_id,'points', r_typ,d_id(1),vid)
ier = NF90_DEF_VAR (Cforcing_id,'carbtype', r_typ,d_id(2),vid)
ier = NF90_DEF_VAR (Cforcing_id,'vegtype', r_typ,d_id(3),vid)
ier = NF90_DEF_VAR (Cforcing_id,'level', r_typ,d_id(4),vid)
ier = NF90_DEF_VAR (Cforcing_id,'time_step', r_typ,d_id(5),vid)
ier = NF90_DEF_VAR (Cforcing_id,'index', r_typ,d_id(1),vid)
ier = NF90_DEF_VAR (Cforcing_id,'clay', r_typ,d_id(1),vid)
ier = NF90_DEF_VAR (Cforcing_id,'space_nat', r_typ,d_id(1),vid)
ier = NF90_DEF_VAR (Cforcing_id,'soilcarbon_input',r_typ, &
& (/ d_id(1),d_id(2),d_id(3),d_id(5) /),vid)
ier = NF90_DEF_VAR (Cforcing_id,'control_moist',r_typ, &
& (/ d_id(1),d_id(4),d_id(5) /),vid)
ier = NF90_DEF_VAR (Cforcing_id,'control_temp',r_typ, &
& (/ d_id(1),d_id(4),d_id(5) /),vid)
ier = NF90_DEF_VAR (Cforcing_id,'npp_equil',r_typ, &
& (/ d_id(1),d_id(5) /),vid)
ier = NF90_ENDDEF (Cforcing_id)
!-
ier = NF90_INQ_VARID (Cforcing_id,'points',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, &
& (/(REAL(i,r_std),i=1,nbp_glo)/))
ier = NF90_INQ_VARID (Cforcing_id,'carbtype',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, &
& (/(REAL(i,r_std),i=1,ncarb)/))
ier = NF90_INQ_VARID (Cforcing_id,'vegtype',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, &
& (/(REAL(i,r_std),i=1,nvegtypes)/))
ier = NF90_INQ_VARID (Cforcing_id,'level',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, &
& (/(REAL(i,r_std),i=1,nlevs)/))
ier = NF90_INQ_VARID (Cforcing_id,'time_step',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, &
& (/(REAL(i,r_std),i=1,nparan*nbyear)/))
ier = NF90_INQ_VARID (Cforcing_id,'index',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, REAL(index_g,r_std) )
ier = NF90_INQ_VARID (Cforcing_id,'clay',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, clay_g )
ier = NF90_INQ_VARID (Cforcing_id,'space_nat',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, space_nat_g )
ALLOCATE(soilcarbon_input_g(nbp_glo,ncarb,nvegtypes,nparan*nbyear))
ier = NF90_INQ_VARID (Cforcing_id,'soilcarbon_input',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, soilcarbon_input_g )
ALLOCATE(control_moist_g(nbp_glo,nlevs,nparan*nbyear))
ier = NF90_INQ_VARID (Cforcing_id,'control_moist',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, control_moist_g )
ALLOCATE(control_temp_g(nbp_glo,nlevs,nparan*nbyear))
ier = NF90_INQ_VARID (Cforcing_id,'control_temp',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, control_temp_g )
ALLOCATE(npp_equil_g(nbp_glo,nparan*nbyear))
ier = NF90_INQ_VARID (Cforcing_id,'npp_equil',vid)
ier = NF90_PUT_VAR (Cforcing_id,vid, npp_equil_g )
!-
ier = NF90_CLOSE (Cforcing_id)
Cforcing_id = -1
ENDIF
CALL gather(clay,clay_g)
CALL gather(space_nat,space_nat_g)
CALL gather(soilcarbon_input,soilcarbon_input_g)
CALL gather(control_moist,control_moist_g)
CALL gather(control_temp,control_temp_g)
CALL gather(npp_equil,npp_equil_g)
IF (is_root_prc) THEN
DEALLOCATE(soilcarbon_input_g)
DEALLOCATE(control_moist_g)
DEALLOCATE(control_temp_g)
DEALLOCATE(npp_equil_g)
ENDIF
ENDIF
RETURN
ENDIF ! write restart-files
!-
! 3 Here's where the serious things begin -
! Check whether stomate and dgvm have to be called
!-
!
! 3.1 update day counter
!
day_counter = day_counter+dtradia
IF (NINT(day_counter) >= NINT(dt_slow)) THEN
!
! 3.2 we have to call STOMATE
! (or daily update of vegetation characteristics)?
!
! reset counter
day_counter = zero
do_slow = .TRUE.
!
! 3.3 is one year over?
! EndOfYear must be true once per year
! during a call of stomate_season.
!
! increase date
dt_days = dt_slow/one_day
! compilation bug : nint added
date = date+nint(dt_days)
IF ( ((date-NINT(date/one_year)*one_year) < .0 ) &
& .AND.((date-NINT(date/one_year)*one_year) >= -dt_days) ) THEN
EndOfYear = .TRUE.
IF ( (bavard >= 2).AND.EndOfYear.AND.do_slow) THEN
WRITE(numout,*) 'stomate: EndOfYear'
ENDIF
ELSE
EndOfYear = .FALSE.
ENDIF
ELSE
do_slow = .FALSE.
EndOfYear = .FALSE.
ENDIF
IF ( (ldcarbon_write) .AND. TRIM(Cforcing_name) /= 'NONE' &
& .AND.((date-NINT(date/one_year)*one_year) == dt_days) ) THEN
control_moist(:,:,:) = zero
control_temp(:,:,:) = zero
soilcarbon_input(:,:,:,:) = zero
nforce=0
ENDIF
!
! 4 Special treatment for some input arrays.
!
!
! 4.1 Sum of liquid and solid precipitation
!
precip = ( precip_rain+precip_snow )*one_day/dtradia
!
! 4.2 Transform from dimension nvm to dimension npft.
! In SECHIBA, some variables are defined
! for all PFTs AND on bare ground -> nvm
! In STOMATE/LPJ, we do not treat bare ground.
! The same variable need not be
! defined on bare ground in STOMATE/LPJ -> npft
! Moreover, several Stomate-PFTs can be aggregated
! to one single PFT in Sechiba.
! This is not used for the moment, but it might be used
! once an age structure is introduced in Stomate.
! In that case, the different age groups of a PFT may
! be treated separately in Stomate,
! but as a single PFT in Sechiba.
! The corresponding variables exchanged with the rest
! of SECHIBA are tagged _x.
! XXX_x(:,ibare_sechiba) is the bare soil part.
! ipft_sechiba(j) is the Sechiba PFT index corresponding
! to the Stomate PFT index j.
!
! 4.2.1 calculate STOMATE's vegetation fractions
! from veget_x, veget_max_x, fv, and fvm
!
CALL stomate_vegconvert (kjpindex,'in',fraction_nobio, &
veget_max_x,veget_x,veget_max,veget,fvm,fv)
DO j=1,npft
! 4.2.2 GPP
! gpp in gC/m**2 of total ground/day
WHERE (veget_max_x(:,ipft_sechiba(j)) > 0.0)
gpp(:,j) = gpp_x(:,ipft_sechiba(j))*one_day/dtradia &
& *(veget_max(:,j)/veget_max_x(:,ipft_sechiba(j)))
ELSEWHERE
gpp(:,j) = 0.0
ENDWHERE
! 4.2.3 moisture availability
humrel(:,j) = humrel_x(:,ipft_sechiba(j))
ENDDO
space_nat(:) = 1.0
DO j=1,npft
IF (.NOT.natural(j) ) THEN
space_nat(:) = space_nat(:)-veget_max(:,j)
ENDIF
ENDDO
!
! 5 "daily" variables
! Note: If dt_days /= 1, then xx_daily are not daily variables,
! but that is not really a problem.
!
!
! 5.1 accumulate instantaneous variables
! and eventually calculate daily mean value
!
CALL stomate_accu (kjpindex, npft, dt_slow, dtradia, &
& do_slow, humrel, humrel_daily)
CALL stomate_accu (kjpindex, 1, dt_slow, dtradia, &
& do_slow, litterhumdiag, litterhum_daily)
CALL stomate_accu (kjpindex, 1, dt_slow, dtradia, &
& do_slow, t2m, t2m_daily)
CALL stomate_accu (kjpindex, 1, dt_slow, dtradia, &
& do_slow, temp_sol, tsurf_daily)
CALL stomate_accu (kjpindex, nbdl, dt_slow, dtradia, &
& do_slow, stempdiag, tsoil_daily)
CALL stomate_accu (kjpindex, nbdl, dt_slow, dtradia, &
& do_slow, shumdiag, soilhum_daily)
CALL stomate_accu (kjpindex, 1, dt_slow, dtradia, &
& do_slow, precip, precip_daily)
CALL stomate_accu (kjpindex, npft, dt_slow, dtradia, &
& do_slow, gpp, gpp_daily)
!
! 5.2 daily minimum temperature
!
t2m_min_daily(:) = MIN( t2m_min(:), t2m_min_daily(:) )
!
! 5.3 calculate respiration (NV 14/5/2002)
!
! 5.3.1 calculate maintenance respiration
!
CALL maint_respiration &
& (kjpindex,dtradia,t2m,tlong_ref,stempdiag,height,veget_max,space_nat, &
& rprof,biomass,resp_maint_part_radia)
resp_maint_radia(:,:) = zero
DO j=1,npft
DO k= 1, nparts
resp_maint_radia(:,j) = resp_maint_radia(:,j) &
& +resp_maint_part_radia(:,j,k)
ENDDO
ENDDO
resp_maint_part(:,:,:)= resp_maint_part(:,:,:) &
& +resp_maint_part_radia(:,:,:)
!
! 5.3.2 the whole litter stuff:
! litter update, lignin content, PFT parts, litter decay,
! litter heterotrophic respiration, dead leaf soil cover.
! No vertical discretisation in the soil for litter decay.
!
CALL littercalc (kjpindex, dtradia/one_day, space_nat, &
turnover_daily*dtradia/one_day, bm_to_litter*dtradia/one_day, &
temp_sol, stempdiag, shumdiag, litterhumdiag, &
litterpart, litter, dead_leaves, lignin_struc, &
deadleaf_cover, resp_hetero_litter, &
soilcarbon_input_inst, control_temp_inst, control_moist_inst)
resp_hetero_litter=resp_hetero_litter*dtradia/one_day
!
! 5.3.3 soil carbon dynamics: heterotrophic respiration from the soil.
! For the moment, no vertical discretisation.
! We might later introduce a vertical discretisation.
! However, in that case, we would have to treat the vertical
! exchanges of carbon between the different levels.
!
CALL soilcarbon (kjpindex, dtradia/one_day, clay, space_nat, &
soilcarbon_input_inst, control_temp_inst, control_moist_inst, &
carbon, resp_hetero_soil)
resp_hetero_soil=resp_hetero_soil*dtradia/one_day
resp_hetero_radia = resp_hetero_litter+resp_hetero_soil
resp_hetero= resp_hetero+resp_hetero_radia
!
! 6 Daily processes
!
IF (do_slow) THEN
! update veget_max_new and space_nat_new by reading data file
defor = .FALSE.
CALL getin_p('DEFOR', defor)
IF(defor) then
IF(EndOfYear) then
IF (is_root_prc) THEN
open(10,file='veget_defor.dat')
read(10,*)jyear,veget_max_new
ENDIF
CALL bcast(jyear)
CALL bcast(veget_max_new)
space_nat_new(:) = 1.0
DO j = 1, npft
IF ( .NOT. natural(j) ) THEN
space_nat_new(:) = space_nat_new(:) - veget_max_new(:,j)
ENDIF
ENDDO
CALL natagritot (kjpindex, ito_natagri, space_nat_new, veget_max_new)
ENDIF
ENDIF
!
! 6.1 total natural space
!
!
! 6.2 Calculate longer-term "meteorological" and biological parameters
!
CALL season &
& (kjpindex, dt_days, EndOfYear, space_nat, &
& veget, veget_max, &
& humrel_daily, t2m_daily, tsoil_daily, soilhum_daily, &
& precip_daily, npp_daily, biomass, &
& turnover_daily, gpp_daily, when_growthinit, &
& maxhumrel_lastyear, maxhumrel_thisyear, &
& minhumrel_lastyear, minhumrel_thisyear, &
& maxgppweek_lastyear, maxgppweek_thisyear, &
& gdd0_lastyear, gdd0_thisyear, &
& precip_lastyear, precip_thisyear, &
& lm_lastyearmax, lm_thisyearmax, &
& maxfpc_lastyear, maxfpc_thisyear, &
& humrel_month, humrel_week, t2m_longterm, &
& tlong_ref, t2m_month, t2m_week, tsoil_month, soilhum_month, &
& npp_longterm, turnover_longterm, gpp_week, &
& gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
& time_lowgpp, time_hum_min, hum_min_dormance, herbivores)
!
! 6.3 transform GPP from gC/(m**2 of total ground)/day to
! gC/(m**2 of nat/agri ground)/day
!
CALL natagritot (kjpindex, ito_natagri, space_nat, gpp_daily)
!
! 6.4 STOMATE: allocation, phenology, etc.
!
IF (control%ok_stomate) THEN
! 6.4.1.a transform spatial fractions from fraction
! of total space to fraction of natural/agricultural space
CALL natagritot (kjpindex, ito_natagri, space_nat, veget)
CALL natagritot (kjpindex, ito_natagri, space_nat, veget_max)
! 6.4.1.b update lai
IF (control%ok_pheno) THEN ! lai from stomate
DO j = 1, npft
WHERE ( veget_max(:,j) .GT. min_sechiba )
lai(:,j) = biomass(:,j,ileaf)/veget_max(:,j)*sla(j)
ELSEWHERE
lai(:,j) = 0.0
ENDWHERE
ENDDO
ELSE
CALL setlai(kjpindex,lai) ! lai prescribed
ENDIF
! 6.4.2 call stomate
CALL StomateLpj &
& (kjpindex, dt_days, EndOfYear, &
& neighbours, resolution, space_nat, &
& clay, herbivores, &
& tsurf_daily, tsoil_daily, t2m_daily, t2m_min_daily, &
& litterhum_daily, soilhum_daily, &
& maxhumrel_lastyear, minhumrel_lastyear, &
& gdd0_lastyear, precip_lastyear, &
& humrel_month, humrel_week, tlong_ref, t2m_month, t2m_week, &
& tsoil_month, soilhum_month, &
& gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
& turnover_longterm, gpp_daily, time_lowgpp, &
& time_hum_min, maxfpc_lastyear, resp_maint_part,&
& PFTpresent, age, fireindex, firelitter, &
& leaf_age, leaf_frac, biomass, ind, adapted, regenerate, &
& senescence, when_growthinit, litterpart, litter, &
& dead_leaves, carbon, black_carbon, lignin_struc, &
& veget_max, veget, npp_longterm, lm_lastyearmax, &
& veget_lastlight, everywhere, need_adjacent, RIP_time, &
& lai, rprof,npp_daily, turnover_daily, turnover_time,&
& control_moist_inst, control_temp_inst, soilcarbon_input_inst, &
& co2_to_bm_dgvm, co2_fire, resp_hetero, resp_maint, &
& resp_growth, height, deadleaf_cover, vcmax, vjmax, &
& t_photo_min, t_photo_opt, t_photo_max,bm_to_litter,&
& prod10, prod100, flux10, flux100, space_nat_new, veget_max_new,&
& convflux, cflux_prod10, cflux_prod100, defor)
! deforestation variables added as arguments + EndOfYear
! 6.4.3 transform spatial fractions from fraction
! of natural/agricultural space to fraction of total space
CALL natagritot (kjpindex, ito_total, space_nat, veget)
CALL natagritot (kjpindex, ito_total, space_nat, veget_max)
!
! 6.5 output: transform from dimension npft to dimension nvm
! Several Stomate-PFTs may correspond
! to a single Sechiba-PFT (see 4.2).
! We sum up the vegetation cover over these Stomate-PFTs.
! Mean LAI, height, and Vmax is calculated
! by ponderating with (maximum) vegetation cover.
!
! 6.5.1 calculate veget_x, veget_max_x,
! fv and fvm from veget and veget_max
!
CALL stomate_vegconvert &
& (kjpindex,'out',fraction_nobio, &
& veget_max_x,veget_x,veget_max,veget,fvm,fv)
! 6.5.2 lai and height
CALL stomate_var_xout (kjpindex,lai,veget_max,zero,lai_x)
CALL stomate_var_xout (kjpindex,height,veget_max,zero,height_x)
! 6.5.3 photosynthesis parameters
CALL stomate_var_xout &
& (kjpindex,vcmax,veget,zero,assim_param_x(:,:,ivcmax))
CALL stomate_var_xout &
& (kjpindex,vjmax,veget,zero,assim_param_x(:,:,ivjmax))
CALL stomate_var_xout &
& (kjpindex,t_photo_min,veget,zero,assim_param_x(:,:,itmin))
CALL stomate_var_xout &
& (kjpindex,t_photo_opt,veget,zero,assim_param_x(:,:,itopt))
CALL stomate_var_xout &
& (kjpindex,t_photo_max,veget,zero,assim_param_x(:,:,itmax))
!
! 6.6 update forcing variables for soil carbon
!
IF (ldcarbon_write .AND. TRIM(Cforcing_name) /= 'NONE') THEN
!
! determime the carbon soil time step we are falling into
!
! where are we within the current year?
sf_time = date &
& -FLOOR(date/(one_year*REAL(nbyear,r_std)))*one_year*nbyear
DO WHILE ( sf_time > one_year )
sf_time = sf_time-one_year
ENDDO
DO WHILE ( sf_time < 0. )
sf_time = sf_time+one_year
ENDDO
iyear=1
IF (iatt > nparan) iatt=1
IF ( (times(iatt-1) > sf_time ) &
& .OR.(times(iatt) <= sf_time ) ) THEN
iatt = nparan
! look for corresponding time step
DO i = nparan, 1, -1
IF ( times(i) > sf_time ) iatt = i
ENDDO
ENDIF ! otherwise, iatt was already OK!
! we know now what soil forcing time step we are talking about.
! Increase counter for this soil carbon time step
! and update "mean" forcing variables.
nforce(iatt) = nforce(iatt)+1
soilcarbon_input(:,:,:,iatt+(iyear-1)*nparan) = &
& soilcarbon_input(:,:,:,iatt+(iyear-1)*nparan) &
& +soilcarbon_input_inst(:,:,:)
control_moist(:,:,iatt+(iyear-1)*nparan) = &
& control_moist(:,:,iatt+(iyear-1)*nparan) &
& +control_moist_inst(:,:)
control_temp(:,:,iatt+(iyear-1)*nparan) = &
& control_temp(:,:,iatt+(iyear-1)*nparan) &
& +control_temp_inst(:,:)
npp_equil(:,iatt+(iyear-1)*nparan) = &
& npp_equil(:,iatt+(iyear-1)*nparan) &
& +npp_tot(:)
! nforce(iatt) = 1
! soilcarbon_input(:,:,:,iatt) = soilcarbon_input_inst(:,:,:)
! control_moist(:,:,iatt) = control_moist_inst(:,:)
! control_temp(:,:,iatt) = control_temp_inst(:,:)
! npp_equil(:,iatt) = npp_tot(:)
ENDIF
!
! 6.7 updates qsintmax
!
qsintmax(:,:) = qsintcst*veget_x(:,:)*lai_x(:,:)
ENDIF
!
! 6.8 write forcing file?
! ldforcing_write should only be .TRUE.
! if STOMATE is run in coupled mode.
! In stand-alone mode, the forcing file is read!
!
IF ( ldforcing_write .AND. TRIM(forcing_name) /= 'NONE' ) THEN
CALL natagritot (kjpindex, ito_total, space_nat, gpp_daily)
gpp_daily_x(:,:) = 0.0
resp_maint_part_x(:,:,:) = 0.0
DO j = 1, npft
! don't worry about weightings. humrel is not modified in STOMATE.
humrel_daily_x(:,ipft_sechiba(j)) = humrel_daily(:,j)
gpp_daily_x(:,ipft_sechiba(j)) = &
& gpp_daily_x(:,ipft_sechiba(j)) &
& +gpp_daily(:,j)*dt_slow/one_day
resp_maint_part_x(:,ipft_sechiba(j),:) = &
& resp_maint_part_x(:,ipft_sechiba(j),:) &
& +resp_maint_part(:,j,:)*dt_slow/one_day
ENDDO
!
! bare soil moisture availability has not been treated
! in STOMATE (doesn't matter)
!
humrel_daily_x(:,ibare_sechiba) = humrel_x(:,ibare_sechiba)
! next forcing step in memory
iisf = iisf+1
! how many times have we treated this forcing state
xn = REAL(nf_cumul(isf(iisf)),r_std)
! cumulate. be careful :
! precipitation is multiplied by dt_slow/one_day
IF (cumul_forcing) THEN
clay_fm(:,iisf) = (xn*clay_fm(:,iisf)+clay(:))/(xn+1.)
humrel_daily_x_fm(:,:,iisf) = &
& (xn*humrel_daily_x_fm(:,:,iisf)+humrel_daily_x(:,:))/(xn+1.)
litterhum_daily_fm(:,iisf) = &
& (xn*litterhum_daily_fm(:,iisf)+litterhum_daily(:))/(xn+1.)
t2m_daily_fm(:,iisf) = &
& (xn*t2m_daily_fm(:,iisf)+t2m_daily(:))/(xn+1.)
t2m_min_daily_fm(:,iisf) = &
& (xn*t2m_min_daily_fm(:,iisf)+t2m_min_daily(:))/(xn+1.)
tsurf_daily_fm(:,iisf) = &
& (xn*tsurf_daily_fm(:,iisf)+tsurf_daily(:))/(xn+1.)
tsoil_daily_fm(:,:,iisf) = &
& (xn*tsoil_daily_fm(:,:,iisf)+tsoil_daily(:,:))/(xn+1.)
soilhum_daily_fm(:,:,iisf) = &
& (xn*soilhum_daily_fm(:,:,iisf)+soilhum_daily(:,:))/(xn+1.)
precip_fm(:,iisf) = &
& (xn*precip_fm(:,iisf)+precip_daily(:)*dt_slow/one_day)/(xn+1.)
gpp_daily_x_fm(:,:,iisf) = &
& (xn*gpp_daily_x_fm(:,:,iisf)+gpp_daily_x(:,:))/(xn+1.)
resp_maint_part_x_fm(:,:,:,iisf) = &
& ( xn*resp_maint_part_x_fm(:,:,:,iisf) &
& +resp_maint_part_x(:,:,:) )/(xn+1.)
veget_x_fm(:,:,iisf) = &
& (xn*veget_x_fm(:,:,iisf)+veget_x(:,:) )/(xn+1.)
veget_max_x_fm(:,:,iisf) = &
& (xn*veget_max_x_fm(:,:,iisf)+veget_max_x(:,:) )/(xn+1.)
lai_x_fm(:,:,iisf) = &
& (xn*lai_x_fm(:,:,iisf)+lai_x(:,:) )/(xn+1.)
ELSE
clay_fm(:,iisf) = clay(:)
humrel_daily_x_fm(:,:,iisf) = humrel_daily_x(:,:)
litterhum_daily_fm(:,iisf) = +litterhum_daily(:)
t2m_daily_fm(:,iisf) = t2m_daily(:)
t2m_min_daily_fm(:,iisf) =t2m_min_daily(:)
tsurf_daily_fm(:,iisf) = tsurf_daily(:)
tsoil_daily_fm(:,:,iisf) =tsoil_daily(:,:)
soilhum_daily_fm(:,:,iisf) =soilhum_daily(:,:)
precip_fm(:,iisf) = precip_daily(:)
gpp_daily_x_fm(:,:,iisf) =gpp_daily_x(:,:)
resp_maint_part_x_fm(:,:,:,iisf) = resp_maint_part_x(:,:,:)
veget_x_fm(:,:,iisf) = veget_x(:,:)
veget_max_x_fm(:,:,iisf) =veget_max_x(:,:)
lai_x_fm(:,:,iisf) =lai_x(:,:)
ENDIF
nf_cumul(isf(iisf)) = nf_cumul(isf(iisf))+1
! do we have to write the forcing states?
IF (iisf == nsfm) THEN
! write these forcing states
CALL forcing_write(forcing_id,1,nsfm)
! determine which forcing states must be read
isf(1) = isf(nsfm)+1
IF ( isf(1) > nsft ) isf(1) = 1
DO iisf = 2, nsfm
isf(iisf) = isf(iisf-1)+1
IF (isf(iisf) > nsft) isf(iisf) = 1
ENDDO
! read them
CALL forcing_read(forcing_id,nsfm)
iisf = 0
ENDIF
ENDIF
! 6.9 compute daily co2_flux
resp_auto_tot(:) = 0.0
DO j=1,npft
resp_auto_tot(:) = resp_auto_tot(:) &
& +resp_maint(:,j)+resp_growth(:,j)
ENDDO
! total photosynthesis (in gC/m**2/day)
gpp_tot(:) = 0.0
DO j=1,npft
gpp_tot(:) = gpp_tot(:)+gpp_daily(:,j)
ENDDO
! CO2 flux in gC/m**2/sec
! (positive towards the atmosphere) is sum of:
! 1/ heterotrophic respiration from natural and agricultural ground
! 2/ maintenance respiration from the plants
! 3/ growth respiration from the plants
! 4/ co2 created by fire
! 5/ - co2 taken up in the DGVM to establish saplings.
! 6/ - co2 taken up by photosyntyhesis
co2_flux_daily(:) = ( resp_hetero(:,inat) &
& +resp_hetero(:,iagri) &
& +resp_auto_tot(:) &
& +co2_fire(:)-co2_to_bm_dgvm(:)-gpp_tot(:) )
CALL histwrite (hist_id, 'CO2FLUX', itime, &
co2_flux_daily, kjpindex, index)
IF ( hist2_id > 0 ) THEN
CALL histwrite (hist2_id, 'CO2FLUX', itime, &
co2_flux_daily, kjpindex, index)
ENDIF
!
co2_flux_monthly(:) = co2_flux_monthly(:) + co2_flux_daily(:)
IF ( (day .EQ. month_len) .AND. (INT(sec) .EQ. 0) ) THEN
IF ( control%ok_stomate ) THEN
CALL histwrite (hist_id_stomate, 'CO2FLUX_MONTHLY', itime, &
co2_flux_monthly, kjpindex, hori_index)
ENDIF
co2_flux_monthly(:) = co2_flux_monthly(:)* &
resolution(:,1)*resolution(:,2)*contfrac(:)
net_co2_flux_monthly = sum(co2_flux_monthly)
WRITE(numout,*) 'net_co2_flux_monthly = ',net_co2_flux_monthly
CALL reduce_sum(net_co2_flux_monthly,net_co2_flux_monthly_sum)
IF (is_root_prc) THEN
OPEN( unit=39, &
file="stomate_co2flux.data", &
action="write", &
position="append", &
iostat=ios )
IF ( ios /= 0 ) THEN
STOP "Erreur lors de la lecture/ecriture du fichier stomate_co2flux.data"
ELSE
WRITE(numout,*)
WRITE(numout,*) "Ecriture du fichier stomate_co2flux.data"
WRITE(numout,*)
END IF
WRITE(39,*) net_co2_flux_monthly_sum*1e-15
CLOSE( unit=39 )
ENDIF
co2_flux_monthly(:) = 0.0
ENDIF
!
! 6.10 reset daily variables
!
humrel_daily(:,:) = 0.0
litterhum_daily(:) = 0.0
t2m_daily(:) = 0.0
t2m_min_daily(:) = large_value
tsurf_daily(:) = 0.0
tsoil_daily(:,:) = 0.0
soilhum_daily(:,:) = 0.0
precip_daily(:) = 0.0
gpp_daily(:,:) = 0.0
resp_maint_part(:,:,:)=0.0
resp_hetero=0.0
IF (bavard >= 3) THEN
WRITE(numout,*) 'stomate_main: daily processes done'
ENDIF
ENDIF ! daily processes?
!
! 7 Outputs from Stomate
! co2_flux is assigned a value only if STOMATE is activated.
! Otherwise, the calling hydrological module must do this itself.
!
IF ( control%ok_stomate ) THEN
! total autotrophic respiration
resp_auto_tot(:) = 0.0
DO j = 1, npft
resp_auto_tot(:) = resp_auto_tot(:) &
& +resp_maint_radia(:,j) &
& +resp_growth(:,j)*dtradia/one_day
resp_maint_x(:,j+1) = resp_maint_radia(:,j)
resp_growth_x(:,j+1)= resp_growth(:,j)*dtradia/one_day
ENDDO
resp_hetero_x=resp_hetero_radia(:,inat)+resp_hetero_radia(:,iagri)
resp_maint_x(:,1) = 0.0
! total photosynthesis (in gC/m**2/day)
gpp_tot(:) = 0.0
DO jv=1,nvm
gpp_tot(:) = gpp_tot(:)+gpp_x(:,jv)
ENDDO
! CO2 flux in gC/m**2/sec (positive towards the atmosphere) is sum of:
! 1/ heterotrophic respiration from natural and agricultural ground
! 2/ maintenance respiration from the plants
! 3/ growth respiration from the plants
! 4/ co2 created by fire
! 5/ - co2 taken up in the DGVM to establish saplings.
! 6/ - co2 taken up by photosyntyhesis
co2_flux(:) = resp_hetero_radia(:,inat) &
& +resp_hetero_radia(:,iagri) &
& +(co2_fire(:)-co2_to_bm_dgvm(:))*dtradia/one_day &
& +resp_auto_tot(:)-gpp_tot(:)
ENDIF
!
! 8 message
!
IF ( (bavard >= 2).AND.EndOfYear.AND.do_slow) THEN
WRITE(numout,*) 'stomate: EndOfYear'
ENDIF
IF (bavard >= 4) WRITE(numout,*) 'Leaving stomate_main'
IF (long_print) WRITE (numout,*) ' stomate_main done '
!--------------------------
END SUBROUTINE stomate_main
!
!=
!
SUBROUTINE stomate_init &
& (kjpij, kjpindex, index, ldforcing_write, lalo, &
& rest_id_stom, hist_id_stom)
!---------------------------------------------------------------------
! interface description
! input scalar
! Total size of the un-compressed grid
INTEGER(i_std),INTENT(in) :: kjpij
! Domain size
INTEGER(i_std),INTENT(in) :: kjpindex
! Logical for _forcing_ file to write
LOGICAL,INTENT(in) :: ldforcing_write
! Geogr. coordinates (latitude,longitude) (degrees)
REAL(r_std),DIMENSION(kjpindex,2),INTENT(in) :: lalo
! STOMATE's _Restart_ file file identifier
INTEGER(i_std),INTENT(in) :: rest_id_stom
! STOMATE's _history_ file file identifier
INTEGER(i_std),INTENT(in) :: hist_id_stom
! input fields
! Indeces of the points on the map
INTEGER(i_std),DIMENSION(kjpindex),INTENT(in) :: index
! local declaration
REAL(r_std) :: tmp_day(1)
! soil depth taken for canopy
REAL(r_std) :: zcanop
! soil depths at diagnostic levels
REAL(r_std),DIMENSION(nbdl) :: zsoil
! Index
INTEGER(i_std) :: l
! allocation error
LOGICAL :: l_error
! Global world fraction of vegetation type map
REAL(r_std),DIMENSION(360,180,nvm) :: veget_ori_on_disk
INTEGER(i_std) :: ier
! indices
INTEGER(i_std) :: ji,j,ipd
!---------------------------------------------------------------------
!
! 1 online diagnostics
! (by default, "bavard" is set to 1 in stomate_constants)
!
!Config Key = BAVARD
!Config Desc = level of online diagnostics in STOMATE (0-4)
!Config Def = 1
!Config Help = With this variable, you can determine
!Config how much online information STOMATE
!Config gives during the run. 0 means
!Config virtually no info.
!
bavard = 1
CALL getin_p('BAVARD', bavard)
IF ( kjpindex > 0 ) THEN
!
!Config Key = STOMATE_DIAGPT
!Config Desc = Index of grid point for online diagnostics
!Config Def = 1
!Config Help = This is the index of the grid point which
! will be used for online diagnostics.
ipd = 1
CALL getin_p('STOMATE_DIAGPT',ipd)
ipd = MIN( ipd, kjpindex )
WRITE(numout,*) 'Stomate: '
WRITE(numout,*) ' Index of grid point for online diagnostics: ',ipd
WRITE(numout,*) ' Lon, lat:',lalo(ipd,2),lalo(ipd,1)
WRITE(numout,*) ' Index of this point on GCM grid: ',index(ipd)
!
ENDIF
!
! 2 check consistency of flags
!
IF ( ( .NOT. control%ok_stomate ) .AND. control%ok_dgvm ) THEN
WRITE(numout,*) 'Cannot do dynamical vegetation without STOMATE.'
WRITE(numout,*) 'We stop.'
STOP
ENDIF
IF ((.NOT.control%ok_co2).AND.control%ok_stomate) THEN
WRITE(numout,*) 'Cannot call STOMATE without GPP.'
WRITE(numout,*) 'We stop.'
STOP
ENDIF
IF ( ( .NOT. control%ok_co2 ) .AND. ldforcing_write ) THEN
WRITE(numout,*) &
& 'Cannot write forcing file if photosynthesis is not activated'
WRITE(numout,*) 'We stop.'
STOP
ENDIF
!
! 3 messages
!
WRITE(numout,*) 'stomate: first call'
WRITE(numout,*) ' Photosynthesis: ', control%ok_co2
WRITE(numout,*) ' STOMATE: ', control%ok_stomate
WRITE(numout,*) ' LPJ: ', control%ok_dgvm
!
! 4 allocation of STOMATE's variables
!
l_error = .FALSE.
ALLOCATE(veget_max(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(space_nat(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(ind(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(adapted(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(regenerate(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(humrel_daily(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(litterhum_daily(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(t2m_daily(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(t2m_min_daily(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(tsurf_daily(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(tsoil_daily(kjpindex,nbdl),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(soilhum_daily(kjpindex,nbdl),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(precip_daily(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(gpp_daily(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(npp_daily(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(turnover_daily(kjpindex,npft,nparts),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(humrel_month(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(humrel_week(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(t2m_longterm(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(tlong_ref(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(t2m_month(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(t2m_week(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(tsoil_month(kjpindex,nbdl),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(soilhum_month(kjpindex,nbdl),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(fireindex(kjpindex,nvegtypes),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(firelitter(kjpindex,nvegtypes),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(maxhumrel_lastyear(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(maxhumrel_thisyear(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(minhumrel_lastyear(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(minhumrel_thisyear(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(maxgppweek_lastyear(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(maxgppweek_thisyear(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(gdd0_lastyear(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(gdd0_thisyear(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(precip_lastyear(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(precip_thisyear(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(gdd_m5_dormance(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(gdd_midwinter(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(ncd_dormance(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(ngd_minus5(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(PFTpresent(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(npp_longterm(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(lm_lastyearmax(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(lm_thisyearmax(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(maxfpc_lastyear(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(maxfpc_thisyear(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(turnover_longterm(kjpindex,npft,nparts),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(gpp_week(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(biomass(kjpindex,npft,nparts),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(senescence(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(when_growthinit(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(age(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(resp_hetero(kjpindex,nvegtypes),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(resp_hetero_radia(kjpindex,nvegtypes),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(resp_maint(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(resp_growth(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(co2_fire(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(co2_to_bm_dgvm(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(veget_lastlight(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(everywhere(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(need_adjacent(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(leaf_age(kjpindex,npft,nleafages),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(leaf_frac(kjpindex,npft,nleafages),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(RIP_time(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(time_lowgpp(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(time_hum_min(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(hum_min_dormance(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(fvm(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(fv(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(litterpart(kjpindex,npft,nlitt),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(litter(kjpindex,nlitt,nvegtypes,nlevs),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(dead_leaves(kjpindex,npft,nlitt),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(carbon(kjpindex,ncarb,nvegtypes),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(black_carbon(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(lignin_struc(kjpindex,nvegtypes,nlevs),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(turnover_time(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(co2_flux_daily(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(co2_flux_monthly(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(bm_to_litter(kjpindex,npft,nparts),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(herbivores(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(hori_index(kjpindex),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(horipft_index(kjpindex*npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(resp_maint_part_radia(kjpindex,npft,nparts),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(resp_maint_radia(kjpindex,npft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(resp_maint_part(kjpindex,npft,nparts),stat=ier)
l_error = l_error .OR. (ier /= 0)
resp_maint_part(:,:,:)=0.0
! allocation for deforestation variables
ALLOCATE (veget_max_new(kjpindex,npft), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (space_nat_new(kjpindex), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (horip10_index(kjpindex*10), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (horip100_index(kjpindex*100), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (horip11_index(kjpindex*11), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (horip101_index(kjpindex*101), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (prod10(kjpindex,0:10), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (prod100(kjpindex,0:100), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (flux10(kjpindex,10), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (flux100(kjpindex,100), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (convflux(kjpindex), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (cflux_prod10(kjpindex), stat=ier)
l_error = l_error .OR. (ier.NE.0)
ALLOCATE (cflux_prod100(kjpindex), stat=ier)
l_error = l_error .OR. (ier.NE.0)
!
IF (l_error) THEN
STOP 'stomate_init: error in memory allocation'
ENDIF
!
! 5 file definitions: stored in common variables
!
hist_id_stomate = hist_id_stom
rest_id_stomate = rest_id_stom
hori_index(:) = index(:)
! Get the indexing table for the vegetation fields.
! In STOMATE we work on
! reduced grids but to store in the full 3D filed vegetation variable
! we need another index table : indexpft
DO j = 1, npft
DO ji = 1, kjpindex
horipft_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
ENDDO
ENDDO
! indexing tables added for deforestation fields
DO j = 1, 10
DO ji = 1, kjpindex
horip10_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
ENDDO
ENDDO
DO j = 1, 100
DO ji = 1, kjpindex
horip100_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
ENDDO
ENDDO
DO j = 1, 11
DO ji = 1, kjpindex
horip11_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
ENDDO
ENDDO
DO j = 1, 101
DO ji = 1, kjpindex
horip101_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
ENDDO
ENDDO
!
! 6 some flags
!
!
!Config Key = HERBIVORES
!Config Desc = herbivores allowed?
!Config Def = n
!Config Help = With this variable, you can determine
!Config if herbivores are activated
!
ok_herbivores = .FALSE.
CALL getin_p('HERBIVORES', ok_herbivores)
!
WRITE(numout,*) 'herbivores activated: ',ok_herbivores
!
!Config Key = TREAT_EXPANSION
!Config Desc = treat expansion of PFTs across a grid cell?
!Config Def = n
!Config Help = With this variable, you can determine
!Config whether we treat expansion of PFTs across a
!Config grid cell.
!
treat_expansion = .FALSE.
CALL getin_p('TREAT_EXPANSION', treat_expansion)
!
WRITE(numout,*) &
& 'expansion across a grid cell is treated: ',treat_expansion
!
bm_to_litter=zero
resp_hetero=zero
!--------------------------
END SUBROUTINE stomate_init
!
!=
!
SUBROUTINE stomate_clear
!---------------------------------------------------------------------
! 1. Deallocate all dynamics variables
IF (ALLOCATED(veget_max)) DEALLOCATE(veget_max)
IF (ALLOCATED(space_nat)) DEALLOCATE(space_nat)
IF (ALLOCATED(ind)) DEALLOCATE(ind)
IF (ALLOCATED(adapted)) DEALLOCATE(adapted)
IF (ALLOCATED(regenerate)) DEALLOCATE(regenerate)
IF (ALLOCATED(humrel_daily)) DEALLOCATE(humrel_daily)
IF (ALLOCATED(litterhum_daily)) DEALLOCATE(litterhum_daily)
IF (ALLOCATED(t2m_daily)) DEALLOCATE(t2m_daily)
IF (ALLOCATED(t2m_min_daily)) DEALLOCATE(t2m_min_daily)
IF (ALLOCATED(tsurf_daily)) DEALLOCATE(tsurf_daily)
IF (ALLOCATED(tsoil_daily)) DEALLOCATE(tsoil_daily)
IF (ALLOCATED(soilhum_daily)) DEALLOCATE(soilhum_daily)
IF (ALLOCATED(precip_daily)) DEALLOCATE(precip_daily)
IF (ALLOCATED(gpp_daily)) DEALLOCATE(gpp_daily)
IF (ALLOCATED(npp_daily)) DEALLOCATE(npp_daily)
IF (ALLOCATED(turnover_daily)) DEALLOCATE(turnover_daily)
IF (ALLOCATED(humrel_month)) DEALLOCATE(humrel_month)
IF (ALLOCATED(humrel_week)) DEALLOCATE(humrel_week)
IF (ALLOCATED(t2m_longterm)) DEALLOCATE(t2m_longterm)
IF (ALLOCATED(tlong_ref)) DEALLOCATE(tlong_ref)
IF (ALLOCATED(t2m_month)) DEALLOCATE(t2m_month)
IF (ALLOCATED(t2m_week)) DEALLOCATE(t2m_week)
IF (ALLOCATED(tsoil_month)) DEALLOCATE(tsoil_month)
IF (ALLOCATED(soilhum_month)) DEALLOCATE(soilhum_month)
IF (ALLOCATED(fireindex)) DEALLOCATE(fireindex)
IF (ALLOCATED(firelitter)) DEALLOCATE(firelitter)
IF (ALLOCATED(maxhumrel_lastyear)) DEALLOCATE(maxhumrel_lastyear)
IF (ALLOCATED(maxhumrel_thisyear)) DEALLOCATE(maxhumrel_thisyear)
IF (ALLOCATED(minhumrel_lastyear)) DEALLOCATE(minhumrel_lastyear)
IF (ALLOCATED(minhumrel_thisyear)) DEALLOCATE(minhumrel_thisyear)
IF (ALLOCATED(maxgppweek_lastyear)) DEALLOCATE(maxgppweek_lastyear)
IF (ALLOCATED(maxgppweek_thisyear)) DEALLOCATE(maxgppweek_thisyear)
IF (ALLOCATED(gdd0_lastyear)) DEALLOCATE(gdd0_lastyear)
IF (ALLOCATED(gdd0_thisyear)) DEALLOCATE(gdd0_thisyear)
IF (ALLOCATED(precip_lastyear)) DEALLOCATE(precip_lastyear)
IF (ALLOCATED(precip_thisyear)) DEALLOCATE(precip_thisyear)
IF (ALLOCATED(gdd_m5_dormance)) DEALLOCATE(gdd_m5_dormance)
IF (ALLOCATED(gdd_midwinter)) DEALLOCATE(gdd_midwinter)
IF (ALLOCATED(ncd_dormance)) DEALLOCATE(ncd_dormance)
IF (ALLOCATED(ngd_minus5)) DEALLOCATE(ngd_minus5)
IF (ALLOCATED(PFTpresent)) DEALLOCATE(PFTpresent)
IF (ALLOCATED(npp_longterm)) DEALLOCATE(npp_longterm)
IF (ALLOCATED(lm_lastyearmax)) DEALLOCATE(lm_lastyearmax)
IF (ALLOCATED(lm_thisyearmax)) DEALLOCATE(lm_thisyearmax)
IF (ALLOCATED(maxfpc_lastyear)) DEALLOCATE(maxfpc_lastyear)
IF (ALLOCATED(maxfpc_thisyear)) DEALLOCATE(maxfpc_thisyear)
IF (ALLOCATED(turnover_longterm)) DEALLOCATE(turnover_longterm)
IF (ALLOCATED(gpp_week)) DEALLOCATE(gpp_week)
IF (ALLOCATED(biomass)) DEALLOCATE(biomass)
IF (ALLOCATED(senescence)) DEALLOCATE(senescence)
IF (ALLOCATED(when_growthinit)) DEALLOCATE(when_growthinit)
IF (ALLOCATED(age)) DEALLOCATE(age)
IF (ALLOCATED(resp_hetero)) DEALLOCATE(resp_hetero)
IF (ALLOCATED(resp_hetero_radia)) DEALLOCATE(resp_hetero_radia)
IF (ALLOCATED(resp_maint)) DEALLOCATE(resp_maint)
IF (ALLOCATED(resp_growth)) DEALLOCATE(resp_growth)
IF (ALLOCATED(co2_fire)) DEALLOCATE(co2_fire)
IF (ALLOCATED(co2_to_bm_dgvm)) DEALLOCATE(co2_to_bm_dgvm)
IF (ALLOCATED(veget_lastlight)) DEALLOCATE(veget_lastlight)
IF (ALLOCATED(everywhere)) DEALLOCATE(everywhere)
IF (ALLOCATED(need_adjacent)) DEALLOCATE(need_adjacent)
IF (ALLOCATED(leaf_age)) DEALLOCATE(leaf_age)
IF (ALLOCATED(leaf_frac)) DEALLOCATE(leaf_frac)
IF (ALLOCATED(RIP_time)) DEALLOCATE(RIP_time)
IF (ALLOCATED(time_lowgpp)) DEALLOCATE(time_lowgpp)
IF (ALLOCATED(time_hum_min)) DEALLOCATE(time_hum_min)
IF (ALLOCATED(hum_min_dormance)) DEALLOCATE(hum_min_dormance)
IF (ALLOCATED(fvm)) DEALLOCATE(fvm)
IF (ALLOCATED(fv)) DEALLOCATE(fv)
IF (ALLOCATED(litterpart)) DEALLOCATE(litterpart)
IF (ALLOCATED(litter)) DEALLOCATE(litter)
IF (ALLOCATED(dead_leaves)) DEALLOCATE(dead_leaves)
IF (ALLOCATED(carbon)) DEALLOCATE(carbon)
IF (ALLOCATED(black_carbon)) DEALLOCATE(black_carbon)
IF (ALLOCATED(lignin_struc)) DEALLOCATE(lignin_struc)
IF (ALLOCATED(turnover_time)) DEALLOCATE(turnover_time)
IF (ALLOCATED(co2_flux_daily)) DEALLOCATE(co2_flux_daily)
IF (ALLOCATED(co2_flux_monthly)) DEALLOCATE(co2_flux_monthly)
IF (ALLOCATED(bm_to_litter)) DEALLOCATE(bm_to_litter)
IF (ALLOCATED(herbivores)) DEALLOCATE(herbivores)
IF (ALLOCATED(resp_maint_part_radia)) DEALLOCATE(resp_maint_part_radia)
IF (ALLOCATED(resp_maint_radia)) DEALLOCATE(resp_maint_radia)
IF (ALLOCATED(resp_maint_part)) DEALLOCATE(resp_maint_part)
IF (ALLOCATED(hori_index)) DEALLOCATE(hori_index)
IF (ALLOCATED(horipft_index)) DEALLOCATE(horipft_index)
IF (ALLOCATED(clay_fm)) DEALLOCATE(clay_fm)
IF (ALLOCATED(humrel_daily_x_fm)) DEALLOCATE(humrel_daily_x_fm)
IF (ALLOCATED(litterhum_daily_fm)) DEALLOCATE(litterhum_daily_fm)
IF (ALLOCATED(t2m_daily_fm)) DEALLOCATE(t2m_daily_fm)
IF (ALLOCATED(t2m_min_daily_fm)) DEALLOCATE(t2m_min_daily_fm)
IF (ALLOCATED(tsurf_daily_fm)) DEALLOCATE(tsurf_daily_fm)
IF (ALLOCATED(tsoil_daily_fm)) DEALLOCATE(tsoil_daily_fm)
IF (ALLOCATED(soilhum_daily_fm)) DEALLOCATE(soilhum_daily_fm)
IF (ALLOCATED(precip_fm)) DEALLOCATE(precip_fm)
IF (ALLOCATED(gpp_daily_x_fm)) DEALLOCATE(gpp_daily_x_fm)
IF (ALLOCATED(resp_maint_part_x_fm)) DEALLOCATE(resp_maint_part_x_fm)
IF (ALLOCATED(veget_x_fm)) DEALLOCATE(veget_x_fm)
IF (ALLOCATED(veget_max_x_fm)) DEALLOCATE(veget_max_x_fm)
IF (ALLOCATED(lai_x_fm)) DEALLOCATE(lai_x_fm)
IF (is_root_prc) THEN
IF (ALLOCATED(clay_fm_g)) DEALLOCATE(clay_fm_g)
IF (ALLOCATED(humrel_daily_x_fm_g)) DEALLOCATE(humrel_daily_x_fm_g)
IF (ALLOCATED(litterhum_daily_fm_g)) DEALLOCATE(litterhum_daily_fm_g)
IF (ALLOCATED(t2m_daily_fm_g)) DEALLOCATE(t2m_daily_fm_g)
IF (ALLOCATED(t2m_min_daily_fm_g)) DEALLOCATE(t2m_min_daily_fm_g)
IF (ALLOCATED(tsurf_daily_fm_g)) DEALLOCATE(tsurf_daily_fm_g)
IF (ALLOCATED(tsoil_daily_fm_g)) DEALLOCATE(tsoil_daily_fm_g)
IF (ALLOCATED(soilhum_daily_fm_g)) DEALLOCATE(soilhum_daily_fm_g)
IF (ALLOCATED(precip_fm_g)) DEALLOCATE(precip_fm_g)
IF (ALLOCATED(gpp_daily_x_fm_g)) DEALLOCATE(gpp_daily_x_fm_g)
IF (ALLOCATED(resp_maint_part_x_fm_g)) DEALLOCATE(resp_maint_part_x_fm_g)
IF (ALLOCATED(veget_x_fm_g)) DEALLOCATE(veget_x_fm_g)
IF (ALLOCATED(veget_max_x_fm_g)) DEALLOCATE(veget_max_x_fm_g)
IF (ALLOCATED(lai_x_fm_g)) DEALLOCATE(lai_x_fm_g)
ENDIF
IF (ALLOCATED(isf)) DEALLOCATE(isf)
IF (ALLOCATED(nf_written)) DEALLOCATE(nf_written)
IF (ALLOCATED(nf_cumul)) DEALLOCATE(nf_cumul)
IF (ALLOCATED(times)) DEALLOCATE(times)
IF (ALLOCATED(nforce)) DEALLOCATE(nforce)
IF (ALLOCATED(control_moist)) DEALLOCATE(control_moist)
IF (ALLOCATED(control_temp)) DEALLOCATE(control_temp)
IF (ALLOCATED(soilcarbon_input)) DEALLOCATE(soilcarbon_input)
! for deforestation variables
IF ( ALLOCATED (veget_max_new)) DEALLOCATE (veget_max_new)
IF ( ALLOCATED (space_nat_new)) DEALLOCATE (space_nat_new)
IF ( ALLOCATED (horip10_index)) DEALLOCATE (horip10_index)
IF ( ALLOCATED (horip100_index)) DEALLOCATE (horip100_index)
IF ( ALLOCATED (horip11_index)) DEALLOCATE (horip11_index)
IF ( ALLOCATED (horip101_index)) DEALLOCATE (horip101_index)
IF ( ALLOCATED (prod10)) DEALLOCATE (prod10)
IF ( ALLOCATED (prod100)) DEALLOCATE (prod100)
IF ( ALLOCATED (flux10)) DEALLOCATE (flux10)
IF ( ALLOCATED (flux100)) DEALLOCATE (flux100)
IF ( ALLOCATED (convflux)) DEALLOCATE (convflux)
IF ( ALLOCATED (cflux_prod10)) DEALLOCATE (cflux_prod10)
IF ( ALLOCATED (cflux_prod100)) DEALLOCATE (cflux_prod100)
! 2. reset l_first
l_first_stomate=.TRUE.
! 3. call to clear functions
CALL get_reftemp_clear
CALL season_clear
CALL stomatelpj_clear
CALL littercalc_clear
CALL vmax_clear
!---------------------------
END SUBROUTINE stomate_clear
!
!=
!
SUBROUTINE stomate_var_init &
& (kjpindex, veget, veget_max, leaf_age, leaf_frac, &
& tlong_ref, t2m_month, dead_leaves, &
& veget_x, lai_x, qsintmax, deadleaf_cover, assim_param_x, &
& prod10, prod100, flux10, flux100, &
& convflux,cflux_prod10, cflux_prod100)
! deforestation variables added as arguments
!---------------------------------------------------------------------
! this subroutine outputs values of assim_param etc.
! only if ok_stomate = .TRUE.
! otherwise,the calling procedure must do it itself.
!
! interface description
! input scalar
! Domain size
INTEGER(i_std),INTENT(in) :: kjpindex
! input fields
! fractional coverage: actually covered space
REAL(r_std),DIMENSION(kjpindex,npft),INTENT(in) :: veget
! fractional coverage: maximum covered space
REAL(r_std),DIMENSION(kjpindex,npft),INTENT(in) :: veget_max
! "long term" 2 meter reference temperatures (K)
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: tlong_ref
! "monthly" 2 meter temperatures (K)
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: t2m_month
! dead leaves on ground, per PFT, metabolic and structural,
! in gC/(m**2 of nat/agri ground)
REAL(r_std),DIMENSION(kjpindex,npft,nlitt),INTENT(in) :: dead_leaves
! Fraction of vegetation type
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in) :: veget_x
! Surface foliere
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in) :: lai_x
! modified fields (actually NOT modified)
! leaf age (d)
REAL(r_std),DIMENSION(kjpindex,npft,nleafages),INTENT(inout) :: &
& leaf_age
! fraction of leaves in leaf age class
REAL(r_std),DIMENSION(kjpindex,npft,nleafages),INTENT(inout) :: &
& leaf_frac
! output scalar
! output fields
! Maximum water on vegetation for interception
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out) :: qsintmax
! fraction of soil covered by dead leaves
REAL(r_std),DIMENSION(kjpindex), INTENT (out) :: deadleaf_cover
! min+max+opt temps & vmax for photosynthesis
REAL(r_std),DIMENSION(kjpindex,nvm,npco2),INTENT(out) :: assim_param_x
! deforestation variables
! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
! (10 or 100 + 1 : input from year of deforestation)
REAL(r_std),DIMENSION(kjpindex,0:10), INTENT (out) :: prod10
REAL(r_std),DIMENSION(kjpindex,0:100), INTENT (out) :: prod100
! annual release from the 10/100 year-turnover pool compartments
REAL(r_std),DIMENSION(kjpindex,10), INTENT (out) :: flux10
REAL(r_std),DIMENSION(kjpindex,100), INTENT (out) :: flux100
! release during first year following deforestation
REAL(r_std),DIMENSION(kjpindex), INTENT (out) :: convflux
! total annual release from the 10/100 year-turnover pool
REAL(r_std),DIMENSION(kjpindex), INTENT (out) :: cflux_prod10, cflux_prod100
!-
! local declaration
!-
! dummy time step, must be zero
REAL(r_std),PARAMETER :: dt_0 = 0.
REAL(r_std),DIMENSION(kjpindex,nvm) :: vcmax
REAL(r_std),DIMENSION(kjpindex,nvm) :: vjmax
! Min temperature for photosynthesis (deg C)
REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_min
! Opt temperature for photosynthesis (deg C)
REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_opt
! Max temperature for photosynthesis (deg C)
REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_max
! Fraction of space that is natural
REAL(r_std),DIMENSION(kjpindex) :: space_nat
! Index
INTEGER(i_std) :: j
!---------------------------------------------------------------------
! initialisation of deforestation variables
prod10(:,:) = 0.
prod100(:,:) = 0.
flux10(:,:) = 0.
flux100(:,:) = 0.
convflux(:) = 0.
cflux_prod10(:) = 0.
cflux_prod100(:) = 0.
IF (control%ok_stomate) THEN
!
! 1 photosynthesis parameters
!
!
! 1.1 vcmax
! only if STOMATE is activated
!
CALL vmax (kjpindex, dt_0, leaf_age, leaf_frac, vcmax, vjmax)
!
! 1.2 assimilation temperatures
!
CALL assim_temp(kjpindex, tlong_ref, t2m_month, &
t_photo_min, t_photo_opt, t_photo_max)
!
! 1.3 transform into nvm vegetation types
!
CALL stomate_var_xout &
& (kjpindex,vcmax,veget,zero,assim_param_x(:,:,ivcmax))
CALL stomate_var_xout &
& (kjpindex,vjmax,veget,zero,assim_param_x(:,:,ivjmax))
CALL stomate_var_xout &
& (kjpindex,t_photo_min,veget,zero,assim_param_x(:,:,itmin))
CALL stomate_var_xout &
& (kjpindex,t_photo_opt,veget,zero,assim_param_x(:,:,itopt))
CALL stomate_var_xout &
& (kjpindex,t_photo_max,veget,zero,assim_param_x(:,:,itmax))
!
! 2 dead leaf cover
!
! first recalculate fraction of natural space
space_nat(:) = 1.0
DO j = 1, npft
IF (.NOT.natural(j)) THEN
space_nat(:) = space_nat(:)-veget_max(:,j)
ENDIF
ENDDO
CALL deadleaf (kjpindex, space_nat, dead_leaves, deadleaf_cover)
!
! 3 qsintmax
!
qsintmax(:,:) = qsintcst*veget_x(:,:)*lai_x(:,:)
ENDIF ! ok_stomate = .TRUE.
!--------------------------------
END SUBROUTINE stomate_var_init
!
!=
!
SUBROUTINE stomate_accu &
& (npts, n_dim2, dt_tot, dt, ldmean, field_in, field_out)
!---------------------------------------------------------------------
!
! 0 declarations
!
! 0.1 input
!
! Domain size
INTEGER(i_std),INTENT(in) :: npts
! 2nd dimension (1 or npft)
INTEGER(i_std),INTENT(in) :: n_dim2
! Time step of STOMATE (days)
REAL(r_std),INTENT(in) :: dt_tot
! Time step in days
REAL(r_std),INTENT(in) :: dt
! Calculate mean ?
LOGICAL,INTENT(in) :: ldmean
! Daily field
REAL(r_std),DIMENSION(npts,n_dim2),INTENT(in) :: field_in
!
! 0.2 modified field
!
! Annual field
REAL(r_std),DIMENSION(npts,n_dim2),INTENT(inout) :: field_out
!---------------------------------------------------------------------
!
! 1 accumulation
!
field_out(:,:) = field_out(:,:)+field_in(:,:)*dt
!
! 2 mean fields
!
IF (ldmean) THEN
field_out(:,:) = field_out(:,:)/dt_tot
ENDIF
!---------------------------------------------------------------------
END SUBROUTINE stomate_accu
!
!=
!
SUBROUTINE stomate_vegconvert &
& (kjpindex,which_way,fraction_nobio, &
& veget_max_x,veget_x,veget_max,veget,fvm,fv)
!---------------------------------------------------------------------
!
! 0 declarations
!
!
! 0.1 input
!
! 0.1.1 input scalar
!
! Domain size
INTEGER(i_std),INTENT(in) :: kjpindex
! veget -> veget_x ('out') or veget_x -> veget ('in') ?
CHARACTER(LEN=*),INTENT(in) :: which_way
! Fraction of land covered by lakes, land ice, cities, ...
REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: fraction_nobio
!
! 0.2 modified
!
! Max vegetation fraction of hydrological module
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: veget_max_x
! Vegetation fraction of hydrological module
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: veget_x
! Max vegetation fraction of STOMATE
REAL(r_std),DIMENSION(kjpindex,npft),INTENT(inout) :: veget_max
! Vegetation fraction of STOMATE
REAL(r_std),DIMENSION(kjpindex,npft),INTENT(inout) :: veget
! factor that converts veget_max_x into veget_max
REAL(r_std),DIMENSION(kjpindex,npft),INTENT(inout) :: fvm
! factor that converts veget_x into veget
REAL(r_std),DIMENSION(kjpindex,npft),INTENT(inout) :: fv
!
! 0.3 local
!
INTEGER(i_std) :: j,jv
!---------------------------------------------------------------------
IF (which_way == 'in') THEN
!
! 1 Convert veget_x into veget
!
DO j = 1, npft
WHERE ((1.-fraction_nobio(:)) > 0.0)
veget(:,j) = veget_x(:,ipft_sechiba(j)) &
& *fv(:,j)/(1.-fraction_nobio(:))
veget_max(:,j) = veget_max_x(:,ipft_sechiba(j)) &
& *fvm(:,j)/(1.-fraction_nobio(:))
ELSEWHERE
veget(:,j) = 0.
veget_max(:,j) = 0.
ENDWHERE
ENDDO
ELSEIF (which_way == 'out') THEN
!
! 2 Convert veget into veget_x
! and calculate fv and fvm for next time step
!
! 2.1 vegetation
!
veget_x(:,:) = 0.0
veget_max_x(:,:) = 0.0
DO j = 1, npft
veget_x(:,ipft_sechiba(j)) = &
& veget_x(:,ipft_sechiba(j)) &
& +veget(:,j)*(1.-fraction_nobio(:))
veget_max_x(:,ipft_sechiba(j)) = &
& veget_max_x(:,ipft_sechiba(j)) &
& +veget_max(:,j)*(1.-fraction_nobio(:))
ENDDO
!
! 2.2 bare soil
! for bare soil, veget_max is actually the potential minimum, as
! it is calculated using the potential maximum vegetation cover.
! veget_max has no real physical meaning anyway.
!
veget_max_x(:,ibare_sechiba) = 1.-fraction_nobio(:)
veget_x(:,ibare_sechiba) = 1.-fraction_nobio(:)
DO jv = 1, nvm
IF (jv /= ibare_sechiba) THEN
veget_max_x(:,ibare_sechiba) = veget_max_x(:,ibare_sechiba) &
& -veget_max_x(:,jv)
veget_x(:,ibare_sechiba) = veget_x(:,ibare_sechiba) &
& -veget_x(:,jv)
ENDIF
ENDDO
! potential minimum bare soil cover cannot be less than 0
veget_max_x(:,ibare_sechiba) = &
& MAX(veget_max_x(:,ibare_sechiba),0._r_std)
!
! 2.3 calculate fv and fvm
!
DO j=1,npft
WHERE (veget_max_x(:,ipft_sechiba(j)) > 0.)
fvm(:,j) = veget_max(:,j)/veget_max_x(:,ipft_sechiba(j)) &
& *(1.-fraction_nobio(:))
ELSEWHERE
fvm(:,j) = 0.0
ENDWHERE
WHERE (veget_x(:,ipft_sechiba(j)) > 0.)
fv(:,j) = veget(:,j)/veget_x(:,ipft_sechiba(j)) &
& *(1.-fraction_nobio(:))
ELSEWHERE
fv(:,j) = 0.0
ENDWHERE
ENDDO
ELSE
WRITE(numout,*) 'stomate_vegconvert: which_way = ', which_way
STOP 'Cannot go this way.'
ENDIF
!--------------------------------
END SUBROUTINE stomate_vegconvert
!
!=
!
SUBROUTINE stomate_var_xout (kjpindex,var,vfrac,bare_val,var_x)
!---------------------------------------------------------------------
! this subroutine outputs a variable (e.g. lai_x) on nvm vegetation
! types given an input (e.g. lai) on npft vegetation types.
! Ponderation is done using vfrac (= veget or veget_max)
!
! 0 declarations
!
! 0.1 input
!
! 0.1.1 input scalar
!
! Domain size
INTEGER(i_std),INTENT(in) :: kjpindex
! variable defined on npft
REAL(r_std),DIMENSION(kjpindex,npft),INTENT(in) :: var
! vegetation fraction
REAL(r_std),DIMENSION(kjpindex,npft),INTENT(in) :: vfrac
! value for bare ground
REAL(r_std),INTENT(in) :: bare_val
!
! 0.2 output
! variable defined on nvm
REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out) :: var_x
!
! 0.3 local
!
INTEGER(i_std) :: j
REAL(r_std),DIMENSION(kjpindex,nvm) :: vfracsum
!---------------------------------------------------------------------
!
! 1 Calculate ponderated value for vegetation types
!
var_x(:,:) = 0.0
vfracsum(:,:) = 0.0
DO j = 1, npft
var_x(:,ipft_sechiba(j)) = var_x(:,ipft_sechiba(j)) &
& +var(:,j)*vfrac(:,j)
vfracsum(:,ipft_sechiba(j)) = vfracsum(:,ipft_sechiba(j)) &
& +vfrac(:,j)
ENDDO
WHERE (vfracsum(:,:) > 0.0)
var_x(:,:) = var_x(:,:)/vfracsum(:,:)
ENDWHERE
!
! 2 impose a value for bare soil
!
var_x(:,ibare_sechiba) = bare_val
!------------------------------
END SUBROUTINE stomate_var_xout
!
!=
!
SUBROUTINE init_forcing (kjpindex,nsfm,nsft)
!---------------------------------------------------------------------
INTEGER(i_std),INTENT(in) :: kjpindex
INTEGER(i_std),INTENT(in) :: nsfm
INTEGER(i_std),INTENT(in) :: nsft
!
LOGICAL :: l_error
INTEGER(i_std) :: ier
!---------------------------------------------------------------------
l_error = .FALSE.
!
ALLOCATE(clay_fm(kjpindex,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(humrel_daily_x_fm(kjpindex,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(litterhum_daily_fm(kjpindex,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(t2m_daily_fm(kjpindex,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(t2m_min_daily_fm(kjpindex,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(tsurf_daily_fm(kjpindex,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(tsoil_daily_fm(kjpindex,nbdl,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(soilhum_daily_fm(kjpindex,nbdl,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(precip_fm(kjpindex,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(gpp_daily_x_fm(kjpindex,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(resp_maint_part_x_fm(kjpindex,nvm,nparts,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(veget_x_fm(kjpindex,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(veget_max_x_fm(kjpindex,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(lai_x_fm(kjpindex,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(isf(nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(nf_written(nsft),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(nf_cumul(nsft),stat=ier)
l_error = l_error .OR. (ier /= 0)
IF (is_root_prc) THEN
ALLOCATE(clay_fm_g(nbp_glo,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(humrel_daily_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(litterhum_daily_fm_g(nbp_glo,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(t2m_daily_fm_g(nbp_glo,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(t2m_min_daily_fm_g(nbp_glo,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(tsurf_daily_fm_g(nbp_glo,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(tsoil_daily_fm_g(nbp_glo,nbdl,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(soilhum_daily_fm_g(nbp_glo,nbdl,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(precip_fm_g(nbp_glo,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(gpp_daily_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(resp_maint_part_x_fm_g(nbp_glo,nvm,nparts,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(veget_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(veget_max_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ALLOCATE(lai_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
l_error = l_error .OR. (ier /= 0)
ENDIF
!
IF (l_error) THEN
WRITE(numout,*) 'Problem with memory allocation: forcing variables'
STOP 'init_forcing'
ENDIF
!
CALL forcing_zero
!--------------------------
END SUBROUTINE init_forcing
!
!=
!
SUBROUTINE forcing_zero
!---------------------------------------------------------------------
clay_fm(:,:) = 0.0
humrel_daily_x_fm(:,:,:) = 0.0
litterhum_daily_fm(:,:) = 0.0
t2m_daily_fm(:,:) = 0.0
t2m_min_daily_fm(:,:) = 0.0
tsurf_daily_fm(:,:) = 0.0
tsoil_daily_fm(:,:,:) = 0.0
soilhum_daily_fm(:,:,:) = 0.0
precip_fm(:,:) = 0.0
gpp_daily_x_fm(:,:,:) = 0.0
resp_maint_part_x_fm(:,:,:,:)=0.0
veget_x_fm(:,:,:) = 0.0
veget_max_x_fm(:,:,:) = 0.0
lai_x_fm(:,:,:) = 0.0
!--------------------------------
END SUBROUTINE forcing_zero
!
!=
!
SUBROUTINE forcing_write(forcing_id,ibeg,iend)
!---------------------------------------------------------------------
INTEGER(i_std),INTENT(in) :: forcing_id
INTEGER(i_std),INTENT(in) :: ibeg, iend
!
INTEGER(i_std) :: iisf, iblocks, nblocks
INTEGER(i_std) :: ier
INTEGER(i_std),DIMENSION(0:2) :: ifirst, ilast
INTEGER(i_std),PARAMETER :: ndm = 10
INTEGER(i_std),DIMENSION(ndm) :: start, count
INTEGER(i_std) :: ndim, vid
!---------------------------------------------------------------------
!
! determine blocks of forcing states that are contiguous in memory
!
nblocks = 0
ifirst(:) = 1
ilast(:) = 1
!
DO iisf = ibeg, iend
IF ( (nblocks /= 0) &
& .AND.(isf(iisf) == isf(ilast(nblocks))+1)) THEN
! element is contiguous with last element found
ilast(nblocks) = iisf
ELSE
! found first element of new block
nblocks = nblocks+1
IF (nblocks > 2) STOP 'Problem in forcing_write'
ifirst(nblocks) = iisf
ilast(nblocks) = iisf
ENDIF
ENDDO
!
DO iblocks = 1, nblocks
IF (ifirst(iblocks) /= ilast(iblocks)) THEN
CALL gather(clay_fm,clay_fm_g)
IF (is_root_prc) THEN
ndim = 2
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(clay_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'clay',vid)
ier = NF90_PUT_VAR (forcing_id,vid, &
& clay_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(humrel_daily_x_fm,humrel_daily_x_fm_g)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(humrel_daily_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'humrel',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& humrel_daily_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(litterhum_daily_fm,litterhum_daily_fm_g)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(litterhum_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'litterhum',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& litterhum_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(t2m_daily_fm,t2m_daily_fm_g)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(t2m_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'t2m',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& t2m_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(t2m_min_daily_fm,t2m_min_daily_fm_g)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(t2m_min_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'t2m_min',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& t2m_min_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(tsurf_daily_fm,tsurf_daily_fm_g)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(tsurf_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'tsurf',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& tsurf_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(tsoil_daily_fm,tsoil_daily_fm_g)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(tsoil_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'tsoil',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& tsoil_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(soilhum_daily_fm,soilhum_daily_fm_g)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(soilhum_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'soilhum',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& soilhum_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(precip_fm,precip_fm_g)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(precip_fm)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'precip',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& precip_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(gpp_daily_x_fm,gpp_daily_x_fm_g)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(gpp_daily_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'gpp',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& gpp_daily_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(resp_maint_part_x_fm,resp_maint_part_x_fm_g)
IF (is_root_prc) THEN
ndim = 4;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim)=SHAPE(resp_maint_part_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'resp_maint_part',vid)
ier = NF90_PUT_VAR (forcing_id,vid, &
& resp_maint_part_x_fm_g(:,:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(veget_x_fm,veget_x_fm_g)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(veget_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'veget',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& veget_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(veget_max_x_fm,veget_max_x_fm_g)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(veget_max_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'veget_max',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
& veget_max_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL gather(lai_x_fm,lai_x_fm_g)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(lai_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'lai',vid)
ier = NF90_PUT_VAR (forcing_id, vid, &
lai_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
ENDIF
ENDDO
nf_written(isf(:)) = .TRUE.
!---------------------------
END SUBROUTINE forcing_write
!
!=
!
SUBROUTINE forcing_read(forcing_id,nsfm)
!---------------------------------------------------------------------
INTEGER(i_std),INTENT(in) :: forcing_id
INTEGER(i_std),INTENT(in) :: nsfm
!
INTEGER(i_std) :: iisf, iblocks, nblocks
INTEGER(i_std) :: ier
INTEGER(i_std),DIMENSION(0:2) :: ifirst, ilast
INTEGER(i_std),PARAMETER :: ndm = 10
INTEGER(i_std),DIMENSION(ndm) :: start, count
INTEGER(i_std) :: ndim, vid
!---------------------------------------------------------------------
!
! set to zero if the corresponding forcing state
! has not yet been written into the file
!
DO iisf = 1, nsfm
IF (.NOT.nf_written(isf(iisf))) THEN
clay_fm(:,iisf) = 0.0
humrel_daily_x_fm(:,:,iisf) = 0.0
litterhum_daily_fm(:,iisf) = 0.0
t2m_daily_fm(:,iisf) = 0.0
t2m_min_daily_fm(:,iisf) = 0.0
tsurf_daily_fm(:,iisf) = 0.0
tsoil_daily_fm(:,:,iisf) = 0.0
soilhum_daily_fm(:,:,iisf) = 0.0
precip_fm(:,iisf) = 0.0
gpp_daily_x_fm(:,:,iisf) = 0.0
resp_maint_part_x_fm(:,:,:,iisf) = 0.0
veget_x_fm(:,:,iisf) = 0.0
veget_max_x_fm(:,:,iisf) = 0.0
lai_x_fm(:,:,iisf) = 0.0
ENDIF
ENDDO
!
! determine blocks of forcing states that are contiguous in memory
!
nblocks = 0
ifirst(:) = 1
ilast(:) = 1
!
DO iisf = 1, nsfm
IF (nf_written(isf(iisf))) THEN
IF ( (nblocks /= 0) &
& .AND.(isf(iisf) == isf(ilast(nblocks))+1)) THEN
! element is contiguous with last element found
ilast(nblocks) = iisf
ELSE
! found first element of new block
nblocks = nblocks+1
IF (nblocks > 2) STOP 'Problem in forcing_read'
!
ifirst(nblocks) = iisf
ilast(nblocks) = iisf
ENDIF
ENDIF
ENDDO
!
DO iblocks = 1, nblocks
IF (ifirst(iblocks) /= ilast(iblocks)) THEN
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(clay_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'clay',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& clay_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(clay_fm_g,clay_fm)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(humrel_daily_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'humrel',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& humrel_daily_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(humrel_daily_x_fm_g,humrel_daily_x_fm)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(litterhum_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'litterhum',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& litterhum_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(litterhum_daily_fm_g,litterhum_daily_fm)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(t2m_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'t2m',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& t2m_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(t2m_daily_fm_g,t2m_daily_fm)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(t2m_min_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'t2m_min',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& t2m_min_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(t2m_min_daily_fm_g,t2m_min_daily_fm)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(tsurf_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'tsurf',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& tsurf_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(tsurf_daily_fm_g,tsurf_daily_fm)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(tsoil_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'tsoil',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& tsoil_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(tsoil_daily_fm_g,tsoil_daily_fm)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(soilhum_daily_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'soilhum',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& soilhum_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(soilhum_daily_fm_g,soilhum_daily_fm)
IF (is_root_prc) THEN
ndim = 2;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(precip_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'precip',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& precip_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(precip_fm_g,precip_fm)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(gpp_daily_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'gpp',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& gpp_daily_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(gpp_daily_x_fm_g,gpp_daily_x_fm)
IF (is_root_prc) THEN
ndim = 4;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim)=SHAPE(resp_maint_part_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'resp_maint_part',vid)
ier = NF90_GET_VAR (forcing_id,vid, &
& resp_maint_part_x_fm_g(:,:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(resp_maint_part_x_fm_g,resp_maint_part_x_fm)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(veget_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'veget',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& veget_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(veget_x_fm_g,veget_x_fm)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(veget_max_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'veget_max',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& veget_max_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(veget_max_x_fm_g,veget_max_x_fm)
IF (is_root_prc) THEN
ndim = 3;
start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
count(1:ndim) = SHAPE(lai_x_fm_g)
count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
ier = NF90_INQ_VARID (forcing_id,'lai',vid)
ier = NF90_GET_VAR (forcing_id, vid, &
& lai_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
& start=start(1:ndim), count=count(1:ndim))
ENDIF
CALL scatter(lai_x_fm_g,lai_x_fm_g)
ENDIF
ENDDO
!--------------------------
END SUBROUTINE forcing_read
!
!=
!
SUBROUTINE setlai(npts,lai)
!---------------------------------------------------------------------
! routine to force the lai in STOMATE (for assimilation procedures)
! for the moment setlai only gives the lai from stomate,
! this routine must be written in the future
!
! 0 declarations
!
! 0.1 input
!
! Domain size
INTEGER(i_std),INTENT(in) :: npts
! 0.3 output
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: lai
! 0.4 local definitions
INTEGER(i_std) :: j
!---------------------------------------------------------------------
DO j=1,npft
WHERE (veget_max(:,j) > 0.0)
lai(:,j) = biomass(:,j,ileaf)/veget_max(:,j)*sla(j)
ELSEWHERE
lai(:,j) = 0.0
ENDWHERE
ENDDO
!--------------------
END SUBROUTINE setlai
!
!=
!
!! BEGINNVADD
!
!=====================================================================
! NV clowproc_soil permet de faire l'interface entre sechiba
! et stomate lorsque l'on appelle uniquement le calcul du carbon sol
!
SUBROUTINE stomate_soil &
& (npts, dt, clay_r,space_nat_r,&
& soilcarbon_input, control_temp, control_moist,resp_hetero_soil)
!---------------------------------------------------------------------
!
! 0 declarations
!
! 0.1 input
!
! Domain size
INTEGER(i_std),INTENT(in) :: npts
! time step in days
REAL(r_std),INTENT(in) :: dt
! quantity of carbon going into carbon pools from litter decomposition
! (gC/(m**2 of nat/agri ground)/day)
REAL(r_std),DIMENSION(npts),INTENT(in) :: clay_r
REAL(r_std),DIMENSION(npts),INTENT(in) :: space_nat_r
REAL(r_std),DIMENSION(npts,ncarb,nvegtypes),INTENT(in) :: &
& soilcarbon_input
! temperature control of heterotrophic respiration
REAL(r_std),DIMENSION(npts,nlevs),INTENT(in) :: control_temp
! moisture control of heterotrophic respiration
REAL(r_std),DIMENSION(npts,nlevs),INTENT(in) :: control_moist
!
! 0.3 output
!
! soil heterotrophic respiration
! (first in gC/day/m**2 of natural/agricultural ground,
! but output in gC/day/m**2 of total ground)
REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(out) :: resp_hetero_soil
!---------------------------------------------------------------------
write_carbonforce = .FALSE.
CALL soilcarbon (npts, dt, clay_r, space_nat_r, &
soilcarbon_input, control_temp, control_moist, &
carbon, resp_hetero_soil)
!--------------------------
END SUBROUTINE stomate_soil
!
!=
!
SUBROUTINE pondere_nat (npts,pondere)
!---------------------------------------------------------------------
INTEGER(i_std),INTENT(in) :: npts
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: pondere
!
INTEGER(i_std) :: n
!---------------------------------------------------------------------
DO n=1,npft
IF (natural(n)) THEN
pondere(:,n)=space_nat(:)
ELSE
pondere(:,n)=1.-space_nat(:)
ENDIF
ENDDO
!-------------------------
END SUBROUTINE pondere_nat
!
!=
!
SUBROUTINE pondere_nat_vegfrac (npts,pondere)
!---------------------------------------------------------------------
INTEGER(i_std),INTENT(in) :: npts
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: pondere
!
INTEGER(i_std) :: n
!---------------------------------------------------------------------
DO n=1,npft
IF (natural(n)) THEN
pondere(:,n)=space_nat(:)*veget_max(:,n)
ELSE
pondere(:,n)=(1.-space_nat(:))*veget_max(:,n)
ENDIF
ENDDO
!---------------------------------------------------------------------
END SUBROUTINE pondere_nat_vegfrac
!
!=
!
SUBROUTINE pondere_vegfrac (npts,pondere)
!---------------------------------------------------------------------
INTEGER(i_std),INTENT(in) :: npts
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: pondere
!
INTEGER(i_std) :: n
!---------------------------------------------------------------------
DO n=1,npft
pondere(:,n)=veget_max(:,n)
ENDDO
!-----------------------------
END SUBROUTINE pondere_vegfrac
!! ENDNVADD
!
!=
!
!-----------------
END MODULE stomate
ORCHIDEE/src_stomate/stomate_alloc.f90 0000754 0103600 0005670 00000045747 11164403473 017437 0 ustar acamlmd lmdjus ! allocation to the roots, stems, leaves, "fruits" and carbohydrate reserve.
! Reproduction: for the moment, this is simply a 10% "tax".
! This should depend on the limitations that the plant experiences. If the
! plant fares well, it will have fruits. However, this means that we should
! also "reward" the plants for having grown fruits by making the
! reproduction rate depend on the fruit growth of the past years. Otherwise,
! the fruit allocation would be a punishment for plants that are doing well.
! "calculates" root profiles (in fact, prescribes it for the moment).
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_alloc.f90,v 1.9 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_alloc
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC alloc,alloc_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE alloc_clear
firstcall = .TRUE.
END SUBROUTINE alloc_clear
SUBROUTINE alloc (npts, dt, &
lai, veget_max, senescence, when_growthinit, &
moiavail_week, tsoil_month, soilhum_month, &
biomass, leaf_age, leaf_frac, rprof, f_alloc)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step (days)
REAL(r_std), INTENT(in) :: dt
! Leaf area index
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
! "maximal" coverage fraction of a PFT ( = ind*cn_ind )
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: senescence
! how many days ago was the beginning of the growing season
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: when_growthinit
! "weekly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
! "monthly" soil temperature (K)
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil_month
! "monthly" soil humidity
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum_month
! 0.2 modified fields
! biomass (gC/m**2)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! leaf age (days)
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! 0.3 output
! root depth. This will, one day, be a prognostic variable. It will be calculated by
! STOMATE (save in restart file & give to hydrology module!). For the moment, it
! is prescribed.
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: rprof
! fraction that goes into plant part
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: f_alloc
! 0.4 local
! Do we try to reach a minimum reservoir even if we are severely stressed?
LOGICAL, PARAMETER :: ok_minres = .TRUE.
! time (d) to attain the initial foliage using the carbohydrate reserve
REAL(r_std), PARAMETER :: tau_leafinit = 30.
! maximum time (d) during which reserve is used (trees)
REAL(r_std), PARAMETER :: reserve_time_tree = 60.
! maximum time (d) during which reserve is used (grasses)
REAL(r_std), PARAMETER :: reserve_time_grass = 30.
! Standard root allocation
REAL(r_std), PARAMETER :: R0 = 0.3
! Standard sapwood allocation
REAL(r_std), PARAMETER :: S0 = 0.3
! Standard leaf allocation
REAL(r_std), PARAMETER :: L0 = 1. - R0 - S0
! Standard fruit allocation
REAL(r_std), PARAMETER :: f_fruit = 0.1
! fraction of sapwood allocation above ground (SHOULD BE CALCULATED !!!!)
REAL(r_std), PARAMETER :: alloc_sap_above_tree = 0.5
REAL(r_std), PARAMETER :: alloc_sap_above_grass = 1.0
! extrema of leaf allocation fraction
REAL(r_std), PARAMETER :: min_LtoLSR = 0.2
REAL(r_std), PARAMETER :: max_LtoLSR = 0.5
! below this lai, the carbohydrate reserve is used
REAL(r_std), DIMENSION(npft) :: lai_happy
! limiting factor light
REAL(r_std), DIMENSION(npts) :: limit_L
! limiting factor nitrogen
REAL(r_std), DIMENSION(npts) :: limit_N
! factors determining limit_N: 1/ temperature
REAL(r_std), DIMENSION(npts) :: limit_N_temp
! factors determining limit_N: 2/ humidity
REAL(r_std), DIMENSION(npts) :: limit_N_hum
! limiting factor water
REAL(r_std), DIMENSION(npts) :: limit_W
! limiting factor in soil (nitrogen or water)
REAL(r_std), DIMENSION(npts) :: limit_WorN
! limit: strongest limitation amongst limit_N, limit_W and limit_L
REAL(r_std), DIMENSION(npts) :: limit
! scaling depth for nitrogen limitation (m)
REAL(r_std), PARAMETER :: z_nitrogen = 0.2
! soil temperature used for N parameterization
REAL(r_std), DIMENSION(npts) :: t_nitrogen
! soil humidity used for N parameterization
REAL(r_std), DIMENSION(npts) :: h_nitrogen
! integration constant for vertical profiles
REAL(r_std), DIMENSION(npts) :: rpc
! ratio between leaf-allocation and (leaf+sapwood+root)-allocation
REAL(r_std), DIMENSION(npts) :: LtoLSR
! ratio between sapwood-allocation and (leaf+sapwood+root)-allocation
REAL(r_std), DIMENSION(npts) :: StoLSR
! ratio between root-allocation and (leaf+sapwood+root)-allocation
REAL(r_std), DIMENSION(npts) :: RtoLSR
! rescaling factor for carbohydrate reserve allocation
REAL(r_std), DIMENSION(npts) :: carb_rescale
! mass taken from carbohydrate reserve (gC/m**2)
REAL(r_std), DIMENSION(npts) :: use_reserve
! mass taken from carbohydrate reserve and put into leaves (gC/m**2)
REAL(r_std), DIMENSION(npts) :: transloc_leaf
! mass in youngest leaf age class (gC/m**2)
REAL(r_std), DIMENSION(npts) :: leaf_mass_young
! old leaf biomass (gC/m**2)
REAL(r_std), DIMENSION(npts,npft) :: lm_old
! maximum time (d) during which reserve is used
REAL(r_std) :: reserve_time
! lai on natural part of the grid cell, or of this agricultural PFT
REAL(r_std), DIMENSION(npts,npft) :: lai_around
! vegetation cover of natural PFTs on the grid cell (agriculture masked)
REAL(r_std), DIMENSION(npts,npft) :: veget_max_nat
! total natural vegetation cover on natural part of the grid cell
REAL(r_std), DIMENSION(npts) :: natveg_tot
! average LAI on natural part of the grid cell
REAL(r_std), DIMENSION(npts) :: lai_nat
! intermediate array for looking for minimum
REAL(r_std), DIMENSION(npts) :: zdiff_min
! fraction of sapwood allocation above ground (SHOULD BE CALCULATED !!!!)
REAL(r_std) :: alloc_sap_above
! soil levels (m)
REAL(r_std), SAVE, DIMENSION(0:nbdl) :: z_soil
! Index
INTEGER(i_std) :: i,j,l,m
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering alloc'
!
! 1 Initialization
!
!
! 1.1 first call
!
IF ( firstcall ) THEN
! 1.1.1 soil levels
z_soil(0) = 0.
z_soil(1:nbdl) = diaglev(1:nbdl)
! 1.1.2 info about flags and parameters.
WRITE(numout,*) 'alloc:'
WRITE(numout,'(a,$)') ' > We'
IF ( .NOT. ok_minres ) WRITE(numout,'(a,$)') ' do NOT'
WRITE(numout,*) 'try to reach a minumum reservoir when severely stressed.'
WRITE(numout,*) ' > Time to put initial leaf mass on (d): ',tau_leafinit
WRITE(numout,*) ' > scaling depth for nitrogen limitation (m): ', &
z_nitrogen
WRITE(numout,*) ' > sap allocation above the ground / total sap allocation: '
WRITE(numout,*) ' trees:', alloc_sap_above_tree
WRITE(numout,*) ' grasses:', alloc_sap_above_grass
WRITE(numout,*) ' > standard root alloc fraction: ', R0
WRITE(numout,*) ' > standard sapwood alloc fraction: ', S0
WRITE(numout,*) ' > standard fruit allocation: ', f_fruit
WRITE(numout,*) ' > minimum/maximum leaf alloc fraction: ', min_LtoLSR,max_LtoLSR
WRITE(numout,*) ' > maximum time (d) during which reserve is used:'
WRITE(numout,*) ' trees:',reserve_time_tree
WRITE(numout,*) ' grasses:',reserve_time_grass
firstcall = .FALSE.
ENDIF
!
! 1.2 initialize output
!
f_alloc(:,:,:) = 0.0
f_alloc(:,:,icarbres) = 1.0
!
! 1.3 Convolution of the temperature and humidity profiles with some kind of profile
! of microbial density gives us a representative temperature and humidity
!
! 1.3.1 temperature
! 1.3.1.1 rpc is an integration constant such that the integral of the root profile is 1.
rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_nitrogen ) )
! 1.3.1.2 integrate over the nbdl levels
t_nitrogen(:) = 0.
DO l = 1, nbdl
t_nitrogen(:) = &
t_nitrogen(:) + tsoil_month(:,l) * rpc(:) * &
( EXP( -z_soil(l-1)/z_nitrogen ) - EXP( -z_soil(l)/z_nitrogen ) )
ENDDO
! 1.3.2 moisture
! 1.3.2.1 rpc is an integration constant such that the integral of the root profile is 1.
rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_nitrogen ) )
! 1.3.2.2 integrate over the nbdl levels
h_nitrogen(:) = 0.0
DO l = 1, nbdl
h_nitrogen(:) = &
h_nitrogen(:) + soilhum_month(:,l) * rpc(:) * &
( EXP( -z_soil(l-1)/z_nitrogen ) - EXP( -z_soil(l)/z_nitrogen ) )
ENDDO
!
! 1.4 for light limitation: lai on natural part of the grid cell or lai of this
! agricultural PFT
!
! mask agricultural vegetation
! mean LAI on natural part
natveg_tot(:) = 0.0
lai_nat(:) = 0.0
DO j = 1, npft
IF ( natural(j) ) THEN
veget_max_nat(:,j) = veget_max(:,j)
ELSE
veget_max_nat(:,j) = 0.0
ENDIF
! sum up fraction of natural space covered by vegetation
natveg_tot(:) = natveg_tot(:) + veget_max_nat(:,j)
! sum up lai
lai_nat(:) = lai_nat(:) + veget_max_nat(:,j) * lai(:,j)
ENDDO
DO j = 1, npft
IF ( natural(j) ) THEN
lai_around(:,j) = lai_nat(:)
ELSE
lai_around(:,j) = lai(:,j)
ENDIF
ENDDO
!
! 1.5 LAI below which carbohydrate reserve is used
!
lai_happy(:) = lai_max(:) * 0.5
!
! 2 Use carbohydrate reserve
! This time constant implicitly takes into account the dispersion of the budburst
! data. Therefore, it might be decreased at lower resolution.
!
! save old leaf mass
lm_old(:,:) = biomass(:,:,ileaf)
DO j = 1, npft
!
! 2.1 determine mass to be translocated to leaves and roots
!
! determine maximum time during which reserve is used
IF ( tree(j) ) THEN
reserve_time = reserve_time_tree
ELSE
reserve_time = reserve_time_grass
ENDIF
! conditions: 1/ plant must not be senescent
! 2/ lai must be relatively low
! 3/ must be at the beginning of the growing season
WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. &
( .NOT. senescence(:,j) ) .AND. &
( lai(:,j) .LT. lai_happy(j) ) .AND. &
( when_growthinit(:,j) .LT. reserve_time ) )
! determine mass to put on
use_reserve(:) = &
MIN( biomass(:,j,icarbres), &
2._r_std * dt/tau_leafinit * lai_happy(j) * veget_max(:,j) / sla(j) )
! grow leaves and fine roots
transloc_leaf(:) = L0/(L0+R0) * use_reserve(:)
biomass(:,j,ileaf) = biomass(:,j,ileaf) + transloc_leaf(:)
biomass(:,j,iroot) = biomass(:,j,iroot) + ( use_reserve(:) - transloc_leaf(:) )
! decrease reserve mass
biomass(:,j,icarbres) = biomass(:,j,icarbres) - use_reserve(:)
ELSEWHERE
transloc_leaf(:) = 0.0
ENDWHERE
!
! 2.2 update leaf age
!
! 2.2.1 Decrease leaf age in youngest class.
leaf_mass_young(:) = leaf_frac(:,j,1) * lm_old(:,j) + transloc_leaf(:)
WHERE ( ( transloc_leaf(:) .GT. 0.0 ) .AND. ( leaf_mass_young(:) .GT. 0.0 ) )
leaf_age(:,j,1) = leaf_age(:,j,1) * ( leaf_mass_young(:) - transloc_leaf(:) ) / &
leaf_mass_young(:)
ENDWHERE
! 2.2.2 new age class fractions (fraction in youngest class increases)
! 2.2.2.1 youngest class: new mass in youngest class divided by total new mass
WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
leaf_frac(:,j,1) = leaf_mass_young(:) / biomass(:,j,ileaf)
ENDWHERE
! 2.2.2.2 other classes: old mass in leaf age class divided by new mass
DO m = 2, nleafages
WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
leaf_frac(:,j,m) = leaf_frac(:,j,m) * lm_old(:,j) / biomass(:,j,ileaf)
ENDWHERE
ENDDO
ENDDO ! loop over PFTs
!
! 3 Calculate fractional allocation.
! The fractions of NPP allocated to the different compartments depend on the
! availability of light, water, and nitrogen.
!
DO j = 1, npft
RtoLSR(:)=0
LtoLSR(:)=0
StoLSR(:)=0
! for the moment, fixed partitioning between above and below the ground
IF ( tree(j) ) THEN
alloc_sap_above = alloc_sap_above_tree
ELSE
alloc_sap_above = alloc_sap_above_grass
ENDIF
! only where leaves are on
WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
!
! 3.1 Limiting factors: weak value = strong limitation
!
! 3.1.1 Light: depends on mean lai on the natural part of the
! grid box (light competition).
! For agricultural PFTs, take its own lai for both parts.
limit_L(:) = MAX( 0.1_r_std, exp( -0.5_r_std * lai_around(:,j) ) )
! 3.1.2 Water
limit_W(:) = MAX( 0.1_r_std, MIN( 1._r_std, moiavail_week(:,j) ) )
! 3.1.3 Nitrogen supply: depends on water and temperature
! Agricultural PFTs can be limited by Nitrogen for the moment ...
! Replace this once there is a nitrogen cycle in STOMATE !
! 3.1.3.1 water
limit_N_hum(:) = MAX( 0.5_r_std, MIN( 1._r_std, h_nitrogen(:) ) )
! 3.1.3.2 temperature
limit_N_temp(:) = 2.**((t_nitrogen(:)-ZeroCelsius-25.)/10.)
limit_N_temp(:) = MAX( 0.1_r_std, MIN( 1._r_std, limit_N_temp(:) ) )
! 3.1.3.3 combine water and temperature factors to get nitrogen limitation
limit_N(:) = MAX( 0.1_r_std, MIN( 1._r_std, limit_N_hum(:) * limit_N_temp(:) ) )
! 3.1.4 Among water and nitrogen, take the one that is more limited
limit_WorN(:) = MIN( limit_W(:), limit_N(:) )
! 3.1.5 strongest limitation
limit(:) = MIN( limit_WorN(:), limit_L(:) )
!
! 3.2 Ratio between allocation to leaves, sapwood and roots
!
! preliminary root allocation
RtoLSR(:) = &
MAX( .15_r_std, &
R0 * 3._r_std * limit_L(:) / ( limit_L(:) + 2._r_std * limit_WorN(:) ) )
! sapwood allocation
StoLSR(:) = S0 * 3. * limit_WorN(:) / ( 2. * limit_L(:) + limit_WorN(:) )
! leaf allocation
LtoLSR(:) = 1. - RtoLSR(:) - StoLSR(:)
LtoLSR(:) = MAX( min_LtoLSR, MIN( max_LtoLSR, LtoLSR(:) ) )
! roots: the rest
RtoLSR(:) = 1. - LtoLSR(:) - StoLSR(:)
ENDWHERE
! no leaf allocation if LAI beyond maximum LAI. Biomass then goes into sapwood
WHERE ( (biomass(:,j,ileaf) .GT. min_stomate) .AND. (lai(:,j) .GT. lai_max(j)) )
StoLSR(:) = StoLSR(:) + LtoLSR(:)
LtoLSR(:) = 0.0
ENDWHERE
!
! 3.3 final allocation
!
DO i = 1, npts
IF ( biomass(i,j,ileaf) .GT. min_stomate ) THEN
IF ( senescence(i,j) ) THEN
! 3.3.1 senescent: everything goes into carbohydrate reserve
f_alloc(i,j,icarbres) = 1.0
ELSE
! 3.3.2 in growing season
! to fruits
f_alloc(i,j,ifruit) = f_fruit
! allocation to the reserve is proportional to the leaf and root allocation.
! Leaf, root, and sap allocation are rescaled.
! No allocation to reserve if there is much biomass in it
! (more than the maximum LAI: in that case, rescale=1)
IF ( ( biomass(i,j,icarbres)*sla(j)/veget_max(i,j) ) .LT. lai_max(j) ) THEN
carb_rescale(i) = 1. / ( 1. + ecureuil(j) * ( LtoLSR(i) + RtoLSR(i) ) )
ELSE
carb_rescale(i) = 1.
ENDIF
f_alloc(i,j,ileaf) = LtoLSR(i) * ( 1.-f_alloc(i,j,ifruit) ) * carb_rescale(i)
f_alloc(i,j,isapabove) = StoLSR(i) * alloc_sap_above * &
( 1. - f_alloc(i,j,ifruit) ) * carb_rescale(i)
f_alloc(i,j,isapbelow) = StoLSR(i) * ( 1. - alloc_sap_above ) * &
( 1. - f_alloc(i,j,ifruit) ) * carb_rescale(i)
f_alloc(i,j,iroot) = RtoLSR(i) * ( 1.-f_alloc(i,j,ifruit) ) * carb_rescale(i)
! this is equivalent to:
! reserve alloc = ecureuil*(LtoLSR+StoLSR)*(1-fruit_alloc)*carb_rescale
f_alloc(i,j,icarbres) = ( 1. - carb_rescale(i) ) * ( 1.-f_alloc(i,j,ifruit) )
ENDIF ! senescent?
ENDIF ! there are leaves
ENDDO ! Fortran95: double WHERE construct
ENDDO ! loop over PFTs
!
! 4 root profile
!
IF (bavard.GE.4) WRITE(numout,*) 'Leaving alloc'
END SUBROUTINE alloc
END MODULE stomate_alloc
ORCHIDEE/src_stomate/stomate_assimtemp.f90 0000754 0103600 0005670 00000004600 11164403473 020326 0 ustar acamlmd lmdjus ! calculates the photosynthesis temperatures
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_assimtemp.f90,v 1.6 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_assimtemp
! modules used:
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC assim_temp
CONTAINS
SUBROUTINE assim_temp (npts, tlong_ref, t2m_month, t_photo_min, t_photo_opt, t_photo_max)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! "long term" 2 meter reference temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
! "monthly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
! 0.2 output
! Minimum temperature for photosynthesis (K)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_min
! Optimum temperature for photosynthesis (K)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_opt
! Maximum temperature for photosynthesis (K)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_max
! 0.3 local
! "long term" 2 meter reference temperatures (deg C)
REAL(r_std), DIMENSION(npts) :: tl
! Index
INTEGER(i_std) :: j
! =========================================================================
tl(:) = tlong_ref(:) - ZeroCelsius
DO j = 1, npft
!
! 1 normal case
!
t_photo_min(:,j) = t_photo%t_min_c(j) + t_photo%t_min_b(j)*tl(:) + t_photo%t_min_a(j)*tl(:)*tl(:) + ZeroCelsius
t_photo_opt(:,j) = t_photo%t_opt_c(j) + t_photo%t_opt_b(j)*tl(:) + t_photo%t_opt_a(j)*tl(:)*tl(:) + ZeroCelsius
t_photo_max(:,j) = t_photo%t_max_c(j) + t_photo%t_max_b(j)*tl(:) + t_photo%t_max_a(j)*tl(:)*tl(:) + ZeroCelsius
!
! 2 If the monthly temperature is too low, we set tmax < tmin.
! Therefore, photosynthesis will not be possible (we need tmin < t < tmax)
!
WHERE ( t2m_month(:) .LT. t_photo_min(:,j) )
t_photo_max(:,j) = t_photo_min(:,j) - min_stomate
ENDWHERE
ENDDO
END SUBROUTINE assim_temp
END MODULE stomate_assimtemp
ORCHIDEE/src_stomate/stomate_constants.f90 0000754 0103600 0005670 00000064303 11164403473 020346 0 ustar acamlmd lmdjus !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_constants.f90,v 1.17 2007/05/28 14:41:53 ssipsl Exp $
!IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!-
MODULE stomate_constants
!---------------------------------------------------------------------
USE defprec
USE constantes_veg
!-
! Number of pfts
INTEGER(i_std),PARAMETER :: npft = nvm-1
!-
! bare soil in Sechiba
INTEGER(i_std),PARAMETER :: ibare_sechiba = 1
!-
! which Sechiba-PFT corresponds to a given Stomate-PFT
INTEGER(i_std),SAVE,DIMENSION(npft) :: ipft_sechiba
!-
! how many Stomate-PFTs correspond to each Sechiba-PFT ?
! e.g. for age classes
INTEGER(i_std),SAVE,DIMENSION(nvm) :: npft_stomate
!-
! 0 = no, 4 = full online diagnostics
INTEGER(i_std),SAVE :: bavard=1
! write forcing file for carbon spinup?
LOGICAL,SAVE :: write_carbonforce
! Horizontal indices
INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: hori_index
! Horizonatal + PFT indices
INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: horipft_index
!-
! deforestation
! Horizontal + P10 indices
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip10_index
! Horizontal + P100 indices
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip100_index
! Horizontal + P11 indices
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip11_index
! Horizontal + P101 indices
INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip101_index
!-
! time step
INTEGER(i_std),SAVE :: itime
! STOMATE history file ID
INTEGER(i_std),SAVE :: hist_id_stomate
! STOMATE restart file ID
INTEGER(i_std),SAVE :: rest_id_stomate
!-
! Freezing point
REAL(r_std),PARAMETER :: ZeroCelsius = 273.15
! e
REAL(r_std),PARAMETER :: euler = 2.71828182846
! Epsilon to detect a near zero floating point
REAL(r_std),PARAMETER :: min_stomate = 1.E-8_r_std
! some large value
REAL(r_std),PARAMETER :: large_value = 1.E33_r_std
! Special value
REAL(r_std),PARAMETER :: undef = -9999.
!-
! maximum reference long term temperature (K)
REAL(r_std),PARAMETER :: tlong_ref_max=303.1
! minimum reference long term temperature (K)
REAL(r_std),PARAMETER :: tlong_ref_min=253.1
!-
! trees and litter: indices for the parts of heart- and sapwood above
! and below the ground
INTEGER(i_std),PARAMETER :: iabove = 1
INTEGER(i_std),PARAMETER :: ibelow = 2
INTEGER(i_std),PARAMETER :: nlevs = 2
!-
! litter: indices for metabolic and structural part
INTEGER(i_std),PARAMETER :: imetabolic = 1
INTEGER(i_std),PARAMETER :: istructural = 2
INTEGER(i_std),PARAMETER :: nlitt = 2
!-
! carbon pools: indices
INTEGER(i_std),PARAMETER :: iactive = 1
INTEGER(i_std),PARAMETER :: islow = 2
INTEGER(i_std),PARAMETER :: ipassive = 3
INTEGER(i_std),PARAMETER :: ncarb = 3
!-
! litter fractions: indices
INTEGER(i_std),PARAMETER :: ileaf = 1
INTEGER(i_std),PARAMETER :: isapabove = 2
INTEGER(i_std),PARAMETER :: isapbelow = 3
INTEGER(i_std),PARAMETER :: iheartabove = 4
INTEGER(i_std),PARAMETER :: iheartbelow = 5
INTEGER(i_std),PARAMETER :: iroot = 6
INTEGER(i_std),PARAMETER :: ifruit = 7
INTEGER(i_std),PARAMETER :: icarbres = 8
INTEGER(i_std),PARAMETER :: nparts = 8
!-
! vegetation types: natural and agricultural
INTEGER(i_std),PARAMETER :: inat = 1
INTEGER(i_std),PARAMETER :: iagri = 2
INTEGER(i_std),PARAMETER :: nvegtypes = 2
!-
! transformation between types of surface
INTEGER(i_std),PARAMETER :: ito_natagri = 1
INTEGER(i_std),PARAMETER :: ito_total = 2
!-
! leaf age discretisation ( 1 = no discretisation )
INTEGER(i_std),PARAMETER :: nleafages = 4
!-
! alpha's : ?
REAL(r_std),PARAMETER :: alpha_grass = .5
REAL(r_std),PARAMETER :: alpha_tree = 1.
!-
! type declaration for photosynthesis
TYPE t_photo_type
REAL(r_std),DIMENSION(npft) :: t_max_a
REAL(r_std),DIMENSION(npft) :: t_max_b
REAL(r_std),DIMENSION(npft) :: t_max_c
REAL(r_std),DIMENSION(npft) :: t_opt_a
REAL(r_std),DIMENSION(npft) :: t_opt_b
REAL(r_std),DIMENSION(npft) :: t_opt_c
REAL(r_std),DIMENSION(npft) :: t_min_a
REAL(r_std),DIMENSION(npft) :: t_min_b
REAL(r_std),DIMENSION(npft) :: t_min_c
END TYPE t_photo_type
!-
! type declaration for phenology
TYPE pheno_type
REAL(r_std),DIMENSION(npft,3) :: gdd
REAL(r_std),DIMENSION(npft) :: ngd
REAL(r_std),DIMENSION(npft) :: ncdgdd_temp
REAL(r_std),DIMENSION(npft) :: hum_frac
REAL(r_std),DIMENSION(npft) :: lowgpp_time
REAL(r_std),DIMENSION(npft) :: leaffall
REAL(r_std),DIMENSION(npft) :: leafagecrit
REAL(r_std) :: tau_hum_month
REAL(r_std) :: tau_hum_week
REAL(r_std) :: tau_t2m_month
REAL(r_std) :: tau_t2m_week
REAL(r_std) :: tau_tsoil_month
REAL(r_std) :: tau_soilhum_month
REAL(r_std) :: tau_gpp_week
REAL(r_std) :: tau_gdd
REAL(r_std) :: tau_ngd
REAL(r_std) :: tau_longterm
REAL(r_std),DIMENSION(npft) :: lai_initmin
CHARACTER(len=6),DIMENSION(npft) :: pheno_model
CHARACTER(len=6),DIMENSION(npft) :: senescence_type
REAL(r_std),DIMENSION(npft,3) :: senescence_temp
REAL(r_std),DIMENSION(npft) :: senescence_hum
REAL(r_std),DIMENSION(npft) :: nosenescence_hum
REAL(r_std),DIMENSION(npft) :: max_turnover_time
REAL(r_std), DIMENSION(npft) :: min_leaf_age_for_senescence
REAL(r_std),DIMENSION(npft) :: min_turnover_time
!-
REAL(r_std),DIMENSION(npft) :: hum_min_time
END TYPE pheno_type
!-
! parameters for the pipe model
!-
! crown area = pipe_tune1. stem diameter**(1.6) (Reinicke's theory)
REAL(r_std),PARAMETER :: pipe_tune1 = 100.0
! height=pipe_tune2 * diameter**pipe_tune3
REAL(r_std),PARAMETER :: pipe_tune2 = 40.0
REAL(r_std),PARAMETER :: pipe_tune3 = 0.5
! needed for stem diameter
REAL(r_std),PARAMETER :: pipe_tune4 = 0.3
! Density
REAL(r_std),PARAMETER :: pipe_density = 2.e5
! one more parameter
REAL(r_std),PARAMETER :: pipe_k1 = 8.e3
!-
! Maximum tree establishment rate
REAL(r_std),PARAMETER :: estab_max_tree = 0.12
! Maximum grass establishment rate
REAL(r_std),PARAMETER :: estab_max_grass = 0.12
! initial density of individuals
REAL(r_std),PARAMETER :: ind_0 = 0.02
!-
! Do we treat PFT expansion across a grid point after introduction?
! default = .FALSE.
LOGICAL,SAVE :: treat_expansion = .FALSE.
!-
! herbivores?
LOGICAL,SAVE :: ok_herbivores = .FALSE.
!-
! For trees, minimum fraction of crown area occupied
! (due to its branches etc.)
! This means that only a small fraction of its crown area
! can be invaded by other trees.
REAL(r_std),PARAMETER :: min_cover = 0.05
!-
! climatic parameters
!-
! minimum precip, in mm/year
REAL(r_std),PARAMETER :: precip_crit = 100.
! minimum gdd for establishment of saplings
REAL(r_std),PARAMETER :: gdd_crit = 150.
! critical fpc, needed for light competition and establishment
REAL(r_std),PARAMETER :: fpc_crit = 0.95
!-
! critical value for being adapted (1-1/e)
REAL(r_std),PARAMETER :: adapted_crit = 1. - ( 1. / euler )
! critical value for being regenerative (1/e)
REAL(r_std),PARAMETER :: regenerate_crit = 1. / euler
!-
! fraction of GPP which is lost as growth respiration
REAL(r_std),PARAMETER :: frac_growthresp = 0.28
!-
! radius of the Earth (m)
REAL(r_std),PARAMETER :: R_Earth = 6378000.
!-
! description of the PFT
CHARACTER(len=34),SAVE,DIMENSION(npft) :: PFT_name = &
& (/ 'tropical broad-leaved evergreen ', &
& 'tropical broad-leaved raingreen ', &
& 'temperate needleleaf evergreen ', &
& 'temperate broad-leaved evergreen ', &
& 'temperate broad-leaved summergreen', &
& 'boreal needleleaf evergreen ', &
& 'boreal broad-leaved summergreen', &
& 'boreal needleleaf summergreen', &
& ' C3 grass ', &
& ' C4 grass ', &
& ' C3 agriculture', &
& ' C4 agriculture' /)
! extinction coefficient of the Monsi&Seaki (53) relationship
REAL(r_std),SAVE,DIMENSION(npft) :: ext_coeff
! is pft a tree
LOGICAL,SAVE,DIMENSION(npft) :: tree
! leaf type
! 1=broad leaved tree, 2=needle leaved tree, 3=grass
INTEGER(i_std),SAVE,DIMENSION(npft) :: leaf_tab = &
& (/ 1, 1, 2, 1, 1, 2, &
& 1, 2, 3, 3, 3, 3 /)
! natural?
LOGICAL,SAVE,DIMENSION(npft) :: natural = &
& (/ .TRUE., .TRUE., .TRUE., .TRUE., .TRUE., .TRUE., &
& .TRUE., .TRUE., .TRUE., .TRUE., .FALSE., .FALSE. /)
! flamability: critical fraction of water holding capacity
REAL(r_std),SAVE,DIMENSION(npft) :: flam
! fire resistance
REAL(r_std),SAVE,DIMENSION(npft) :: resist = &
& (/ .12, .50, .12, .50, .12, .12, &
& .12, .12, .0, .0, .0, .0 /)
! specific leaf area (m**2/gC)
REAL(r_std),SAVE,DIMENSION(npft) :: sla
! sapling biomass (gC/ind)
REAL(r_std),SAVE,DIMENSION(npft,nparts) :: bm_sapl
! migration speed (m/year)
REAL(r_std),SAVE,DIMENSION(npft) :: migrate
! maximum stem diameter from which on crown area no longer increases (m)
REAL(r_std),SAVE,DIMENSION(npft) :: maxdia
! critical minimum temperature (K)
REAL(r_std),SAVE,DIMENSION(npft) :: tmin_crit
! critical temperature of the coldest month (K)
REAL(r_std),SAVE,DIMENSION(npft) :: tcm_crit
! critical values for phenology
TYPE(pheno_type),SAVE :: pheno_crit
! time constant for leaf age discretisation (d)
REAL(r_std),SAVE,DIMENSION(npft) :: leaf_timecst
! maximum LAI, PFT-specific
REAL(r_std),SAVE,DIMENSION (npft) :: lai_max = &
& (/ 7., 7., 5., 5., 5., 4.5, &
& 4.5, 3.0, 2.5, 2.5, 5., 5. /)
! maintenance respiration coefficient (g/g/day) at 0 deg C
REAL(r_std),SAVE,DIMENSION(npft,nparts) :: coeff_maint_zero
! slope of maintenance respiration coefficient (1/K, 1/K^2, 1/K^3)
REAL(r_std),SAVE,DIMENSION(npft,3) :: maint_resp_slope
! residence time (y) of trees
REAL(r_std),SAVE,DIMENSION(npft) :: residence_time = &
& (/ 30.0, 30.0, 40.0, 40.0, 40.0, 80.0, &
& 80.0, 80.0, 0.0, 0.0, 0.0, 0.0 /)
!SZ modifications
! leaf lifetime, tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: leaflife_tab = &
& (/ .5, 2., .33, 1., 2., .33, &
& 2., 2., 2., 2., 2., 2. /)
! OLD HEAD
!!$ & (/ .5, 1., .5, .5, 1., .5, &
!!$ & 1., 1., 1., 1., 1., 1. /)
! type of phenology
! 1=evergreen, 2=summergreen, 3=raingreen, 4=perennial
INTEGER(i_std),SAVE,DIMENSION(npft) :: pheno_type_tab = &
& (/ 1, 3, 1, 1, 2, 1, &
& 2, 2, 4, 4, 2, 3 /)
! critical tmin, tabulated (C)
REAL(r_std),SAVE,DIMENSION(npft) :: tmin_crit_tab = &
& (/ 0.0, 0.0, -45.0, -10.0, -45.0, -60.0, &
& -60.0, undef, undef, undef, undef, undef /)
! critical tcm, tabulated (C)
REAL(r_std),SAVE,DIMENSION(npft) :: tcm_crit_tab = &
& (/ undef, undef, 5.0, 15.5, 15.5, -2.0, &
& 5.0, -2.0, undef, undef, undef, undef /)
! critical gdd, tabulated (C), constant c of aT^2+bT+c
REAL(r_std),SAVE,DIMENSION(npft) :: gdd_crit1_tab = &
& (/ undef, undef, undef, undef, undef, undef, &
& undef, undef, 184.375, 400., 125., 400. /)
! critical gdd, tabulated (C), constant b of aT^2+bT+c
REAL(r_std),SAVE,DIMENSION(npft) :: gdd_crit2_tab = &
& (/ undef, undef, undef, undef, undef, undef, &
& undef, undef, 6.25, 0., 0., 0. /)
! critical gdd, tabulated (C), constant a of aT^2+bT+c
REAL(r_std),SAVE,DIMENSION(npft) :: gdd_crit3_tab = &
& (/ undef, undef, undef, undef, undef, undef, &
& undef, undef, 0.03125, 0., 0., 0. /)
! critical ngd, tabulated. Threshold -5 degrees
REAL(r_std),SAVE,DIMENSION(npft) :: ngd_crit_tab = &
& (/ undef, undef, undef, undef, undef, undef, &
& undef, 17., undef, undef, undef, undef /)
! critical temperature for the ncd vs. gdd function in phenology
REAL(r_std),SAVE,DIMENSION(npft) :: ncdgdd_temp_tab = &
& (/ undef, undef, undef, undef, 5., undef, &
& 0., undef, undef, undef, undef, undef /)
! critical humidity (relative to min/max) for phenology
REAL(r_std),SAVE,DIMENSION(npft) :: hum_frac_tab
! minimum duration of dormance (d) for phenology
REAL(r_std),SAVE,DIMENSION(npft) :: lowgpp_time_tab
! minimum time elapsed since moisture minimum (d)
REAL(r_std),SAVE,DIMENSION(npft) :: hum_min_time_tab
! sapwood -> heartwood conversion time (d)
REAL(r_std),SAVE,DIMENSION(npft) :: tau_sap
! fruit lifetime (d)
REAL(r_std),SAVE,DIMENSION(npft) :: tau_fruit
! fraction of primary leaf and root allocation put into reserve
REAL(r_std),SAVE,DIMENSION(npft) :: ecureuil
! Maximum rate of carboxylation
REAL(r_std),SAVE,DIMENSION(npft) :: vcmax_opt
! Maximum rate of RUbp regeneration
REAL(r_std),SAVE,DIMENSION(npft) :: vjmax_opt
! constants needed for photosynthesis temperatures
TYPE(t_photo_type),SAVE :: t_photo
! lenth of death of leaves, tabulated (d)
REAL(r_std),SAVE,DIMENSION(npft) :: leaffall_tab
! critical leaf age, tabulated (d)
REAL(r_std),SAVE,DIMENSION(npft) :: leafagecrit_tab
! which phenology model is used? (tabulated)
CHARACTER(len=6),SAVE,DIMENSION(npft) :: pheno_model_tab
! type of senescence, tabulated
CHARACTER(len=6),SAVE,DIMENSION(npft) :: senescence_type_tab
! critical temperature for senescence (C),
! constant c of aT^2+bT+c , tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: senescence_temp1_tab
! critical temperature for senescence (C),
! constant b of aT^2+bT+c , tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: senescence_temp2_tab
! critical temperature for senescence (C),
! constant a of aT^2+bT+c , tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: senescence_temp3_tab
! critical relative moisture availability for senescence
REAL(r_std),SAVE,DIMENSION(npft) :: senescence_hum_tab
! relative moisture availability above which
! there is no humidity-related senescence
REAL(r_std),SAVE,DIMENSION(npft) :: nosenescence_hum_tab
! maximum turnover time for grasse
REAL(r_std),SAVE,DIMENSION(npft) :: max_turnover_time_tab
! minimum turnover time for grasse
REAL(r_std),SAVE,DIMENSION(npft) :: min_turnover_time_tab
! minimum leaf age to allow senescence g
REAL(r_std), SAVE, DIMENSION(npft) :: min_leaf_age_for_senescence_tab
!-
! slope of maintenance respiration coefficient (1/K),
! constant c of aT^2+bT+c , tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: maint_resp_slope1_tab
! slope of maintenance respiration coefficient (1/K),
! constant b of aT^2+bT+c , tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: maint_resp_slope2_tab
! slope of maintenance respiration coefficient (1/K),
! constant a of aT^2+bT+c , tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: maint_resp_slope3_tab
! maintenance respiration coefficient (g/g/day) at 0 deg C,
! for leaves, tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_leaf_tab
! maintenance respiration coefficient (g/g/day) at 0 deg C,
! for sapwood above, tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_sapabove_tab
! maintenance respiration coefficient (g/g/day) at 0 deg C,
! for sapwood below, tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_sapbelow_tab
! maintenance respiration coefficient (g/g/day) at 0 deg C,
! for heartwood above, tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_heartabove_tab
! maintenance respiration coefficient (g/g/day) at 0 deg C,
! for heartwood below, tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_heartbelow_tab
! maintenance respiration coefficient (g/g/day) at 0 deg C,
! for roots, tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_root_tab
! maintenance respiration coefficient (g/g/day) at 0 deg C,
! for fruits, tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_fruit_tab
! maintenance respiration coefficient (g/g/day) at 0 deg C,
! for carbohydrate reserve, tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_carbres_tab
! minimum photosynthesis temperature,
! constant a of ax^2+bx+c (deg C), tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_min_a_tab
! minimum photosynthesis temperature,
! constant b of ax^2+bx+c (deg C), tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_min_b_tab
! minimum photosynthesis temperature,
! constant c of ax^2+bx+c (deg C), tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_min_c_tab
! optimum photosynthesis temperature,
! constant a of ax^2+bx+c (deg C), tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_opt_a_tab
! optimum photosynthesis temperature,
! constant b of ax^2+bx+c (deg C), tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_opt_b_tab
! optimum photosynthesis temperature,
! constant c of ax^2+bx+c (deg C), tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_opt_c_tab
! maximum photosynthesis temperature,
! constant a of ax^2+bx+c (deg C), tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_max_a_tab
! maximum photosynthesis temperature,
! constant b of ax^2+bx+c (deg C), tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_max_b_tab
! maximum photosynthesis temperature,
! constant c of ax^2+bx+c (deg C), tabulated
REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_max_c_tab
!-
! tables
!-
!-
DATA flam / .25, .25, .25, .25, .25, .25, &
.25, .25, .30, .30, .35, .35 /
! DATA flam / .15, .15, .15, .15, .15, .15, &
! .15, .15, .15, .15, .15, .15 /
!-
DATA hum_frac_tab / undef, .5, undef, undef, undef, undef, &
undef, undef, .5, .5, .5, .5 /
!-
DATA lowgpp_time_tab / undef, 30., undef, undef, 30., undef, &
30., 30., 30., 30., 30., 30. /
!-
DATA hum_min_time_tab / undef, 50., undef, undef, undef, undef, &
undef, undef, 35., 35., 75., 75. /
!-
DATA tau_sap / 730., 730., 730., 730., 730., 730., &
730., 730., undef, undef, undef, undef /
!-
DATA tau_fruit / 90., 90., 90., 90., 90., 90., &
90., 90., undef, undef, undef, undef /
!-
DATA ecureuil / .0, 1., .0, .0, 1., .0, &
1., 1., 1., 1., 1., 1. /
!-
! Shilong modification
DATA vcmax_opt / 65., 65., 35., 40., 55., 35., &
45., 35., 70., 70., 70., 70. /
! OLD HEAD
!!$ / 65., 65., 35., 40., 55., 35., &
!!$ 45., 35., 80., 80., 100., 100. /
!modif jerome carbofor
! DATA vcmax_opt / 65., 65., 50., 40., 75., 35., &
! 45., 35., 80., 80., 100., 100. /
DATA vjmax_opt / 130., 130., 70., 80., 110., 70., &
90., 70., 160., 160., 200., 200. /
!-
!DATA vcmax_opt_tab / 65., 65., 37.5, 45., 60., 37.5, &
! 50., 40., 100., 100., 100., 100. /
!DATA vjmax_opt_tab / 130., 130., 75., 90., 120., 75., &
! 100., 80., 200., 200., 200., 200. /
!-
DATA leaffall_tab / undef, 10., undef, undef, 10., undef, &
10., 10., 10., 10., 10., 10. /
!-
! Shilong modification
DATA leafagecrit_tab / 730., 180., 910., 730., 180., 910., &
180., 180., 120., 120., 90., 90. /
! OLD HEAD
!!$ DATA leafagecrit_tab / 730., 180., 910., 730., 180., 910., &
!!$ 180., 180., 120., 120., 120., 120. /
!-
DATA ipft_sechiba / 2, 3, 4, 5, 6, 7, &
8, 9, 10, 11, 12, 13 /
!-
DATA senescence_type_tab / 'none', 'dry', 'none', 'none', 'cold', 'none', &
'cold', 'cold', 'mixed', 'mixed', 'mixed', 'mixed' /
!-
DATA senescence_temp1_tab / undef, undef, undef, undef, 12., undef, &
7., 2., -1.375, 5., 5., 10. /
DATA senescence_temp2_tab / undef, undef, undef, undef, 0., undef, &
0., 0., .1, 0., 0., 0. /
DATA senescence_temp3_tab / undef, undef, undef, undef, 0., undef, &
0., 0., .00375, 0., 0., 0. /
!-
DATA senescence_hum_tab / undef, .6, undef, undef, undef, undef, &
undef, undef, .2, .2, .3, .2 /
!-
DATA nosenescence_hum_tab / undef, 1., undef, undef, undef, undef, &
undef, undef, .3, .3, .3, .3 /
!-
DATA max_turnover_time_tab / undef, undef, undef, undef, undef, undef, &
undef, undef, 80., 80., 80., 80. /
!-
DATA min_turnover_time_tab / undef, undef, undef, undef, undef, undef, &
undef, undef, 10., 10., 10., 10. /
!-
DATA min_leaf_age_for_senescence_tab / undef, 90, undef, undef, 90, undef, &
60, 60, 30., 30., 30., 30. /
!-
DATA pheno_model_tab / 'none', 'moi', 'none', 'none','ncdgdd', 'none', &
'ncdgdd', 'ngd','moigdd','moigdd','moigdd','moigdd' /
!-
! DATA maint_resp_slope1_tab / .16, .16, .16, .16, .16, .16, &
! .16, .16, .16, .16, .16, .16 /
! DATA maint_resp_slope2_tab / .0, .0, .0, .0, .0, .0, &
! .0, .0, .0, .0, .0, .0 /
DATA maint_resp_slope1_tab / .12, .12, .16, .16, .16, .16, &
.16, .16, .16, .12, .16, .12 /
DATA maint_resp_slope2_tab / .0, .0, .0, .0, .0, .0, &
.0, .0, -.00133, .0, -.00133, .0 /
DATA maint_resp_slope3_tab / .0, .0, .0, .0, .0, .0, &
.0, .0, .0, .0, .0, .0 /
!-
DATA cm_zero_leaf_tab / 2.35E-3, 2.62E-3, 1.01E-3, 2.35E-3, 2.62E-3, 1.01E-3, &
2.62E-3, 2.05E-3, 2.62E-3, 2.62E-3, 2.62E-3, 2.62E-3 /
!-
DATA cm_zero_sapabove_tab / 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, &
1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4 /
!-
DATA cm_zero_sapbelow_tab / 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, &
1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4 /
!-
DATA cm_zero_heartabove_tab / 0., 0., 0., 0., 0., 0., &
0., 0., 0., 0., 0., 0. /
!-
DATA cm_zero_heartbelow_tab / 0., 0., 0., 0., 0., 0., &
0., 0., 0., 0., 0., 0. /
!-
DATA cm_zero_root_tab / 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, &
1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3 /
!-
DATA cm_zero_fruit_tab / 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, &
1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4 /
!-
DATA cm_zero_carbres_tab / 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, &
1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4 /
!-
DATA tphoto_min_c_tab / 2., 2., -4., -3., -2., -4., &
-4., -4., -3.25, 13., -5., 13. /
DATA tphoto_min_b_tab / 0., 0., 0., 0., 0., 0., &
0., 0., 0.1, 0., 0., 0. /
DATA tphoto_min_a_tab / 0., 0., 0., 0., 0., 0., &
0., 0., 0.0025, 0., 0., 0. /
DATA tphoto_opt_c_tab / 37., 37., 25., 32., 26., 25., &
25., 25., 27.25, 36., 30., 36. /
DATA tphoto_opt_b_tab / 0., 0., 0., 0., 0., 0., &
0., 0., 0.25, 0., 0., 0. /
DATA tphoto_opt_a_tab / 0., 0., 0., 0., 0., 0., &
0., 0., 0.0025, 0., 0., 0. /
DATA tphoto_max_c_tab / 55., 55., 38., 48., 38., 38., &
38., 38., 41.125, 55., 45., 55. /
DATA tphoto_max_b_tab / 0., 0., 0., 0., 0., 0., &
0., 0., 0.35, 0., 0., 0. /
DATA tphoto_max_a_tab / 0., 0., 0., 0., 0., 0., &
0., 0., 0.00375, 0., 0., 0. /
!---------------------------
END MODULE stomate_constants
ORCHIDEE/src_stomate/stomate_data.f90 0000754 0103600 0005670 00000051674 11164403473 017252 0 ustar acamlmd lmdjus ! defines PFT parameters
! the geographical coordinates might be used for defining some additional parameters
! (e.g. frequency of anthropogenic fires, irrigation of agricultural surfaces, etc.)
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_data.f90,v 1.10 2007/05/28 14:51:50 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_data
! modules used:
USE constantes_veg
USE constantes_co2
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC data
CONTAINS
SUBROUTINE data (npts, lalo)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! Geographical coordinates (latitude,longitude)
REAL(r_std),DIMENSION (npts,2), INTENT (in) :: lalo
! 0.2 local variables
! Index
INTEGER(i_std) :: j
! alpha's : ?
REAL(r_std) :: alpha
! stem diameter
REAL(r_std) :: dia
! Sapling CSA
REAL(r_std) :: csa_sap
! mass ratio (heartwood+sapwood)/sapwood
REAL(r_std), PARAMETER :: x = 3.
! =========================================================================
IF ( bavard .GE. 1 ) WRITE(numout,*) 'data: PFT characteristics'
DO j = 1, npft
IF ( bavard .GE. 1 ) WRITE(numout,'(a,i3,a,a)') ' > PFT#',j,': ', PFT_name(j)
!
! 1 tree?
!
IF ( leaf_tab(j) .LE. 2 ) THEN
tree(j) = .TRUE.
ELSE
tree(j) = .FALSE.
ENDIF
IF ( bavard .GE. 1 ) WRITE(numout,*) ' tree: ', tree(j)
!
! 2 flamability
!
IF ( bavard .GE. 1 ) WRITE(numout,*) ' litter flamability:', flam(j)
!
! 3 fire resistance
!
IF ( bavard .GE. 1 ) WRITE(numout,*) ' fire resistance:', resist(j)
!
! 4 specific leaf area per mass carbon = 2 * sla / dry mass
!
!!$ IF ( leaf_tab(j) .EQ. 1 ) THEN
!!$
!!$ ! broad leaved tree
!!$
!!$ sla(j) = 2. * ( 10. ** ( 2.41 - 0.38 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
!!$
!!$ ELSE
!!$
!!$ ! needle leaved or grass (Reich et al 1992)
!!$
!!$ sla(j) = 2. * ( 10. ** ( 2.29 - 0.4 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
!!$
!!$ ENDIF
!!$
!!$ IF ( ( leaf_tab(j) .EQ. 2 ) .AND. ( pheno_type_tab(j) .EQ. 2 ) ) THEN
!!$
!!$ ! summergreen needle leaf
!!$
!!$ sla(j) = 1.25 * sla(j)
!!$
!!$ ENDIF
IF ( leaf_tab(j) .EQ. 2 ) THEN
! needle leaved tree
sla(j) = 2. * ( 10. ** ( 2.29 - 0.4 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
ELSE
! broad leaved tree or grass (Reich et al 1992)
sla(j) = 2. * ( 10. ** ( 2.41 - 0.38 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
ENDIF
IF ( bavard .GE. 1 ) WRITE(numout,*) ' specific leaf area (m**2/gC):', sla(j)
!
! 5 sapling characteristics
!
IF ( tree(j) ) THEN
! 5.1 trees
alpha = alpha_tree
bm_sapl(j,ileaf) = &
( (4.*pipe_tune1 * ( x*4.*sla(j)/(pi*pipe_k1))**.8 ) / sla(j) ) ** 5.
IF ( pheno_type_tab(j) .NE. 1 ) THEN
! not evergreen
bm_sapl(j,icarbres) = 5. * bm_sapl(j,ileaf)
ELSE
bm_sapl(j,icarbres) = 0.0
ENDIF
csa_sap = bm_sapl(j,ileaf) / ( pipe_k1 / sla(j) )
dia = ( x * csa_sap * 4. / pi ) ** 0.5
bm_sapl(j,isapabove) = &
.5 * pipe_density * csa_sap * pipe_tune2 * dia ** pipe_tune3
bm_sapl(j,isapbelow) = bm_sapl(j,isapabove)
bm_sapl(j,iheartabove) = 2. * bm_sapl(j,isapabove)
bm_sapl(j,iheartbelow) = 2. * bm_sapl(j,isapbelow)
ELSE
! 5.2 grasses
alpha = alpha_grass
IF ( natural(j) ) THEN
bm_sapl(j,ileaf) = 0.1 / sla(j)
ELSE
bm_sapl(j,ileaf) = 1.0 / sla(j)
ENDIF
bm_sapl(j,icarbres) = 5.*bm_sapl(j,ileaf)
bm_sapl(j,isapabove) = 0.
bm_sapl(j,isapbelow) = 0.
bm_sapl(j,iheartabove) = 0.
bm_sapl(j,iheartbelow) = 0.
ENDIF
bm_sapl(j,iroot) = 0.1 * (1./alpha) * bm_sapl(j,ileaf)
bm_sapl(j,ifruit) = 0.3 * bm_sapl(j,ileaf)
IF ( bavard .GE. 1 ) THEN
WRITE(numout,*) ' sapling biomass (gC):'
WRITE(numout,*) ' leaves:',bm_sapl(j,ileaf)
WRITE(numout,*) ' sap above ground:',bm_sapl(j,isapabove)
WRITE(numout,*) ' sap below ground:',bm_sapl(j,isapbelow)
WRITE(numout,*) ' heartwood above ground:',bm_sapl(j,iheartabove)
WRITE(numout,*) ' heartwood below ground:',bm_sapl(j,iheartbelow)
WRITE(numout,*) ' roots:',bm_sapl(j,iroot)
WRITE(numout,*) ' fruits:',bm_sapl(j,ifruit)
WRITE(numout,*) ' carbohydrate reserve:',bm_sapl(j,icarbres)
ENDIF
!
! 6 migration speed (m/year)
!
IF ( tree(j) ) THEN
migrate(j) = 10.*1.E3
ELSE
! can be any value as grasses are, per definitionem, everywhere (big leaf).
migrate(j) = 10.*1.E3
ENDIF
IF ( bavard .GE. 1 ) WRITE(numout,*) ' migration speed (m/year):', migrate(j)
!
! 7 critical stem diameter: beyond this diameter, the crown area no longer
! increases
!
IF ( tree(j) ) THEN
maxdia(j) = ( ( pipe_tune4 / ((pipe_tune2*pipe_tune3)/(100.**pipe_tune3)) ) &
** ( 1. / ( pipe_tune3 - 1. ) ) ) * 0.01
ELSE
maxdia(j) = undef
ENDIF
IF ( bavard .GE. 1 ) WRITE(numout,*) ' critical stem diameter (m):', maxdia(j)
!
! 8 Coldest tolerable temperature
!
IF ( ABS( tmin_crit_tab(j) - undef ) .GT. min_stomate ) THEN
tmin_crit(j) = tmin_crit_tab(j) + ZeroCelsius
ELSE
tmin_crit(j) = undef
ENDIF
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' coldest tolerable temperature (K):', tmin_crit(j)
!
! 9 Maximum temperature of the coldest month: need to be below this temperature
! for a certain time to regrow leaves next spring
!
IF ( ABS ( tcm_crit_tab(j) - undef ) .GT. min_stomate ) THEN
tcm_crit(j) = tcm_crit_tab(j) + ZeroCelsius
ELSE
tcm_crit(j) = undef
ENDIF
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' vernalization temperature (K):', tcm_crit(j)
!
! 10 critical values for phenology
!
! 10.1 model used
pheno_crit%pheno_model(j) = pheno_model_tab(j)
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' phenology model used: ',pheno_crit%pheno_model(j)
! 10.2 growing degree days. What kind of gdd is meant (i.e. threshold 0 or -5 deg C
! or whatever), depends on how this is used in stomate_phenology.
pheno_crit%gdd(j,1) = gdd_crit1_tab(j)
pheno_crit%gdd(j,2) = gdd_crit2_tab(j)
pheno_crit%gdd(j,3) = gdd_crit3_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( ALL(pheno_crit%gdd(j,:) .NE. undef) ) ) THEN
WRITE(numout,*) ' critical GDD is a function of long term T (C):'
WRITE(numout,*) ' ',pheno_crit%gdd(j,1), &
' + T *',pheno_crit%gdd(j,2), &
' + T^2 *',pheno_crit%gdd(j,3)
ENDIF
! consistency check
IF ( ( ( pheno_crit%pheno_model(j) .EQ. 'moigdd' ) .OR. &
( pheno_crit%pheno_model(j) .EQ. 'humgdd' ) ) .AND. &
( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) ) THEN
STOP 'problem with phenology parameters, critical GDD.'
ENDIF
! 10.3 number of growing days
pheno_crit%ngd(j) = ngd_crit_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%ngd(j) .NE. undef ) ) &
WRITE(numout,*) ' critical NGD:', pheno_crit%ngd(j)
! 10.4 critical temperature for ncd vs. gdd function in phenology
pheno_crit%ncdgdd_temp(j) = ncdgdd_temp_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%ncdgdd_temp(j) .NE. undef ) ) &
WRITE(numout,*) ' critical temperature for NCD vs. GDD (C):', &
pheno_crit%ncdgdd_temp(j)
! 10.5 humidity fractions
pheno_crit%hum_frac(j) = hum_frac_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%hum_frac(j) .NE. undef ) ) &
WRITE(numout,*) ' critical humidity fraction:', pheno_crit%hum_frac(j)
! 10.6 minimum time during which there was no photosynthesis
pheno_crit%lowgpp_time(j) = lowgpp_time_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%lowgpp_time(j) .NE. undef ) ) &
WRITE(numout,*) ' minimum dormance duration (d):', pheno_crit%lowgpp_time(j)
! 10.7 minimum time elapsed since moisture minimum (d)
pheno_crit%hum_min_time(j) = hum_min_time_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%hum_min_time(j) .NE. undef ) ) &
WRITE(numout,*) ' time to wait after moisture min (d):', pheno_crit%hum_min_time(j)
!
! 11 critical values for senescence
!
! 11.1 type of senescence
pheno_crit%senescence_type(j) = senescence_type_tab(j)
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' type of senescence: ',pheno_crit%senescence_type(j)
! 11.2 critical temperature for senescence
pheno_crit%senescence_temp(j,1) = senescence_temp1_tab(j)
pheno_crit%senescence_temp(j,2) = senescence_temp2_tab(j)
pheno_crit%senescence_temp(j,3) = senescence_temp3_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( ALL(pheno_crit%senescence_temp(j,:) .NE. undef) ) ) THEN
WRITE(numout,*) ' critical temperature for senescence (C) is'
WRITE(numout,*) ' a function of long term T (C):'
WRITE(numout,*) ' ',pheno_crit%senescence_temp(j,1), &
' + T *',pheno_crit%senescence_temp(j,2), &
' + T^2 *',pheno_crit%senescence_temp(j,3)
ENDIF
! consistency check
IF ( ( ( pheno_crit%senescence_type(j) .EQ. 'cold' ) .OR. &
( pheno_crit%senescence_type(j) .EQ. 'mixed' ) ) .AND. &
( ANY(pheno_crit%senescence_temp(j,:) .EQ. undef ) ) ) THEN
STOP 'problem with senescence parameters, temperature.'
ENDIF
! 11.3 critical relative moisture availability for senescence
pheno_crit%senescence_hum(j) = senescence_hum_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%senescence_hum(j) .NE. undef ) ) &
WRITE(numout,*) ' max. critical relative moisture availability for senescence:', &
pheno_crit%senescence_hum(j)
! consistency check
IF ( ( ( pheno_crit%senescence_type(j) .EQ. 'dry' ) .OR. &
( pheno_crit%senescence_type(j) .EQ. 'mixed' ) ) .AND. &
( pheno_crit%senescence_hum(j) .EQ. undef ) ) THEN
STOP 'problem with senescence parameters, humidity.'
ENDIF
! 14.3 relative moisture availability above which there is no moisture-related
! senescence
pheno_crit%nosenescence_hum(j) = nosenescence_hum_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%nosenescence_hum(j) .NE. undef ) ) &
WRITE(numout,*) ' relative moisture availability above which there is'
WRITE(numout,*) ' no moisture-related senescence:', &
pheno_crit%nosenescence_hum(j)
pheno_crit% max_turnover_time(j) = max_turnover_time_tab(j)
pheno_crit% min_turnover_time(j) = min_turnover_time_tab(j)
pheno_crit% min_leaf_age_for_senescence(j) = min_leaf_age_for_senescence_tab(j)
! consistency check
IF ( ( ( pheno_crit%senescence_type(j) .EQ. 'dry' ) .OR. &
( pheno_crit%senescence_type(j) .EQ. 'mixed' ) ) .AND. &
( pheno_crit%nosenescence_hum(j) .EQ. undef ) ) THEN
STOP 'problem with senescence parameters, humidity.'
ENDIF
!
! 12 sapwood -> heartwood conversion time
!
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' sapwood -> heartwood conversion time (d):', tau_sap(j)
!
! 13 fruit lifetime
!
IF ( bavard .GE. 1 ) WRITE(numout,*) ' fruit lifetime (d):', tau_fruit(j)
!
! 14 length of leaf death
! For evergreen trees, this variable determines the lifetime of the leaves.
! Note that it is different from the value given in leaflife_tab.
!
pheno_crit%leaffall(j) = leaffall_tab(j)
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' length of leaf death (d):', pheno_crit%leaffall(j)
!
! 15 maximum lifetime of leaves
!
pheno_crit%leafagecrit(j) = leafagecrit_tab(j)
IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%leafagecrit(j) .NE. undef ) ) &
WRITE(numout,*) ' critical leaf age (d):', pheno_crit%leafagecrit(j)
!
! 16 time constant for leaf age discretisation (d)
!
leaf_timecst(j) = pheno_crit%leafagecrit(j) / REAL( nleafages,r_std )
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' time constant for leaf age discretisation (d):', &
leaf_timecst(j)
!
! 17 minimum lai, initial
!
IF ( tree(j) ) THEN
pheno_crit%lai_initmin(j) = 0.3
ELSE
pheno_crit%lai_initmin(j) = 0.1
ENDIF
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' initial LAI:', pheno_crit%lai_initmin(j)
!
! 19 maximum LAI
!
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' critical LAI above which no leaf allocation:', lai_max(j)
!
! 20 fraction of primary leaf and root allocation put into reserve
!
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' reserve allocation factor:', ecureuil(j)
!
! 21 maintenance respiration coefficient (g/g/day) at 0 deg C
!
coeff_maint_zero(j,ileaf) = cm_zero_leaf_tab(j)
coeff_maint_zero(j,isapabove) = cm_zero_sapabove_tab(j)
coeff_maint_zero(j,isapbelow) = cm_zero_sapbelow_tab(j)
coeff_maint_zero(j,iheartabove) = cm_zero_heartabove_tab(j)
coeff_maint_zero(j,iheartbelow) = cm_zero_heartbelow_tab(j)
coeff_maint_zero(j,iroot) = cm_zero_root_tab(j)
coeff_maint_zero(j,ifruit) = cm_zero_fruit_tab(j)
coeff_maint_zero(j,icarbres) = cm_zero_carbres_tab(j)
IF ( bavard .GE. 1 ) THEN
WRITE(numout,*) ' maintenance respiration coefficient (g/g/day) at 0 deg C:'
WRITE(numout,*) ' . leaves: ',coeff_maint_zero(j,ileaf)
WRITE(numout,*) ' . sapwood above ground: ',coeff_maint_zero(j,isapabove)
WRITE(numout,*) ' . sapwood below ground: ',coeff_maint_zero(j,isapbelow)
WRITE(numout,*) ' . heartwood above ground: ',coeff_maint_zero(j,iheartabove)
WRITE(numout,*) ' . heartwood below ground: ',coeff_maint_zero(j,iheartbelow)
WRITE(numout,*) ' . roots: ',coeff_maint_zero(j,iroot)
WRITE(numout,*) ' . fruits: ',coeff_maint_zero(j,ifruit)
WRITE(numout,*) ' . carbohydrate reserve: ',coeff_maint_zero(j,icarbres)
ENDIF
!
! 22 parameter for temperature sensitivity of maintenance respiration
!
maint_resp_slope(j,1) = maint_resp_slope1_tab(j)
maint_resp_slope(j,2) = maint_resp_slope2_tab(j)
maint_resp_slope(j,3) = maint_resp_slope3_tab(j)
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' temperature sensitivity of maintenance respiration (1/K) is'
WRITE(numout,*) ' a function of long term T (C):'
WRITE(numout,*) ' ',maint_resp_slope(j,1),' + T *',maint_resp_slope(j,2), &
' + T^2 *',maint_resp_slope(j,3)
!
! 23 natural ?
!
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' Natural:', natural(j)
!
! 24 Vcmax et Vjmax
!
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' Maximum rate of carboxylation:', vcmax_opt(j)
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' Maximum rate of RUbp regeneration:', vjmax_opt(j)
!
! 25 constants for photosynthesis temperatures
!
t_photo%t_min_a(j) = tphoto_min_a_tab(j)
t_photo%t_min_b(j) = tphoto_min_b_tab(j)
t_photo%t_min_c(j) = tphoto_min_c_tab(j)
t_photo%t_opt_a(j) = tphoto_opt_a_tab(j)
t_photo%t_opt_b(j) = tphoto_opt_b_tab(j)
t_photo%t_opt_c(j) = tphoto_opt_c_tab(j)
t_photo%t_max_a(j) = tphoto_max_a_tab(j)
t_photo%t_max_b(j) = tphoto_max_b_tab(j)
t_photo%t_max_c(j) = tphoto_max_c_tab(j)
IF ( bavard .GE. 1 ) THEN
WRITE(numout,*) ' min. temperature for photosynthesis as a function of long term T (C):'
WRITE(numout,*) ' ',t_photo%t_min_c(j), &
' + T*',t_photo%t_min_b(j), &
' + T^2*',t_photo%t_min_a(j)
WRITE(numout,*) ' opt. temperature for photosynthesis as a function of long term T (C):'
WRITE(numout,*) ' ',t_photo%t_opt_c(j), &
' + T*',t_photo%t_opt_b(j), &
' + T^2*',t_photo%t_opt_a(j)
WRITE(numout,*) ' max. temperature for photosynthesis as a function of long term T (C):'
WRITE(numout,*) ' ',t_photo%t_max_c(j), &
' + T*',t_photo%t_max_b(j), &
' + T^2*',t_photo%t_max_a(j)
ENDIF
!
! 26 corresponding PFT number in Sechiba
!
IF ( bavard .GE. 1 ) THEN
WRITE(numout,*) ' corresponding PFT number in Sechiba:', ipft_sechiba(j)
WRITE(numout,*) ' Slope of the gs/A relation:', &
gsslope(ipft_sechiba(j))
WRITE(numout,*) ' Intercept of the gs/A relation:', &
gsoffset(ipft_sechiba(j))
WRITE(numout,*) ' C4 photosynthesis:', is_c4(ipft_sechiba(j))
WRITE(numout,*) ' Depth constant for root profile (m):', &
1./humcste(ipft_sechiba(j))
ENDIF
!
! 27 extinction coefficient of the Monsi&Seaki (53) relationship
!
ext_coeff(j) = ext_coef(ipft_sechiba(j))
IF ( bavard .GE. 1 ) THEN
WRITE(numout,*) ' extinction coefficient:', ext_coeff(j)
ENDIF
!
! 28 check coherence between tree definitions
! this is not absolutely necessary (just security)
!
IF ( tree(j) .NEQV. is_tree(ipft_sechiba(j)) ) THEN
STOP 'Definition of tree/not tree not coherent'
ENDIF
ENDDO
!
! 29 time scales for phenology and other processes (in days)
!
pheno_crit%tau_hum_month = 20. ! (!)
pheno_crit%tau_hum_week = 7.
pheno_crit%tau_t2m_month = 20. ! (!)
pheno_crit%tau_t2m_week = 7.
pheno_crit%tau_tsoil_month = 20. ! (!)
pheno_crit%tau_soilhum_month = 20. ! (!)
pheno_crit%tau_gpp_week = 7.
pheno_crit%tau_gdd = 40.
pheno_crit%tau_ngd = 50.
pheno_crit%tau_longterm = 3. * one_year
IF ( bavard .GE. 1 ) THEN
WRITE(numout,*) ' > time scale for ''monthly'' moisture availability (d):', &
pheno_crit%tau_hum_month
WRITE(numout,*) ' > time scale for ''weekly'' moisture availability (d):', &
pheno_crit%tau_hum_week
WRITE(numout,*) ' > time scale for ''monthly'' 2 meter temperature (d):', &
pheno_crit%tau_t2m_month
WRITE(numout,*) ' > time scale for ''weekly'' 2 meter temperature (d):', &
pheno_crit%tau_t2m_week
WRITE(numout,*) ' > time scale for ''weekly'' GPP (d):', &
pheno_crit%tau_gpp_week
WRITE(numout,*) ' > time scale for ''monthly'' soil temperature (d):', &
pheno_crit%tau_tsoil_month
WRITE(numout,*) ' > time scale for ''monthly'' soil humidity (d):', &
pheno_crit%tau_soilhum_month
WRITE(numout,*) ' > time scale for vigour calculations (y):', &
pheno_crit%tau_longterm / one_year
ENDIF
!
! 30 fraction of allocatable biomass which is lost as growth respiration
!
IF ( bavard .GE. 1 ) &
WRITE(numout,*) ' > growth respiration fraction:', frac_growthresp
!
! 31 count number of Stomate-PFTs that correpond to each Sechiba-PFT. Normally result
! is 1 for plants, except if we introduce age classes in Stomate and not in Sechiba.
!
DO j = 1, nvm
npft_stomate(j) = COUNT( ipft_sechiba(:) .EQ. j )
IF ( bavard .GE. 1 ) &
WRITE(numout,'(a,i2,a,i2,a)') ' > Sechiba-PFT #',j,' corresponds to ',&
npft_stomate(j),' Stomate-PFTs.'
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving data'
END SUBROUTINE data
END MODULE stomate_data
ORCHIDEE/src_stomate/stomate_deforestation.f90 0000754 0103600 0005670 00000033062 11164403473 021176 0 ustar acamlmd lmdjus !
! update/completion by P. Smith
!
! Stomate: deforestation
!
! authors: M. Boisserie, P. Friedlingstein
!
!
!
! version 0.0: May 2003
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_deforestation.f90,v 1.5 2007/06/13 07:55:43 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_deforestation
! modules used:
USE ioipsl
USE stomate_constants
USE stomate_data
IMPLICIT NONE
PRIVATE
PUBLIC deforestation
CONTAINS
SUBROUTINE deforestation(npts, dt_days, space_nat, space_nat_new, veget_max, veget_max_new,&
biomass, ind, age, PFTpresent, senescence, when_growthinit, everywhere, veget,&
co2_to_bm, bm_to_litter, bm_sapl, tree, cn_ind,flux10,flux100, &
prod10,prod100,prod10_total,prod100_total,&
convflux,cflux_prod_total,cflux_prod10,cflux_prod100, leaf_frac,&
npp_longterm, lm_lastyearmax)
! 0 declarations
! 0.1 input
! Domain size
INTEGER, INTENT(in) :: npts
! Time step (days)
REAL(r_std), INTENT(in) :: dt_days
! new "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max_new
! biomass of sapling (gC)
REAL(r_std) , DIMENSION (npft, nparts), INTENT(in) :: bm_sapl
! is pft a tree
LOGICAL, DIMENSION(npft), INTENT(in) :: tree
! 0.2 modified fields
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: space_nat
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat_new
! fractional coverage on natural/agricultural ground, taking into
! account LAI (=grid-scale fpc)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! density of individuals 1/m**2
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
! mean age (years)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
! set to .FALSE. if PFT is introduced or killed
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: senescence
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
! is the PFT everywhere in the grid box or very localized (after its introduction)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
! how many days ago was the beginning of the growing season
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
! biomass uptaken (gC/(m**2 of total ground)/day)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: co2_to_bm
! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
! crown area (m**2) per ind.
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: cn_ind
! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
! (10 or 100 + 1 : input from year of deforestation)
REAL(r_std), DIMENSION(npts,0:10), INTENT(inout) :: prod10
REAL(r_std), DIMENSION(npts,0:100), INTENT(inout) :: prod100
! annual release from the 10/100 year-turnover pool compartments
REAL(r_std), DIMENSION(npts,10), INTENT(inout) :: flux10
REAL(r_std), DIMENSION(npts,100), INTENT(inout) :: flux100
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_lastyearmax
! "long term" net primary productivity (gC/(m**2 of nat/agri ground)/year)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: npp_longterm
! 0.3 output
! release during first year following deforestation
REAL(r_std), DIMENSION(npts), INTENT(out) :: convflux
! total annual release from the 10/100 year-turnover pool
REAL(r_std), DIMENSION(npts), INTENT(out) :: cflux_prod10, cflux_prod100
! total products remaining in the pool after the annual release
REAL(r_std), DIMENSION(npts), INTENT(out) :: prod10_total, prod100_total
! total flux from conflux and the 10/100 year-turnover pool
REAL(r_std), DIMENSION(npts), INTENT(out) :: cflux_prod_total
! 0.4 local
! indices
INTEGER(i_std) :: i, j, k, l, m
! biomass increase (gC/(m**2 of nat/agri ground))
REAL(r_std),DIMENSION(npts) :: bm_new
! change in number of individuals /m2 per year
REAL(r_std),DIMENSION(npts,npft) :: d_ind
REAL(r_std) :: x,above
REAL(r_std),DIMENSION(npft) :: y,z
REAL(r_std), DIMENSION(npts,npft) :: vegetspace
REAL(r_std), DIMENSION(npts,npft) :: vegetspace_new
! =========================================================================
! yearly initialisation
prod10(:,0) = zero
prod100(:,0) = zero
above = zero
convflux(:) = zero
cflux_prod10(:) = zero
cflux_prod100(:) = zero
prod10_total(:) = zero
prod100_total(:) = zero
cflux_prod_total(:) = zero
bm_new(:) = zero
DO i = 1, npts
DO j = 1, npft
IF( natural(j) ) THEN
vegetspace(i,j) = veget_max(i,j) * space_nat(i)
vegetspace_new(i,j) = veget_max_new(i,j) * space_nat_new(i)
ELSE
vegetspace(i,j) = veget_max(i,j) *(1. - space_nat(i))
vegetspace_new(i,j) = veget_max_new(i,j) *(1. - space_nat_new(i))
ENDIF
! in case of establishment of a new PFT or extension of its coverage in a gridcell
IF ( vegetspace_new(i,j) .GT. vegetspace(i,j) ) THEN
IF ( tree(j) ) THEN
IF ( abs(cn_ind(i,j)) > 1e-16) THEN
d_ind(i,j) = (vegetspace_new(i,j) - vegetspace(i,j)) / cn_ind (i,j)
ELSE
write(numout,*) "deforestation : cn_ind est nul pour i,j = ",i,j
d_ind(i,j) = zero
ENDIF
ELSE
d_ind(i,j) = vegetspace_new(i,j) - vegetspace(i,j)
ENDIF
DO k = 1, nparts
bm_new(i) = d_ind(i,j) * bm_sapl(j,k)
biomass(i,j,k) = biomass(i,j,k) + bm_new(i)
IF( natural(j) ) THEN
co2_to_bm(i) = co2_to_bm(i) + bm_new(i) * space_nat_new(i) / one_year * dt_days
ELSE
co2_to_bm(i) = co2_to_bm(i) + bm_new(i) * (1.-space_nat_new(i)) / one_year * dt_days
ENDIF
ENDDO
PFTpresent(i,j) = .TRUE.
everywhere(i,j) = 1.
senescence(i,j) = .FALSE.
age(i,j) = 0.
ind(i,j) = veget_max_new (i,j)
when_growthinit(:,j) = large_value
leaf_frac(:,j,1) = 1.0
npp_longterm(:,j) = 10.
lm_lastyearmax(:,j) = bm_sapl(j,ileaf) * ind(:,j)
ENDIF ! End if PFT extension
! in case of total or fractional disparition or a PFT
IF ( vegetspace_new(i,j) .LT. vegetspace(i,j)) THEN
x = 40./67.
y(1) = 27./67.
y(2) = 27./67.
y(9) = 27./67.
y(3) = 20./67.
y(4) = 20./67.
y(5) = 20./67.
y(6) = 20./67.
y(7) = 20./67.
y(8) = 20./67.
y(10)= 20./67.
y(11)= 20./67.
z(3) = 7./67.
z(4) = 7./67.
z(5) = 7./67.
z(6) = 7./67.
z(7) = 7./67.
z(8) = 7./67.
z(11)= 7./67.
z(12)= 7./67.
z(1) = 0.
z(2) = 0.
z(9) = 0.
IF ( vegetspace_new(i,j) .EQ. 0. ) THEN
IF (.NOT. tree(j) ) THEN
ind(i,j) = 0.0
bm_to_litter(i,j,:) = bm_to_litter(i,j,:) + biomass(i,j,:)
biomass(i,j,:) = 0.0
ELSE
ind(i,j) = 0.0
cn_ind(i,j) = 0.0
above = biomass(i,j,1) + biomass(i,j,2) + &
biomass(i,j,4)
convflux(i) = convflux(i) + x * above
prod10(i,0) = prod10(i,0) + y(j) * above
prod100(i,0) = prod100(i,0) + z(j) * above
bm_to_litter(i,j,3) = bm_to_litter(i,j,3) + biomass(i,j,3)
bm_to_litter(i,j,5) = bm_to_litter(i,j,5) + biomass(i,j,5)
bm_to_litter(i,j,6) = bm_to_litter(i,j,6) + biomass(i,j,6)
bm_to_litter(i,j,7) = bm_to_litter(i,j,7) + biomass(i,j,7)
bm_to_litter(i,j,8) = bm_to_litter(i,j,8) + biomass(i,j,8)
biomass(i,j,:) = 0.0
ENDIF
PFTpresent(i,j) = .FALSE.
senescence(i,j) = .FALSE.
age(i,j) = 0.0
when_growthinit(i,j) = undef
everywhere(i,j) = 0.0
veget(i,j) = 0.0
ELSE
d_ind(i,j) = vegetspace(i,j) - vegetspace_new(i,j)
IF (.NOT. tree (j)) THEN
bm_to_litter(i,j,:) = bm_to_litter(i,j,:) + &
biomass(i,j,:) * d_ind(i,j) / veget_max(i,j)
biomass(i,j,:) = biomass(i,j,:) * (1. - d_ind(i,j)/veget_max(i,j))
ind(i,j) = ind(i,j) * (1. - d_ind(i,j))
ELSE
above =(biomass(i,j,1) + biomass(i,j,2) + biomass(i,j,4)) * d_ind(i,j)/veget_max(i,j)
convflux(i) = convflux(i) + x * above
prod10(i,0) = prod10(i,0) + y(j) * above
prod100(i,0) = prod100(i,0) + z(j) * above
bm_to_litter(i,j,3) = bm_to_litter(i,j,3) + &
biomass(i,j,3)* d_ind(i,j)/vegetspace(i,j)
bm_to_litter(i,j,5) = bm_to_litter(i,j,5) + &
biomass(i,j,5)* d_ind(i,j)/vegetspace(i,j)
bm_to_litter(i,j,6) = bm_to_litter(i,j,6) + &
biomass(i,j,6)* d_ind(i,j)/vegetspace(i,j)
bm_to_litter(i,j,7) = bm_to_litter(i,j,7) + &
biomass(i,j,7)* d_ind(i,j)/vegetspace(i,j)
bm_to_litter(i,j,8) = bm_to_litter(i,j,8) + &
biomass(i,j,8)* d_ind(i,j) /vegetspace(i,j)
biomass(i,j,:) = biomass(i,j,:) * ( 1. - d_ind(i,j))/vegetspace(i,j)
ENDIF
ENDIF ! End if PFT total disparition
ENDIF ! End if PFT's coverage reduction
ENDDO ! End loop on PFTs
! each year, update 10 year-turnover pool content following flux emission
! (linear decay (10%) of the initial carbon input)
DO l = 0, 8
m = 10 - l
cflux_prod10(i) = cflux_prod10(i) + flux10(i,m)
prod10(i,m) = prod10(i,m-1) - flux10(i,m-1)
prod10_total(i) = prod10_total(i) + prod10(i,m)
flux10(i,m) = flux10(i,m-1)
IF (prod10(i,m) .LT. 1.0) prod10(i,m) = 0.0
ENDDO
cflux_prod10(i) = cflux_prod10(i) + flux10(i,1)
flux10(i,1) = 0.1 * prod10(i,0)
prod10(i,1) = prod10(i,0)
prod10_total(i) = prod10_total(i) + prod10(i,1)
DO l = 0, 98
m = 100 - l
cflux_prod100(i) = cflux_prod100(i) + flux100(i,m)
prod100(i,m) = prod100(i,m-1) - flux100(i,m-1)
prod100_total(i) = prod100_total(i) + prod100(i,m)
flux100(i,m) = flux100(i,m-1)
IF (prod100(i,m).LT.1.0) prod100(i,m) = 0.0
ENDDO
cflux_prod100(i) = cflux_prod100(i) + flux100(i,1)
flux100(i,1) = 0.01 * prod100(i,0)
prod100(i,1) = prod100(i,0)
prod100_total(i) = prod100_total(i) + prod100(i,1)
cflux_prod_total(i) = convflux(i) + cflux_prod10(i) + cflux_prod100(i)
prod10(i,0) = 0.0
prod100(i,0) = 0.0
ENDDO ! End loop on npts
space_nat(:) = space_nat_new(:)
veget_max(:,:) = veget_max_new(:,:)
! convert flux from /year into /time step
convflux = convflux/one_year*dt_days
cflux_prod10 = cflux_prod10/one_year*dt_days
cflux_prod100 = cflux_prod100/one_year*dt_days
END SUBROUTINE deforestation
END MODULE stomate_deforestation
ORCHIDEE/src_stomate/stomate_io.f90 0000754 0103600 0005670 00000227421 11164403473 016743 0 ustar acamlmd lmdjus ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_io.f90,v 1.16 2007/06/13 07:53:08 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_io
!---------------------------------------------------------------------
!- Not all variables saved in the start files are absolutely necessary.
!- Some variables may seem totally unnecessary (fvm and fv),
!- as the necessary information already exists in Sechiba.
!- However, Sechiba's and Stomate's PFTs are not necessarily identical,
!- and for that case this information needs to be saved.
!---------------------------------------------------------------------
USE ioipsl
USE stomate_constants
USE parallel
!-
IMPLICIT NONE
!-
PRIVATE
PUBLIC readstart, writerestart, readbc,get_reftemp_clear
!-
! first call?
!-
LOGICAL,SAVE :: firstcall = .TRUE.
!-
! reference temperature (K)
!-
REAL(r_std),ALLOCATABLE,DIMENSION(:),SAVE :: trefe
!-
CONTAINS
!-
!===
!-
SUBROUTINE readstart &
& (npts, index, lalo, resolution, day_counter, dt_days, date, &
& ind, adapted, regenerate, moiavail_daily, litterhum_daily, &
& t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
& soilhum_daily, precip_daily, &
& gpp_daily, npp_daily, turnover_daily, &
& moiavail_month, moiavail_week, t2m_longterm, tlong_ref, &
& t2m_month, t2m_week, tsoil_month, soilhum_month, &
& fireindex, firelitter, &
& maxmoiavail_lastyear, maxmoiavail_thisyear, &
& minmoiavail_lastyear, minmoiavail_thisyear, &
& maxgppweek_lastyear, maxgppweek_thisyear, &
& gdd0_lastyear, gdd0_thisyear, precip_lastyear, precip_thisyear, &
& gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
& PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
& maxfpc_lastyear, maxfpc_thisyear, &
& turnover_longterm, gpp_week, biomass, resp_maint_part, &
& fvm, fv, leaf_age, leaf_frac, senescence, when_growthinit, age, &
& resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
& veget_lastlight, everywhere, need_adjacent, RIP_time, &
& time_lowgpp, time_hum_min, hum_min_dormance, litterpart, litter, &
& dead_leaves, carbon, black_carbon, lignin_struc,turnover_time, &
& prod10,prod100,flux10, flux100)
! deforestation variables added as arguments
!---------------------------------------------------------------------
!- read start file
!---------------------------------------------------------------------
!-
! 0 declarations
!-
! 0.1 input
!-
! Domain size
INTEGER(i_std),INTENT(in) :: npts
! Indices of the points on the map
INTEGER(i_std),DIMENSION(npts),INTENT(in) :: index
! Geogr. coordinates (latitude,longitude) (degrees)
REAL(r_std),DIMENSION(npts,2),INTENT(in) :: lalo
! size in x an y of the grid (m)
REAL(r_std),DIMENSION(npts,2),INTENT(in) :: resolution
!-
! 0.2 output
!-
! counts time until next STOMATE time step
REAL(r_std),INTENT(out) :: day_counter
! time step of STOMATE in days
REAL(r_std),INTENT(out) :: dt_days
! date (d)
INTEGER(i_std),INTENT(out) :: date
! density of individuals (1/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: ind
! Winter too cold? between 0 and 1
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: adapted
! Winter sufficiently cold? between 0 and 1
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: regenerate
! daily moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: moiavail_daily
! daily litter humidity
REAL(r_std),DIMENSION(npts),INTENT(out) :: litterhum_daily
! daily 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_daily
! daily minimum 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_min_daily
! daily surface temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(out) :: tsurf_daily
! daily soil temperatures (K)
REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: tsoil_daily
! daily soil humidity
REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: soilhum_daily
! daily precipitations (mm/day) (for phenology)
REAL(r_std),DIMENSION(npts),INTENT(out) :: precip_daily
! daily gross primary productivity (gC/m**2/day)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: gpp_daily
! daily net primary productivity (gC/m**2/day)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: npp_daily
! daily turnover rates (gC/m**2/day)
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(out) :: turnover_daily
! "monthly" moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: moiavail_month
! "weekly" moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: moiavail_week
! "long term" 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_longterm
! "monthly" 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_month
! "weekly" 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_week
! "monthly" soil temperatures (K)
REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: tsoil_month
! "monthly" soil humidity
REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: soilhum_month
! Probability of fire
REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(out) :: fireindex
! Longer term total litter above the ground, gC/m**2 of nat/agri ground
REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(out) :: firelitter
! last year's maximum moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxmoiavail_lastyear
! this year's maximum moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxmoiavail_thisyear
! last year's minimum moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: minmoiavail_lastyear
! this year's minimum moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: minmoiavail_thisyear
! last year's maximum weekly GPP
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxgppweek_lastyear
! this year's maximum weekly GPP
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxgppweek_thisyear
! last year's annual GDD0
REAL(r_std),DIMENSION(npts),INTENT(out) :: gdd0_lastyear
! this year's annual GDD0
REAL(r_std),DIMENSION(npts),INTENT(out) :: gdd0_thisyear
! last year's annual precipitation (mm/year)
REAL(r_std),DIMENSION(npts),INTENT(out) :: precip_lastyear
! this year's annual precipitation (mm/year)
REAL(r_std),DIMENSION(npts),INTENT(out) :: precip_thisyear
! growing degree days, threshold -5 deg C (for phenology)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: gdd_m5_dormance
! growing degree days since midwinter (for phenology)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: gdd_midwinter
! number of chilling days since leaves were lost (for phenology)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: ncd_dormance
! number of growing days, threshold -5 deg C (for phenology)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: ngd_minus5
! PFT exists (equivalent to fpc_max > 0 for natural PFTs)
LOGICAL,DIMENSION(npts,npft),INTENT(out) :: PFTpresent
! "long term" net primary productivity (gC/m**2/year)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: npp_longterm
! last year's maximum leaf mass, for each PFT (gC/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: lm_lastyearmax
! this year's maximum leaf mass, for each PFT (gC/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: lm_thisyearmax
! last year's maximum fpc for each natural PFT, on *natural* ground
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxfpc_lastyear
! this year's maximum fpc for each PFT,
! on *total* ground (see stomate_season)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxfpc_thisyear
! "long term" turnover rate (gC/m**2/year)
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(out) :: turnover_longterm
! "weekly" GPP (gC/day/(m**2 covered)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: gpp_week
! biomass (gC/m**2)
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(out) :: biomass
! maintenance resp (gC/m**2)
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(out) :: resp_maint_part
! factor to convert veget_x into veget
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: fv
! factor to convert veget_max_x into veget_max
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: fvm
! leaf age (days)
REAL(r_std),DIMENSION(npts,npft,nleafages),INTENT(out) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std),DIMENSION(npts,npft,nleafages),INTENT(out) :: leaf_frac
! is the plant senescent ?
!(only for deciduous trees - carbohydrate reserve)
LOGICAL,DIMENSION(npts,npft),INTENT(out) :: senescence
! how many days ago was the beginning of the growing season
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: when_growthinit
! mean age (years)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: age
! heterotrophic respiration (gC/day/m**2)
REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(out) :: resp_hetero
! maintenance respiration (gC/day/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: resp_maint
! growth respiration (gC/day/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: resp_growth
! carbon emitted into the atmosphere by fire (living and dead biomass)
! (in gC/m**2/time step)
REAL(r_std),DIMENSION(npts),INTENT(out) :: co2_fire
! biomass uptaken (gC/(m**2 of total ground)/day)
REAL(r_std),DIMENSION(npts),INTENT(out) :: co2_to_bm_dgvm
! vegetation fractions
! (on natural/agri ground) after last light competition
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: veget_lastlight
! is the PFT everywhere in the grid box or very localized
! (after its introduction)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: everywhere
! in order for this PFT to be introduced,
! does it have to be present in an adjacent grid box?
LOGICAL,DIMENSION(npts,npft),INTENT(out) :: need_adjacent
! How much time ago was the PFT eliminated for the last time (y)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: RIP_time
! duration of dormance (d)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: time_lowgpp
! time elapsed since strongest moisture availability (d)
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: time_hum_min
! minimum moisture during dormance
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: hum_min_dormance
! fraction of litter above the ground belonging to different PFTs
! separated for natural and agricultural PFTs.
REAL(r_std),DIMENSION(npts,npft,nlitt),INTENT(out) :: litterpart
! metabolic and structural litter, natural and agricultural,
! above and below ground (gC/m**2)
REAL(r_std),DIMENSION(npts,nlitt,nvegtypes,nlevs),INTENT(out):: litter
! dead leaves on ground, per PFT, metabolic and structural,
! in gC/(m**2 of nat/agri ground)
REAL(r_std),DIMENSION(npts,npft,nlitt),INTENT(out) :: dead_leaves
! carbon pool: active, slow, or passive, natural and agricultural
! (gC/m**2)
REAL(r_std),DIMENSION(npts,ncarb,nvegtypes),INTENT(out) :: carbon
! black carbon on the ground (gC/(m**2 of total ground))
REAL(r_std),DIMENSION(npts),INTENT(out) :: black_carbon
! ratio Lignine/Carbon in structural litter, above and below ground,
! natural and agricultural (gC/m**2)
REAL(r_std),DIMENSION(npts,nvegtypes,nlevs),INTENT(out) :: lignin_struc
REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: turnover_time
!-
! 0.3 not necessarily output
!-
! "long term" reference 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(inout) :: tlong_ref
!-
! 0.4 local
!-
! date, real
REAL(r_std) :: date_real
! PFT exists (equivalent to fpc_max > 0 for natural PFTs), real
REAL(r_std),DIMENSION(npts,npft) :: PFTpresent_real
! is the plant senescent ?
! (only for deciduous trees - carbohydrate reserve), real
REAL(r_std),DIMENSION(npts,npft) :: senescence_real
! in order for this PFT to be introduced,
! does it have to be present in an adjacent grid box? - real
REAL(r_std),DIMENSION(npts,npft) :: need_adjacent_real
! To store variables names for I/O
CHARACTER(LEN=80) :: var_name
! string suffix indicating an index
CHARACTER(LEN=10) :: part_str
! string suffix indicating litter type
CHARACTER(LEN=3),DIMENSION(nlitt) :: litter_str
! string suffix indicating vegetation type
CHARACTER(LEN=3),DIMENSION(nvegtypes) :: vegtype_str
! string suffix indicating level
CHARACTER(LEN=2),DIMENSION(nlevs) :: level_str
! temporary storage
REAL(r_std),DIMENSION(1) :: xtmp
! index
INTEGER(i_std) :: k,l,m
! reference temperature (K)
REAL(r_std),DIMENSION(npts) :: tref
! deforestation variables
! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
! (10 or 100 + 1 : input from year of deforestation)
REAL(r_std),DIMENSION(npts,0:10),INTENT(out) :: prod10
REAL(r_std),DIMENSION(npts,0:100),INTENT(out) :: prod100
! annual release from the 10/100 year-turnover pool compartments
REAL(r_std),DIMENSION(npts,10),INTENT(out) :: flux10
REAL(r_std),DIMENSION(npts,100),INTENT(out) :: flux100
!---------------------------------------------------------------------
IF (bavard >= 3) WRITE(numout,*) 'Entering readstart'
!-
! 0 When the vegetation is dynamic,
! the long-term reference temperature is prognostic.
! In this case, it is read from the restart file.
! If the corresponding field does not exist in the restart file,
! read it from another file in order to initialize it correctly.
!-
CALL get_reftemp( npts, lalo, resolution, tref )
!-
! 1 string definitions
!-
DO m=1,nvegtypes
IF (m == inat) THEN
vegtype_str(m) = 'nat'
ELSEIF (m == iagri) THEN
vegtype_str(m) = 'agr'
ELSE
STOP 'Define vegtype_str'
ENDIF
ENDDO
!-
DO l=1,nlitt
IF (l == imetabolic) THEN
litter_str(l) = 'met'
ELSEIF (l == istructural) THEN
litter_str(l) = 'str'
ELSE
STOP 'Define litter_str'
ENDIF
ENDDO
!-
DO l=1,nlevs
IF (l == iabove) THEN
level_str(l) = 'ab'
ELSEIF (l == ibelow) THEN
level_str(l) = 'be'
ELSE
STOP 'Define level_str'
ENDIF
ENDDO
!-
! 2 run control
!-
! 2.1 day counter
!-
IF (is_root_prc) THEN
var_name = 'day_counter'
CALL restget (rest_id_stomate, var_name, 1 , 1 , 1, itime, &
& .TRUE., xtmp)
day_counter = xtmp(1)
IF (day_counter == val_exp) day_counter = 1.
ENDIF
CALL bcast(day_counter)
!-
! 2.2 time step of STOMATE in days
!-
IF (is_root_prc) THEN
var_name = 'dt_days'
CALL restget (rest_id_stomate, var_name, 1 , 1 , 1, itime, &
& .TRUE., xtmp)
dt_days = xtmp(1)
IF (dt_days == val_exp) dt_days = 1.
ENDIF
CALL bcast(dt_days)
!-
! 2.3 date
!-
IF (is_root_prc) THEN
var_name = 'date'
CALL restget (rest_id_stomate, var_name, 1 , 1 , 1, itime, &
& .TRUE., xtmp)
date_real = xtmp(1)
IF (date_real == val_exp) date_real = 0.
date = NINT(date_real)
ENDIF
CALL bcast(date_real)
!-
! 3 daily meteorological variables
!-
moiavail_daily(:,:) = val_exp
var_name = 'moiavail_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., moiavail_daily, 'gather', nbp_glo, index_g)
IF (ALL(moiavail_daily(:,:) == val_exp)) moiavail_daily(:,:) = 0.0
!-
litterhum_daily(:) = val_exp
var_name = 'litterhum_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., litterhum_daily, 'gather', nbp_glo, index_g)
IF (ALL(litterhum_daily(:) == val_exp)) litterhum_daily(:) = 0.0
!-
t2m_daily(:) = val_exp
var_name = 't2m_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., t2m_daily, 'gather', nbp_glo, index_g)
IF (ALL(t2m_daily(:) == val_exp)) t2m_daily(:) = 0.0
!-
t2m_min_daily(:) = val_exp
var_name = 't2m_min_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., t2m_min_daily, 'gather', nbp_glo, index_g)
IF (ALL(t2m_min_daily(:) == val_exp)) t2m_min_daily(:) = large_value
!-
tsurf_daily(:) = val_exp
var_name = 'tsurf_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., tsurf_daily, 'gather', nbp_glo, index_g)
IF (ALL(tsurf_daily(:) == val_exp)) tsurf_daily(:) = tref(:)
!-
tsoil_daily(:,:) = val_exp
var_name = 'tsoil_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
& .TRUE., tsoil_daily, 'gather', nbp_glo, index_g)
IF (ALL(tsoil_daily(:,:) == val_exp)) tsoil_daily(:,:) = 0.0
!-
soilhum_daily(:,:) = val_exp
var_name = 'soilhum_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
& .TRUE., soilhum_daily, 'gather', nbp_glo, index_g)
IF (ALL(soilhum_daily(:,:) == val_exp)) soilhum_daily(:,:) = 0.0
!-
precip_daily(:) = val_exp
var_name = 'precip_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., precip_daily, 'gather', nbp_glo, index_g)
IF (ALL(precip_daily(:) == val_exp)) precip_daily(:) = 0.0
!-
! 4 productivities
!-
gpp_daily(:,:) = val_exp
var_name = 'gpp_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., gpp_daily, 'gather', nbp_glo, index_g)
IF (ALL(gpp_daily(:,:) == val_exp)) gpp_daily(:,:) = 0.0
!-
npp_daily(:,:) = val_exp
var_name = 'npp_daily'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., npp_daily, 'gather', nbp_glo, index_g)
IF (ALL(npp_daily(:,:) == val_exp)) npp_daily(:,:) = 0.0
!-
turnover_daily(:,:,:) = val_exp
DO k=1,nparts
WRITE(part_str,'(I2)') k
IF (k < 10) part_str(1:1) = '0'
var_name = 'turnover_daily_'//part_str(1:LEN_TRIM(part_str))
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., turnover_daily(:,:,k), 'gather', nbp_glo, index_g)
IF (ALL(turnover_daily(:,:,k) == val_exp)) &
& turnover_daily(:,:,k) = 0.0
ENDDO
!-
! 5 monthly meteorological variables
!-
moiavail_month(:,:) = val_exp
var_name = 'moiavail_month'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., moiavail_month, 'gather', nbp_glo, index_g)
IF (ALL(moiavail_month(:,:) == val_exp)) moiavail_month(:,:) = 0.0
!-
moiavail_week(:,:) = val_exp
var_name = 'moiavail_week'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., moiavail_week, 'gather', nbp_glo, index_g)
IF (ALL(moiavail_week(:,:) == val_exp)) moiavail_week(:,:) = 0.0
!-
t2m_longterm(:) = val_exp
var_name = 't2m_longterm'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., t2m_longterm, 'gather', nbp_glo, index_g)
IF (ALL(t2m_longterm(:) == val_exp)) t2m_longterm(:) = tref(:)
!-
! the long-term reference temperature is a prognostic variable
! only in case the vegetation is dynamic
!-
IF (control%ok_dgvm) THEN
tlong_ref(:) = val_exp
var_name = 'tlong_ref'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., tlong_ref, 'gather', nbp_glo, index_g)
IF (ALL(tlong_ref(:) == val_exp)) tlong_ref(:) = tref(:)
ENDIF
!-
t2m_month(:) = val_exp
var_name = 't2m_month'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., t2m_month, 'gather', nbp_glo, index_g)
IF (ALL(t2m_month(:) == val_exp)) t2m_month(:) = tref(:)
!-
t2m_week(:) = val_exp
var_name = 't2m_week'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., t2m_week, 'gather', nbp_glo, index_g)
IF (ALL(t2m_week(:) == val_exp)) t2m_week(:) = tref(:)
!-
tsoil_month(:,:) = val_exp
var_name = 'tsoil_month'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
& .TRUE., tsoil_month, 'gather', nbp_glo, index_g)
IF (ALL(tsoil_month(:,:) == val_exp)) THEN
DO l=1,nbdl
tsoil_month(:,l) = tref(:)
ENDDO
ENDIF
!-
soilhum_month(:,:) = val_exp
var_name = 'soilhum_month'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
& .TRUE., soilhum_month, 'gather', nbp_glo, index_g)
IF (ALL(soilhum_month(:,:) == val_exp)) soilhum_month(:,:) = 0.0
!-
! 6 fire probability
!-
fireindex(:,:) = val_exp
var_name = 'fireindex'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
& .TRUE., fireindex, 'gather', nbp_glo, index_g)
IF (ALL(fireindex(:,:) == val_exp)) fireindex(:,:) = 0.0
!-
firelitter(:,:) = val_exp
var_name = 'firelitter'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
& .TRUE., firelitter, 'gather', nbp_glo, index_g)
IF (ALL(firelitter(:,:) == val_exp)) firelitter(:,:) = 0.0
!-
! 7 maximum and minimum moisture availabilities for tropic phenology
!-
maxmoiavail_lastyear(:,:) = val_exp
var_name = 'maxmoistr_last'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., maxmoiavail_lastyear, 'gather', nbp_glo, index_g)
IF (ALL(maxmoiavail_lastyear(:,:) == val_exp)) &
& maxmoiavail_lastyear(:,:) = 0.0
!-
maxmoiavail_thisyear(:,:) = val_exp
var_name = 'maxmoistr_this'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., maxmoiavail_thisyear, 'gather', nbp_glo, index_g)
IF (ALL(maxmoiavail_thisyear(:,:) == val_exp)) &
& maxmoiavail_thisyear(:,:) = 0.0
!-
minmoiavail_lastyear(:,:) = val_exp
var_name = 'minmoistr_last'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., minmoiavail_lastyear, 'gather', nbp_glo, index_g)
IF (ALL(minmoiavail_lastyear(:,:) == val_exp)) &
& minmoiavail_lastyear(:,:) = 1.0
!-
minmoiavail_thisyear(:,:) = val_exp
var_name = 'minmoistr_this'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., minmoiavail_thisyear, 'gather', nbp_glo, index_g)
IF (ALL( minmoiavail_thisyear(:,:) == val_exp)) &
& minmoiavail_thisyear(:,:) = 1.0
!-
! 8 maximum "weekly" GPP
!-
maxgppweek_lastyear(:,:) = val_exp
var_name = 'maxgppweek_lastyear'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., maxgppweek_lastyear, 'gather', nbp_glo, index_g)
IF (ALL(maxgppweek_lastyear(:,:) == val_exp)) &
& maxgppweek_lastyear(:,:) = 0.0
!-
maxgppweek_thisyear(:,:) = val_exp
var_name = 'maxgppweek_thisyear'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., maxgppweek_thisyear, 'gather', nbp_glo, index_g)
IF (ALL(maxgppweek_thisyear(:,:) == val_exp)) &
& maxgppweek_thisyear(:,:) = 0.0
!-
! 9 annual GDD0
!-
gdd0_thisyear(:) = val_exp
var_name = 'gdd0_thisyear'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., gdd0_thisyear, 'gather', nbp_glo, index_g)
IF (ALL(gdd0_thisyear(:) == val_exp)) gdd0_thisyear(:) = 0.0
!-
gdd0_lastyear(:) = val_exp
var_name = 'gdd0_lastyear'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., gdd0_lastyear, 'gather', nbp_glo, index_g)
IF (ALL(gdd0_lastyear(:) == val_exp)) gdd0_lastyear(:) = gdd_crit
!-
! 10 annual precipitation
!-
precip_thisyear(:) = val_exp
var_name = 'precip_thisyear'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., precip_thisyear, 'gather', nbp_glo, index_g)
IF (ALL(precip_thisyear(:) == val_exp)) precip_thisyear(:) = 0.0
!-
precip_lastyear(:) = val_exp
var_name = 'precip_lastyear'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., precip_lastyear, 'gather', nbp_glo, index_g)
IF (ALL(precip_lastyear(:) == val_exp)) &
& precip_lastyear(:) = precip_crit
!-
! 11 derived "biometeorological" variables
!-
gdd_m5_dormance(:,:) = val_exp
var_name = 'gdd_m5_dormance'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., gdd_m5_dormance, 'gather', nbp_glo, index_g)
IF (ALL(gdd_m5_dormance(:,:) == val_exp)) &
& gdd_m5_dormance(:,:) = undef
!-
gdd_midwinter(:,:) = val_exp
var_name = 'gdd_midwinter'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., gdd_midwinter, 'gather', nbp_glo, index_g)
IF (ALL(gdd_midwinter(:,:) == val_exp)) gdd_midwinter(:,:) = undef
!-
ncd_dormance(:,:) = val_exp
var_name = 'ncd_dormance'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., ncd_dormance, 'gather', nbp_glo, index_g)
IF (ALL(ncd_dormance(:,:) == val_exp)) ncd_dormance(:,:) = undef
!-
ngd_minus5(:,:) = val_exp
var_name = 'ngd_minus5'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., ngd_minus5, 'gather', nbp_glo, index_g)
IF (ALL(ngd_minus5(:,:) == val_exp)) ngd_minus5(:,:) = 0.0
!-
time_lowgpp(:,:) = val_exp
var_name = 'time_lowgpp'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., time_lowgpp, 'gather', nbp_glo, index_g)
IF (ALL(time_lowgpp(:,:) == val_exp)) time_lowgpp(:,:) = 0.0
!-
time_hum_min(:,:) = val_exp
var_name = 'time_hum_min'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., time_hum_min, 'gather', nbp_glo, index_g)
IF (ALL(time_hum_min(:,:) == val_exp)) time_hum_min(:,:) = undef
!-
hum_min_dormance(:,:) = val_exp
var_name = 'hum_min_dormance'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., hum_min_dormance, 'gather', nbp_glo, index_g)
IF (ALL(hum_min_dormance(:,:) == val_exp)) &
& hum_min_dormance(:,:) = undef
!-
! 12 Plant status
!-
PFTpresent_real(:,:) = val_exp
var_name = 'PFTpresent'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., PFTpresent_real, 'gather', nbp_glo, index_g)
IF (ALL(PFTpresent_real(:,:) == val_exp)) PFTpresent_real(:,:) = 0.0
WHERE (PFTpresent_real(:,:) >= .5)
PFTpresent = .TRUE.
ELSEWHERE
PFTpresent = .FALSE.
ENDWHERE
!-
ind(:,:) = val_exp
var_name = 'ind'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., ind, 'gather', nbp_glo, index_g)
IF (ALL(ind(:,:) == val_exp)) ind(:,:) = 0.0
!-
adapted(:,:) = val_exp
var_name = 'adapted'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., adapted, 'gather', nbp_glo, index_g)
IF (ALL(adapted(:,:) == val_exp)) adapted(:,:) = 0.0
!-
regenerate(:,:) = val_exp
var_name = 'regenerate'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., regenerate, 'gather', nbp_glo, index_g)
IF (ALL(regenerate(:,:) == val_exp)) regenerate(:,:) = 0.0
!-
npp_longterm(:,:) = val_exp
var_name = 'npp_longterm'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., npp_longterm, 'gather', nbp_glo, index_g)
IF (ALL(npp_longterm(:,:) == val_exp)) npp_longterm(:,:) = 0.0
!-
lm_lastyearmax(:,:) = val_exp
var_name = 'lm_lastyearmax'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., lm_lastyearmax, 'gather', nbp_glo, index_g)
IF (ALL(lm_lastyearmax(:,:) == val_exp)) lm_lastyearmax(:,:) = 0.0
!-
lm_thisyearmax(:,:) = val_exp
var_name = 'lm_thisyearmax'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., lm_thisyearmax, 'gather', nbp_glo, index_g)
IF (ALL(lm_thisyearmax(:,:) == val_exp)) lm_thisyearmax(:,:) = 0.0
!-
maxfpc_lastyear(:,:) = val_exp
var_name = 'maxfpc_lastyear'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., maxfpc_lastyear, 'gather', nbp_glo, index_g)
IF (ALL(maxfpc_lastyear(:,:) == val_exp)) maxfpc_lastyear(:,:) = 0.0
!-
maxfpc_thisyear(:,:) = val_exp
var_name = 'maxfpc_thisyear'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., maxfpc_thisyear, 'gather', nbp_glo, index_g)
IF (ALL(maxfpc_thisyear(:,:) == val_exp)) maxfpc_thisyear(:,:) = 0.0
!-
turnover_time(:,:) = val_exp
var_name = 'turnover_time'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., turnover_time, 'gather', nbp_glo, index_g)
IF ( ALL( turnover_time(:,:) == val_exp)) turnover_time(:,:) = 100.
turnover_longterm(:,:,:) = val_exp
DO k=1,nparts
WRITE(part_str,'(I2)') k
IF ( k < 10 ) part_str(1:1) = '0'
var_name = 'turnover_longterm_'//part_str(1:LEN_TRIM(part_str))
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., turnover_longterm(:,:,k), 'gather', nbp_glo, index_g)
IF (ALL(turnover_longterm(:,:,k) == val_exp)) &
& turnover_longterm(:,:,k) = 0.0
ENDDO
!-
gpp_week(:,:) = val_exp
var_name = 'gpp_week'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., gpp_week, 'gather', nbp_glo, index_g)
IF (ALL(gpp_week(:,:) == val_exp)) gpp_week(:,:) = 0.0
!-
biomass(:,:,:) = val_exp
DO k=1,nparts
WRITE(part_str,'(I2)') k
IF ( k < 10 ) part_str(1:1) = '0'
var_name = 'biomass_'//part_str(1:LEN_TRIM(part_str))
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., biomass(:,:,k), 'gather', nbp_glo, index_g)
IF (ALL(biomass(:,:,k) == val_exp)) biomass(:,:,k) = 0.0
ENDDO
!-
!-
resp_maint_part(:,:,:) = val_exp
DO k=1,nparts
WRITE(part_str,'(I2)') k
IF ( k < 10 ) part_str(1:1) = '0'
var_name = 'maint_resp_'//part_str(1:LEN_TRIM(part_str))
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., resp_maint_part(:,:,k), 'gather', nbp_glo, index_g)
IF (ALL(resp_maint_part(:,:,k) == val_exp)) resp_maint_part(:,:,k) = 0.0
ENDDO
!-
fvm(:,:) = val_exp
var_name = 'fvm'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., fvm, 'gather', nbp_glo, index_g)
IF (ALL(fvm(:,:) == val_exp)) fvm(:,:) = 1.0
!-
fv(:,:) = val_exp
var_name = 'fv'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., fv, 'gather', nbp_glo, index_g)
IF (ALL(fv(:,:) == val_exp)) fv(:,:) = 1.0
!-
leaf_age(:,:,:) = val_exp
DO m=1,nleafages
WRITE (part_str,'(I2)') m
IF ( m < 10 ) part_str(1:1) = '0'
var_name = 'leaf_age_'//part_str(1:LEN_TRIM(part_str))
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., leaf_age(:,:,m), 'gather', nbp_glo, index_g)
IF (ALL(leaf_age(:,:,m) == val_exp)) leaf_age(:,:,m) = 0.0
ENDDO
!-
leaf_frac(:,:,:) = val_exp
DO m=1,nleafages
WRITE(part_str,'(I2)') m
IF ( m < 10 ) part_str(1:1) = '0'
var_name = 'leaf_frac_'//part_str(1:LEN_TRIM(part_str))
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., leaf_frac(:,:,m), 'gather', nbp_glo, index_g)
IF (ALL(leaf_frac(:,:,m) == val_exp)) leaf_frac(:,:,m) = 0.0
ENDDO
!-
senescence_real(:,:) = val_exp
var_name = 'senescence'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., senescence_real, 'gather', nbp_glo, index_g)
IF (ALL(senescence_real(:,:) == val_exp)) senescence_real(:,:) = 0.0
WHERE ( senescence_real(:,:) >= .5 )
senescence = .TRUE.
ELSEWHERE
senescence = .FALSE.
ENDWHERE
!-
when_growthinit(:,:) = val_exp
var_name = 'when_growthinit'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., when_growthinit, 'gather', nbp_glo, index_g)
IF (ALL(when_growthinit(:,:) == val_exp)) &
& when_growthinit(:,:) = undef
!-
age(:,:) = val_exp
var_name = 'age'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., age, 'gather', nbp_glo, index_g)
IF (ALL(age(:,:) == val_exp)) age(:,:) = 0.0
!-
! 13 CO2
!-
resp_hetero(:,:) = val_exp
var_name = 'resp_hetero'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
& .TRUE., resp_hetero, 'gather', nbp_glo, index_g)
IF (ALL(resp_hetero(:,:) == val_exp)) resp_hetero(:,:) = 0.0
!-
resp_maint(:,:) = val_exp
var_name = 'resp_maint'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., resp_maint, 'gather', nbp_glo, index_g)
IF (ALL(resp_maint(:,:) == val_exp)) resp_maint(:,:) = 0.0
!-
resp_growth(:,:) = val_exp
var_name = 'resp_growth'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., resp_growth, 'gather', nbp_glo, index_g)
IF (ALL(resp_growth(:,:) == val_exp)) resp_growth(:,:) = 0.0
!-
co2_fire(:) = val_exp
var_name = 'co2_fire'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., co2_fire, 'gather', nbp_glo, index_g)
IF (ALL(co2_fire(:) == val_exp)) co2_fire(:) = 0.0
!-
co2_to_bm_dgvm(:) = val_exp
var_name = 'co2_to_bm_dgvm'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., co2_to_bm_dgvm, 'gather', nbp_glo, index_g)
IF (ALL(co2_to_bm_dgvm(:) == val_exp)) co2_to_bm_dgvm(:) = 0.0
!-
! 14 vegetation distribution after last light competition
!-
veget_lastlight(:,:) = val_exp
var_name = 'veget_lastlight'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., veget_lastlight, 'gather', nbp_glo, index_g)
IF (ALL(veget_lastlight(:,:) == val_exp)) veget_lastlight(:,:) = 0.0
!-
! 15 establishment criteria
!-
everywhere(:,:) = val_exp
var_name = 'everywhere'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., everywhere, 'gather', nbp_glo, index_g)
IF (ALL(everywhere(:,:) == val_exp)) everywhere(:,:) = 0.0
!-
need_adjacent_real(:,:) = val_exp
var_name = 'need_adjacent'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., need_adjacent_real, 'gather', nbp_glo, index_g)
IF (ALL(need_adjacent_real(:,:) == val_exp)) &
& need_adjacent_real(:,:) = 0.0
WHERE ( need_adjacent_real(:,:) >= .5 )
need_adjacent = .TRUE.
ELSEWHERE
need_adjacent = .FALSE.
ENDWHERE
!-
RIP_time(:,:) = val_exp
var_name = 'RIP_time'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., RIP_time, 'gather', nbp_glo, index_g)
IF (ALL(RIP_time(:,:) == val_exp)) RIP_time(:,:) = large_value
!-
! 16 black carbon
!-
black_carbon(:) = val_exp
var_name = 'black_carbon'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
& .TRUE., black_carbon, 'gather', nbp_glo, index_g)
IF (ALL(black_carbon(:) == val_exp)) black_carbon(:) = 0.0
!-
! 17 litter
!-
litterpart(:,:,:) = val_exp
DO l=1,nlitt
var_name = 'litterpart_'//litter_str(l)
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., litterpart(:,:,l), 'gather', nbp_glo, index_g)
IF (ALL(litterpart(:,:,l) == val_exp)) litterpart(:,:,l) = 0.0
ENDDO
!-
litter(:,:,:,:) = val_exp
DO l=1,nlevs
DO m=1,nvegtypes
var_name = 'litter_'//vegtype_str(m)//'_'//level_str(l)
CALL restget_p (rest_id_stomate, var_name, nbp_glo, nlitt , 1, itime, &
& .TRUE., litter(:,:,m,l), 'gather', nbp_glo, index_g)
IF (ALL(litter(:,:,m,l) == val_exp)) litter(:,:,m,l) = 0.0
ENDDO
ENDDO
!-
dead_leaves(:,:,:) = val_exp
DO l=1,nlitt
var_name = 'dead_leaves_'//litter_str(l)
CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& .TRUE., dead_leaves(:,:,l), 'gather', nbp_glo, index_g)
IF (ALL(dead_leaves(:,:,l) == val_exp)) dead_leaves(:,:,l) = 0.0
ENDDO
!-
carbon(:,:,:) = val_exp
DO m=1,nvegtypes
var_name = 'carbon_'//vegtype_str(m)
CALL restget_p (rest_id_stomate, var_name, nbp_glo, ncarb , 1, itime, &
& .TRUE., carbon(:,:,m), 'gather', nbp_glo, index_g)
IF (ALL(carbon(:,:,m) == val_exp)) carbon(:,:,m) = 0.0
ENDDO
!-
lignin_struc(:,:,:) = val_exp
DO l=1,nlevs
var_name = 'lignin_struc_'//level_str(l)
CALL restget_p &
& (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
& .TRUE., lignin_struc(:,:,l), 'gather', nbp_glo, index_g)
IF (ALL(lignin_struc(:,:,l) == val_exp)) lignin_struc(:,:,l) = 0.0
ENDDO
!-
! 18 deforestation
!-
prod10(:,:) = val_exp
var_name = 'prod10'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 11 , 1, itime, &
& .TRUE., prod10, 'gather', nbp_glo, index_g)
IF (ALL(prod10(:,:) == val_exp)) prod10(:,:) = 0.0
prod100(:,:) = val_exp
var_name = 'prod100'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 101 , 1, itime, &
& .TRUE., prod100, 'gather', nbp_glo, index_g)
IF (ALL(prod100(:,:) == val_exp)) prod100(:,:) = 0.0
flux10(:,:) = val_exp
var_name = 'flux10'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 10 , 1, itime, &
& .TRUE., flux10, 'gather', nbp_glo, index_g)
IF (ALL(flux10(:,:) == val_exp)) flux10(:,:) = 0.0
flux100(:,:) = val_exp
var_name = 'flux100'
CALL restget_p (rest_id_stomate, var_name, nbp_glo, 100 , 1, itime, &
& .TRUE., flux100, 'gather', nbp_glo, index_g)
IF (ALL(flux100(:,:) == val_exp)) flux100(:,:) = 0.0
!-
IF (bavard >= 4) WRITE(numout,*) 'Leaving readstart'
!-----------------------
END SUBROUTINE readstart
!-
!===
!-
SUBROUTINE writerestart &
& (npts, index, day_counter, dt_days, date, &
& ind, adapted, regenerate, moiavail_daily, litterhum_daily, &
& t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
& soilhum_daily, precip_daily, gpp_daily, npp_daily, &
& turnover_daily, moiavail_month, moiavail_week, &
& t2m_longterm, tlong_ref, t2m_month, t2m_week, &
& tsoil_month, soilhum_month, fireindex, firelitter, &
& maxmoiavail_lastyear, maxmoiavail_thisyear, &
& minmoiavail_lastyear, minmoiavail_thisyear, &
& maxgppweek_lastyear, maxgppweek_thisyear, &
& gdd0_lastyear, gdd0_thisyear, precip_lastyear, precip_thisyear, &
& gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
& PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
& maxfpc_lastyear, maxfpc_thisyear, &
& turnover_longterm, gpp_week, biomass, resp_maint_part, &
& fvm, fv, leaf_age, leaf_frac, senescence, when_growthinit, age, &
& resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
& veget_lastlight, everywhere, need_adjacent, RIP_time, &
& time_lowgpp, time_hum_min, hum_min_dormance, litterpart, litter, &
& dead_leaves, carbon, black_carbon, lignin_struc,turnover_time, &
& prod10,prod100 ,flux10, flux100)
! deforestation variables added as arguments
!---------------------------------------------------------------------
!- write restart file
!---------------------------------------------------------------------
!-
! 0 declarations
!-
! 0.1 input
!-
! Domain size
INTEGER(i_std),INTENT(in) :: npts
! Indices of the points on the map
INTEGER(i_std),DIMENSION(npts),INTENT(in) :: index
! counts time until next STOMATE time step
REAL(r_std),INTENT(in) :: day_counter
! time step of STOMATE in days
REAL(r_std),INTENT(in) :: dt_days
! date (d)
INTEGER(i_std),INTENT(in) :: date
! density of individuals (1/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: ind
! Winter too cold? between 0 and 1
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: adapted
! Winter sufficiently cold? between 0 and 1
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: regenerate
! daily moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: moiavail_daily
! daily litter humidity
REAL(r_std),DIMENSION(npts),INTENT(in) :: litterhum_daily
! daily 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_daily
! daily minimum 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_min_daily
! daily surface temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(in) :: tsurf_daily
! daily soil temperatures (K)
REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: tsoil_daily
! daily soil humidity
REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: soilhum_daily
! daily precipitations (mm/day) (for phenology)
REAL(r_std),DIMENSION(npts),INTENT(in) :: precip_daily
! daily gross primary productivity (gC/m**2/day)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: gpp_daily
! daily net primary productivity (gC/m**2/day)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: npp_daily
! daily turnover rates (gC/m**2/day)
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: turnover_daily
! "monthly" moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: moiavail_month
! "weekly" moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: moiavail_week
! "long term" 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_longterm
! "long term" reference 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(in) :: tlong_ref
! "monthly" 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_month
! "weekly" 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_week
! "monthly" soil temperatures (K)
REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: tsoil_month
! "monthly" soil humidity
REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: soilhum_month
! Probability of fire
REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(in) :: fireindex
! Longer term total litter above the ground, gC/m**2 of nat/agri ground
REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(in) :: firelitter
! last year's maximum moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxmoiavail_lastyear
! this year's maximum moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxmoiavail_thisyear
! last year's minimum moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: minmoiavail_lastyear
! this year's minimum moisture availability
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: minmoiavail_thisyear
! last year's maximum weekly GPP
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxgppweek_lastyear
! this year's maximum weekly GPP
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxgppweek_thisyear
! last year's annual GDD0
REAL(r_std),DIMENSION(npts),INTENT(in) :: gdd0_lastyear
! this year's annual GDD0
REAL(r_std),DIMENSION(npts),INTENT(in) :: gdd0_thisyear
! last year's annual precipitation (mm/year)
REAL(r_std),DIMENSION(npts),INTENT(in) :: precip_lastyear
! this year's annual precipitation (mm/year)
REAL(r_std),DIMENSION(npts),INTENT(in) :: precip_thisyear
! growing degree days, threshold -5 deg C (for phenology)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: gdd_m5_dormance
! growing degree days since midwinter (for phenology)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: gdd_midwinter
! number of chilling days since leaves were lost (for phenology)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: ncd_dormance
! number of growing days, threshold -5 deg C (for phenology)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: ngd_minus5
! PFT exists (equivalent to fpc_max > 0 for natural PFTs)
LOGICAL,DIMENSION(npts,npft),INTENT(in) :: PFTpresent
! "long term" net primary productivity (gC/m**2/year)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: npp_longterm
! last year's maximum leaf mass, for each PFT (gC/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: lm_lastyearmax
! this year's maximum leaf mass, for each PFT (gC/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: lm_thisyearmax
! last year's maximum fpc for each natural PFT, on *natural* ground
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxfpc_lastyear
! this year's maximum fpc for each PFT,
! on *total* ground (see stomate_season)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxfpc_thisyear
! "long term" turnover rate (gC/m**2/year)
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: turnover_longterm
! "weekly" GPP (gC/day/(m**2 covered)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: gpp_week
! biomass (gC/m**2)
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: biomass
! maintenance respiration (gC/m**2)
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: resp_maint_part
! factor to convert veget_x into veget
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: fv
! factor to convert veget_max_x into veget_max
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: fvm
! leaf age (days)
REAL(r_std),DIMENSION(npts,npft,nleafages),INTENT(in) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std),DIMENSION(npts,npft,nleafages),INTENT(in) :: leaf_frac
! is the plant senescent ?
! (only for deciduous trees - carbohydrate reserve)
LOGICAL,DIMENSION(npts,npft),INTENT(in) :: senescence
! how many days ago was the beginning of the growing season
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: when_growthinit
! mean age (years)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: age
! heterotrophic respiration (gC/day/m**2)
REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(in) :: resp_hetero
! maintenance respiration (gC/day/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: resp_maint
! growth respiration (gC/day/m**2)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: resp_growth
! carbon emitted into the atmosphere by fire (living and dead biomass)
! (in gC/m**2/time step)
REAL(r_std),DIMENSION(npts),INTENT(in) :: co2_fire
! biomass uptaken (gC/(m**2 of total ground)/day)
REAL(r_std),DIMENSION(npts),INTENT(in) :: co2_to_bm_dgvm
! vegetation fractions
! (on natural/agri ground) after last light competition
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: veget_lastlight
! is the PFT everywhere in the grid box or very localized
! (after its introduction)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: everywhere
! in order for this PFT to be introduced,
! does it have to be present in an adjacent grid box?
LOGICAL,DIMENSION(npts,npft),INTENT(in) :: need_adjacent
! How much time ago was the PFT eliminated for the last time (y)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: RIP_time
! duration of dormance (d)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: time_lowgpp
! time elapsed since strongest moisture availability (d)
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: time_hum_min
! minimum moisture during dormance
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: hum_min_dormance
! fraction of litter above the ground belonging to different PFTs
! separated for natural and agricultural PFTs.
REAL(r_std),DIMENSION(npts,npft,nlitt),INTENT(in) :: litterpart
! metabolic and structural litter, natural and agricultural,
! above and below ground (gC/m**2)
REAL(r_std),DIMENSION(npts,nlitt,nvegtypes,nlevs),INTENT(in) :: litter
! dead leaves on ground, per PFT, metabolic and structural,
! in gC/(m**2 of nat/agri ground)
REAL(r_std),DIMENSION(npts,npft,nlitt),INTENT(in) :: dead_leaves
! carbon pool: active, slow, or passive, natural and agricultural
! (gC/m**2)
REAL(r_std),DIMENSION(npts,ncarb,nvegtypes),INTENT(in) :: carbon
! black carbon on the ground (gC/(m**2 of total ground))
REAL(r_std),DIMENSION(npts),INTENT(in) :: black_carbon
! ratio Lignine/Carbon in structural litter, above and below ground,
! natural and agricultural (gC/m**2)
REAL(r_std),DIMENSION(npts,nvegtypes,nlevs),INTENT(in) :: lignin_struc
! turnover_time of leaves
REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: turnover_time
!-
! 0.2 local
!-
! date, real
REAL(r_std) :: date_real
! PFT exists (equivalent to fpc_max > 0 for natural PFTs), real
REAL(r_std),DIMENSION(npts,npft) :: PFTpresent_real
! is the plant senescent ?
! (only for deciduous trees - carbohydrate reserve), real
REAL(r_std),DIMENSION(npts,npft) :: senescence_real
! in order for this PFT to be introduced,
! does it have to be present in an adjacent grid box? - real
REAL(r_std),DIMENSION(npts,npft) :: need_adjacent_real
! To store variables names for I/O
CHARACTER(LEN=80) :: var_name
! string suffix indicating an index
CHARACTER(LEN=10) :: part_str
! string suffix indicating litter type
CHARACTER(LEN=3),DIMENSION(nlitt) :: litter_str
! string suffix indicating vegetation type
CHARACTER(LEN=3),DIMENSION(nvegtypes) :: vegtype_str
! string suffix indicating level
CHARACTER(LEN=2),DIMENSION(nlevs) :: level_str
! temporary storage
REAL(r_std),DIMENSION(1) :: xtmp
! index
INTEGER(i_std) :: k,l,m
! deforestation variables
! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
! (10 or 100 + 1 : input from year of deforestation)
REAL(r_std),DIMENSION(npts,0:10),INTENT(in) :: prod10
REAL(r_std),DIMENSION(npts,0:100),INTENT(in) :: prod100
! annual release from the 10/100 year-turnover pool compartments
REAL(r_std),DIMENSION(npts,10),INTENT(in) :: flux10
REAL(r_std),DIMENSION(npts,100),INTENT(in) :: flux100
!---------------------------------------------------------------------
IF (bavard >= 3) WRITE(numout,*) 'Entering writerestart'
!-
! 1 string definitions
!-
print *,'--------------------> debut writestart',rest_id_stomate
DO m=1,nvegtypes
IF (m == inat) THEN
vegtype_str(m) = 'nat'
ELSEIF (m == iagri) THEN
vegtype_str(m) = 'agr'
ELSE
STOP 'Define vegtype_str'
ENDIF
ENDDO
!-
DO l=1,nlitt
IF (l == imetabolic) THEN
litter_str(l) = 'met'
ELSEIF (l == istructural) THEN
litter_str(l) = 'str'
ELSE
STOP 'Define litter_str'
ENDIF
ENDDO
!-
DO l=1,nlevs
IF (l == iabove) THEN
level_str(l) = 'ab'
ELSEIF (l == ibelow) THEN
level_str(l) = 'be'
ELSE
STOP 'Define level_str'
ENDIF
ENDDO
!-
IF (is_root_prc) THEN
CALL ioconf_setatt ('UNITS','-')
CALL ioconf_setatt ('LONG_NAME',' ')
ENDIF
!-
! 2 run control
!-
! 2.1 day counter
!-
IF (is_root_prc) THEN
var_name = 'day_counter'
xtmp(1) = day_counter
CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, xtmp)
ENDIF
!-
! 2.2 time step of STOMATE in days
!-
IF (is_root_prc) THEN
var_name = 'dt_days'
xtmp(1) = dt_days
CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, xtmp)
ENDIF
!-
! 2.3 date
!-
IF (is_root_prc) THEN
var_name = 'date'
date_real = REAL(date,r_std)
xtmp(1) = date_real
CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, xtmp)
ENDIF
!-
! 3 daily meteorological variables
!-
var_name = 'moiavail_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& moiavail_daily, 'scatter', nbp_glo, index_g)
!-
var_name = 'litterhum_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& litterhum_daily, 'scatter', nbp_glo, index_g)
!-
var_name = 't2m_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& t2m_daily, 'scatter', nbp_glo, index_g)
!-
var_name = 't2m_min_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& t2m_min_daily, 'scatter', nbp_glo, index_g)
!-
var_name = 'tsurf_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& tsurf_daily, 'scatter', nbp_glo, index_g)
!-
var_name = 'tsoil_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
& tsoil_daily, 'scatter', nbp_glo, index_g)
!-
var_name = 'soilhum_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
& soilhum_daily, 'scatter', nbp_glo, index_g)
!-
var_name = 'precip_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& precip_daily, 'scatter', nbp_glo, index_g)
!-
! 4 productivities
!-
var_name = 'gpp_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& gpp_daily, 'scatter', nbp_glo, index_g)
!-
var_name = 'npp_daily'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& npp_daily, 'scatter', nbp_glo, index_g)
!-
DO k=1,nparts
WRITE(part_str,'(I2)') k
IF (k < 10) part_str(1:1) = '0'
var_name = 'turnover_daily_'//part_str(1:LEN_TRIM(part_str))
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& turnover_daily(:,:,k), 'scatter', nbp_glo, index_g)
ENDDO
!-
! 5 monthly meteorological variables
!-
var_name = 'moiavail_month'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& moiavail_month, 'scatter', nbp_glo, index_g)
!-
var_name = 'moiavail_week'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& moiavail_week, 'scatter', nbp_glo, index_g)
!-
var_name = 't2m_longterm'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& t2m_longterm, 'scatter', nbp_glo, index_g)
!-
IF (control%ok_dgvm) THEN
var_name = 'tlong_ref'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& tlong_ref, 'scatter', nbp_glo, index_g)
ENDIF
!-
var_name = 't2m_month'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& t2m_month, 'scatter', nbp_glo, index_g)
!-
var_name = 't2m_week'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& t2m_week, 'scatter', nbp_glo, index_g)
!-
var_name = 'tsoil_month'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
& tsoil_month, 'scatter', nbp_glo, index_g)
!-
var_name = 'soilhum_month'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
& soilhum_month, 'scatter', nbp_glo, index_g)
!-
! 6 fire probability
!-
var_name = 'fireindex'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
& fireindex, 'scatter', nbp_glo, index_g)
!-
var_name = 'firelitter'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
& firelitter, 'scatter', nbp_glo, index_g)
!-
! 7 maximum and minimum moisture availabilities for tropic phenology
!-
var_name = 'maxmoistr_last'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& maxmoiavail_lastyear, 'scatter', nbp_glo, index_g)
!-
var_name = 'maxmoistr_this'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& maxmoiavail_thisyear, 'scatter', nbp_glo, index_g)
!-
var_name = 'minmoistr_last'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& minmoiavail_lastyear, 'scatter', nbp_glo, index_g)
!-
var_name = 'minmoistr_this'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& minmoiavail_thisyear, 'scatter', nbp_glo, index_g)
!-
! 8 maximum "weekly" GPP
!-
var_name = 'maxgppweek_lastyear'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& maxgppweek_lastyear, 'scatter', nbp_glo, index_g)
!-
var_name = 'maxgppweek_thisyear'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& maxgppweek_thisyear, 'scatter', nbp_glo, index_g)
!-
! 9 annual GDD0
!-
var_name = 'gdd0_thisyear'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& gdd0_thisyear, 'scatter', nbp_glo, index_g)
!-
var_name = 'gdd0_lastyear'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& gdd0_lastyear, 'scatter', nbp_glo, index_g)
!-
! 10 annual precipitation
!-
var_name = 'precip_thisyear'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& precip_thisyear, 'scatter', nbp_glo, index_g)
!-
var_name = 'precip_lastyear'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& precip_lastyear, 'scatter', nbp_glo, index_g)
!-
! 11 derived "biometeorological" variables
!-
var_name = 'gdd_m5_dormance'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& gdd_m5_dormance, 'scatter', nbp_glo, index_g)
!-
var_name = 'gdd_midwinter'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& gdd_midwinter, 'scatter', nbp_glo, index_g)
!-
var_name = 'ncd_dormance'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& ncd_dormance, 'scatter', nbp_glo, index_g)
!-
var_name = 'ngd_minus5'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& ngd_minus5, 'scatter', nbp_glo, index_g)
!-
var_name = 'time_lowgpp'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& time_lowgpp, 'scatter', nbp_glo, index_g)
!-
var_name = 'time_hum_min'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& time_hum_min, 'scatter', nbp_glo, index_g)
!-
var_name = 'hum_min_dormance'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& hum_min_dormance, 'scatter', nbp_glo, index_g)
!-
! 12 Plant status
!-
var_name = 'PFTpresent'
WHERE ( PFTpresent(:,:) )
PFTpresent_real = 1.
ELSEWHERE
PFTpresent_real = 0.
ENDWHERE
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& PFTpresent_real, 'scatter', nbp_glo, index_g)
!-
var_name = 'ind'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& ind, 'scatter', nbp_glo, index_g)
!-
var_name = 'turnover_time'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& turnover_time, 'scatter', nbp_glo, index_g)
!-
var_name = 'adapted'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& adapted, 'scatter', nbp_glo, index_g)
!-
var_name = 'regenerate'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& regenerate, 'scatter', nbp_glo, index_g)
!-
var_name = 'npp_longterm'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& npp_longterm, 'scatter', nbp_glo, index_g)
!-
var_name = 'lm_lastyearmax'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& lm_lastyearmax, 'scatter', nbp_glo, index_g)
!-
var_name = 'lm_thisyearmax'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& lm_thisyearmax, 'scatter', nbp_glo, index_g)
!-
var_name = 'maxfpc_lastyear'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& maxfpc_lastyear, 'scatter', nbp_glo, index_g)
!-
var_name = 'maxfpc_thisyear'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& maxfpc_thisyear, 'scatter', nbp_glo, index_g)
!-
DO k=1,nparts
WRITE(part_str,'(I2)') k
IF (k < 10) part_str(1:1) = '0'
var_name = 'turnover_longterm_'//part_str(1:LEN_TRIM(part_str))
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& turnover_longterm(:,:,k), 'scatter', nbp_glo, index_g)
ENDDO
!-
var_name = 'gpp_week'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& gpp_week, 'scatter', nbp_glo, index_g)
!-
DO k=1,nparts
WRITE(part_str,'(I2)') k
IF (k < 10) part_str(1:1) = '0'
var_name = 'biomass_'//part_str(1:LEN_TRIM(part_str))
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& biomass(:,:,k), 'scatter', nbp_glo, index_g)
ENDDO
!-
DO k=1,nparts
WRITE(part_str,'(I2)') k
IF (k < 10) part_str(1:1) = '0'
var_name = 'maint_resp_'//part_str(1:LEN_TRIM(part_str))
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& resp_maint_part(:,:,k), 'scatter', nbp_glo, index_g)
ENDDO
!-
var_name = 'fvm'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& fvm, 'scatter', nbp_glo, index_g)
!-
var_name = 'fv'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& fv, 'scatter', nbp_glo, index_g)
!-
DO m=1,nleafages
WRITE(part_str,'(I2)') m
IF (m < 10) part_str(1:1) = '0'
var_name = 'leaf_age_'//part_str(1:LEN_TRIM(part_str))
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& leaf_age(:,:,m), 'scatter', nbp_glo, index_g)
ENDDO
!-
DO m=1,nleafages
WRITE(part_str,'(I2)') m
IF (m < 10) part_str(1:1) = '0'
var_name = 'leaf_frac_'//part_str(1:LEN_TRIM(part_str))
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& leaf_frac(:,:,m), 'scatter', nbp_glo, index_g)
ENDDO
!-
var_name = 'senescence'
WHERE ( senescence(:,:) )
senescence_real = 1.
ELSEWHERE
senescence_real = 0.
ENDWHERE
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& senescence_real, 'scatter', nbp_glo, index_g)
!-
var_name = 'when_growthinit'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& when_growthinit, 'scatter', nbp_glo, index_g)
!-
var_name = 'age'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
& age, 'scatter', nbp_glo, index_g)
!-
! 13 CO2
!-
var_name = 'resp_hetero'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
& resp_hetero, 'scatter', nbp_glo, index_g)
!-
var_name = 'resp_maint'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& resp_maint, 'scatter', nbp_glo, index_g)
!-
var_name = 'resp_growth'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& resp_growth, 'scatter', nbp_glo, index_g)
!-
var_name = 'co2_fire'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& co2_fire, 'scatter', nbp_glo, index_g)
!-
var_name = 'co2_to_bm_dgvm'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& co2_to_bm_dgvm, 'scatter', nbp_glo, index_g)
!-
! 14 vegetation distribution after last light competition
!-
var_name = 'veget_lastlight'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& veget_lastlight, 'scatter', nbp_glo, index_g)
!-
! 15 establishment criteria
!-
var_name = 'everywhere'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& everywhere, 'scatter', nbp_glo, index_g)
!-
var_name = 'need_adjacent'
WHERE (need_adjacent(:,:))
need_adjacent_real(:,:) = 1.
ELSEWHERE
need_adjacent_real(:,:) = 0.
ENDWHERE
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& need_adjacent_real, 'scatter', nbp_glo, index_g)
!-
var_name = 'RIP_time'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& RIP_time, 'scatter', nbp_glo, index_g)
!-
! 16 black carbon
!-
var_name = 'black_carbon'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
& black_carbon, 'scatter', nbp_glo, index_g)
!-
! 17 litter
!-
DO l=1,nlitt
var_name = 'litterpart_'//litter_str(l)
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& litterpart(:,:,l), 'scatter', nbp_glo, index_g)
ENDDO
!-
DO l=1,nlevs
DO m=1,nvegtypes
var_name = 'litter_'//vegtype_str(m)//'_'//level_str(l)
CALL restput_p (rest_id_stomate, var_name, nbp_glo, nlitt, 1, itime, &
& litter(:,:,m,l), 'scatter', nbp_glo, index_g)
ENDDO
ENDDO
!-
DO l=1,nlitt
var_name = 'dead_leaves_'//litter_str(l)
CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
& dead_leaves(:,:,l), 'scatter', nbp_glo, index_g)
ENDDO
!-
DO m=1,nvegtypes
var_name = 'carbon_'//vegtype_str(m)
CALL restput_p (rest_id_stomate, var_name, nbp_glo, ncarb, 1, itime, &
& carbon(:,:,m), 'scatter', nbp_glo, index_g)
ENDDO
!-
DO l=1,nlevs
var_name = 'lignin_struc_'//level_str(l)
CALL restput_p &
& (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
& lignin_struc(:,:,l), 'scatter', nbp_glo, index_g)
ENDDO
!-
! 18 deforestation
!-
var_name = 'prod10'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 11, 1, itime, &
& prod10, 'scatter', nbp_glo, index_g)
var_name = 'prod100'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 101, 1, itime, &
& prod100, 'scatter', nbp_glo, index_g)
var_name = 'flux10'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 10, 1, itime, &
& flux10, 'scatter', nbp_glo, index_g)
var_name = 'flux100'
CALL restput_p (rest_id_stomate, var_name, nbp_glo, 100, 1, itime, &
& flux100, 'scatter', nbp_glo, index_g)
!-
IF (bavard >= 4) WRITE(numout,*) 'Leaving writerestart'
!--------------------------
END SUBROUTINE writerestart
!-
!===
!-
SUBROUTINE readbc (npts, lalo, resolution, tref)
!---------------------------------------------------------------------
!-
! 0.1 input
!-
! Domain size
INTEGER(i_std),INTENT(in) :: npts
! Geogr. coordinates (latitude,longitude) (degrees)
REAL(r_std),DIMENSION (npts,2),INTENT(in) :: lalo
! size in x an y of the grid (m)
REAL(r_std),DIMENSION (npts,2),INTENT(in) :: resolution
!-
! 0.2 not necessarily output
!-
! "long term" reference 2 meter temperatures (K)
REAL(r_std),DIMENSION(npts),INTENT(inout) :: tref
!---------------------------------------------------------------------
!-
! If the vegetation is static, then the long-term reference
! temperature is a boundary condition.
!-
IF ( .NOT. control%ok_dgvm ) THEN
CALL get_reftemp (npts, lalo, resolution, tref)
ENDIF
!--------------------
END SUBROUTINE readbc
!-
!===
!-
SUBROUTINE get_reftemp_clear
!---------------------------------------------------------------------
firstcall=.TRUE.
IF (ALLOCATED (trefe)) DEALLOCATE( trefe )
!-------------------------------
END SUBROUTINE get_reftemp_clear
!-
!===
!-
SUBROUTINE get_reftemp (npts, lalo, resolution, tref_out)
!---------------------------------------------------------------------
!- read the long-term reference temperature from a boundary condition
!- file. If the vegetation is dynamic, this field is used to
!- initialize correctly the (prognostic) long-term reference
!- temperature (in the case it is not found in the restart file).
!- If the vegetation is static, the field read here is a real boundary
!- condition that is not modified by the model.
!---------------------------------------------------------------------
!-
! 0 declarations
!-
! 0.1 input
!-
! Domain size
INTEGER(i_std),INTENT(in) :: npts
! Geogr. coordinates (latitude,longitude) (degrees)
REAL(r_std),DIMENSION (npts,2),INTENT(in) :: lalo
! size in x an y of the grid (m)
REAL(r_std),DIMENSION (npts,2),INTENT(in) :: resolution
!-
! 0.2 output
!-
! reference temperature (K)
REAL(r_std), DIMENSION(npts),INTENT(out) :: tref_out
!-
! 0.3 local
!-
INTEGER(i_std),PARAMETER :: nbvmax=200
REAL(r_std),PARAMETER :: R_Earth = 6378000.
CHARACTER(LEN=80) :: filename
INTEGER(i_std) :: &
& iml, jml, lml, tml, fid, ib, ip, jp, fopt, ilf, lastjp
REAL(r_std) :: lev(1), date, dt, coslat
INTEGER(i_std) :: itau(1)
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: &
& lat_rel, lon_rel, lat_ful, lon_ful, tref_file
REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: &
& loup_rel, lolow_rel, laup_rel, lalow_rel
REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
REAL(r_std) :: ax, ay, sgn
REAL(r_std),DIMENSION(nbvmax) :: area
REAL(r_std),DIMENSION(nbvmax) :: tt
REAL(r_std) :: m_pi
REAL(r_std) :: resx, resy
LOGICAL :: do_again
!---------------------------------------------------------------------
m_pi = 4. * ATAN(1.)
!-
! 1 If this is the first call, calculate the reference temperature
! and keep it in memory
!-
IF (firstcall) THEN
!---
!-- 1.1 only do this once
!---
firstcall = .FALSE.
!---
!-- 1.2 allocate the field
!---
ALLOCATE( trefe(npts) )
!---
!-- 1.3 read and interpolate the temperature file
!---
!-- Needs to be a configurable variable
!---
!Config Key = REFTEMP_FILE
!Config Desc = Name of file from which the reference
!Config temperature is read
!Config Def = reftemp.nc
!Config Help = The name of the file to be opened to read
!Config the reference surface temperature.
!Config The data from this file is then interpolated
!Config to the grid of of the model.
!Config The aim is to get a reference temperature either
!Config to initialize the corresponding prognostic model
!Config variable correctly (ok_dgvm=TRUE) or to impose it
!Config as boundary condition (ok_dgvm=FALSE)
!---
filename = 'reftemp.nc'
CALL getin_p('REFTEMP_FILE',filename)
!---
IF (is_root_prc) CALL flininfo(filename,iml, jml, lml, tml, fid)
CALL bcast(iml)
CALL bcast(jml)
CALL bcast(lml)
CALL bcast(tml)
!---
ALLOCATE (lat_rel(iml,jml))
ALLOCATE (lon_rel(iml,jml))
ALLOCATE (laup_rel(iml,jml))
ALLOCATE (loup_rel(iml,jml))
ALLOCATE (lalow_rel(iml,jml))
ALLOCATE (lolow_rel(iml,jml))
ALLOCATE (lat_ful(iml+2,jml+2))
ALLOCATE (lon_ful(iml+2,jml+2))
ALLOCATE (tref_file(iml,jml))
!---
IF (is_root_prc) CALL flinopen (filename, .FALSE., iml, jml, lml, &
& lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
CALL bcast(lon_rel)
CALL bcast(lat_rel)
CALL bcast(itau)
CALL bcast(date)
CALL bcast(dt)
!---
IF (is_root_prc) CALL flinget (fid, 'temperature', iml, jml, lml, tml, &
& 1, 1, tref_file)
CALL bcast(tref_file)
!---
IF (is_root_prc) CALL flinclo (fid)
!---
!-- Duplicate the border assuming we have a global grid
!-- going from west to east
!---
lon_ful(2:iml+1,2:jml+1) = lon_rel(1:iml,1:jml)
lat_ful(2:iml+1,2:jml+1) = lat_rel(1:iml,1:jml)
!---
IF ( lon_rel(iml,1) < lon_ful(2,2)) THEN
lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)
lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
ELSE
lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)-360
lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
ENDIF
!---
IF ( lon_rel(1,1) > lon_ful(iml+1,2)) THEN
lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)
lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
ELSE
lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)+360
lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
ENDIF
!---
sgn = lat_rel(1,1)/ABS(lat_rel(1,1))
lat_ful(2:iml+1,1) = sgn*180 - lat_rel(1:iml,1)
sgn = lat_rel(1,jml)/ABS(lat_rel(1,jml))
lat_ful(2:iml+1,jml+2) = sgn*180 - lat_rel(1:iml,jml)
lat_ful(1,1) = lat_ful(iml+1,1)
lat_ful(iml+2,1) = lat_ful(2,1)
lat_ful(1,jml+2) = lat_ful(iml+1,jml+2)
lat_ful(iml+2,jml+2) = lat_ful(2,jml+2)
!---
!-- Add the longitude lines to the top and bottom
!---
lon_ful(:,1) = lon_ful(:,2)
lon_ful(:,jml+2) = lon_ful(:,jml+1)
!---
!-- Get the upper and lower limits of each grid box
!---
DO ip=1,iml
DO jp=1,jml
loup_rel(ip,jp) = &
& MAX(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), &
& 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
lolow_rel(ip,jp) = &
& MIN(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), &
& 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
laup_rel(ip,jp) = &
& MAX(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), &
& 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
lalow_rel(ip,jp) = &
& MIN(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), &
& 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
ENDDO
ENDDO
!---
!-- Now we take each grid point and find out which values
!-- from the forcing we need to average
!---
DO ib=1,npts
!-----
resx = resolution(ib,1)
resy = resolution(ib,2)
!-----
do_again = .TRUE.
!-----
DO WHILE (do_again)
!-----
do_again = .FALSE.
!-------
!------ We find the 4 limits of the grid-box.
!------ As we transform the resolution of the model into longitudes
!------ and latitudes we do not have the problem of periodicity.
!------ coslat is a help variable here !
!-------
coslat = MAX(COS(lalo(ib,1)*m_pi/180.),0.001)*m_pi/180.*R_Earth
!-------
lon_up = lalo(ib,2)+resx/(2.0*coslat)
lon_low = lalo(ib,2)-resx/(2.0*coslat)
!-------
coslat = m_pi/180.*R_Earth
!-------
lat_up = lalo(ib,1)+resy/(2.0*coslat)
lat_low = lalo(ib,1)-resy/(2.0*coslat)
!-------
!------ Find the grid boxes from the data that go into
!------ the model's boxes.
!------ We still work as if we had a regular grid !
!------ Well it needs to be localy regular so that
!------ the longitude at the latitude of the last found point
!------ is close to the one of the next point.
!-------
fopt = 0
lastjp = 1
DO ip=1,iml
!---------
!-------- Either the center of the data grid point is in the interval
!-------- of the model grid or the East and West limits of the data
!-------- grid point are on either sides of the border of the data grid
!---------
IF ( lon_rel(ip,lastjp) > lon_low &
& .AND. lon_rel(ip,lastjp) < lon_up &
& .OR. lolow_rel(ip,lastjp) < lon_low &
& .AND. loup_rel(ip,lastjp) > lon_low &
& .OR. lolow_rel(ip,lastjp) < lon_up &
& .AND. loup_rel(ip,lastjp) > lon_up ) THEN
DO jp=1,jml
!-------------
!------------ Now that we have the longitude let us find the latitude
!-------------
IF ( lat_rel(ip,jp) > lat_low &
& .AND. lat_rel(ip,jp) < lat_up &
& .OR. lalow_rel(ip,jp) < lat_low &
& .AND. laup_rel(ip,jp) > lat_low &
& .OR. lalow_rel(ip,jp) < lat_up &
& .AND. laup_rel(ip,jp) > lat_up) THEN
lastjp = jp
!---------------
fopt = fopt + 1
IF ( fopt > nbvmax) THEN
WRITE(numout,*) &
& 'Please increase nbvmax in subroutine get_reftemp',ib
STOP
ELSE
!-----------------
!---------------- Get the area of the fine grid in the model grid
!-----------------
coslat = MAX(COS(lat_rel(ip,jp)*m_pi/180.),0.001)
ax = ( MIN(lon_up,loup_rel(ip,jp)) &
& -MAX(lon_low,lolow_rel(ip,jp))) &
& *m_pi/180.*R_Earth*coslat
ay = ( MIN(lat_up,laup_rel(ip,jp)) &
& -MAX(lat_low,lalow_rel(ip,jp))) &
& *m_pi/180.*R_Earth
area(fopt) = ax*ay
tt(fopt) = tref_file(ip,jp)
ENDIF
ENDIF
ENDDO
ENDIF
ENDDO
!-------
!------ Check that we found some points
!-------
trefe(ib) = 0.
!-------
IF (fopt == 0) THEN
do_again = .TRUE.
!-------
!------ increase search radius
!-------
resx = resx*2.
resy = resy*2.
IF ( resx > 2.*m_pi*R_Earth .OR. resy > m_pi*R_Earth ) THEN
STOP 'get_reftemp: found no point'
ENDIF
ELSE
sgn = zero
!-------
!------ Compute the average surface air temperature
!-------
DO ilf=1,fopt
trefe(ib) = trefe(ib) + tt(ilf) * area(ilf)
sgn = sgn + area(ilf)
ENDDO
!-------
!------ Normalize the surface
!-------
IF (sgn < min_sechiba) THEN
do_again = .TRUE.
!---------
!-------- increase search radius
!---------
resx = resx * 2.
resy = resy * 2.
IF ( resx > 2.*m_pi*R_Earth .OR. resy > m_pi*R_Earth ) THEN
STOP 'get_reftemp: found no point'
ENDIF
ELSE
trefe(ib) = trefe(ib) / sgn
ENDIF
ENDIF
ENDDO
ENDDO
!-
! transform into Kelvin
!-
trefe(:) = trefe(:) + ZeroCelsius
!-
! deallocate
!-
DEALLOCATE (lat_rel)
DEALLOCATE (lon_rel)
DEALLOCATE (laup_rel)
DEALLOCATE (loup_rel)
DEALLOCATE (lalow_rel)
DEALLOCATE (lolow_rel)
DEALLOCATE (lat_ful)
DEALLOCATE (lon_ful)
DEALLOCATE (tref_file)
ENDIF
!-
! 2 output the reference temperature
!-
tref_out(:) = trefe(:)
!-------------------------
END SUBROUTINE get_reftemp
!-
!===
!-
END MODULE stomate_io
ORCHIDEE/src_stomate/stomate_litter.f90 0000754 0103600 0005670 00000060314 11164403473 017633 0 ustar acamlmd lmdjus ! Update litter and lignine content after litter fall.
! Calculate litter decomposition.
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_litter.f90,v 1.7 2007/05/28 15:03:35 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_litter
! modules used:
USE ioipsl
USE stomate_constants
USE constantes_veg
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC littercalc,littercalc_clear, deadleaf
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE littercalc_clear
firstcall =.TRUE.
END SUBROUTINE littercalc_clear
SUBROUTINE littercalc (npts, dt, space_nat, &
turnover, bm_to_litter, &
tsurf, tsoil, soilhum, litterhum, &
litterpart, litter, dead_leaves, lignin_struc, &
deadleaf_cover, resp_hetero_litter, &
soilcarbon_input, control_temp, control_moist)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step in days
REAL(r_std), INTENT(in) :: dt
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! Turnover rates (gC/(m**2 of nat/agri ground)/day)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: turnover
! conversion of biomass to litter (gC/(m**2 of average nat. or agric. ground)) / day
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: bm_to_litter
! temperature (K) at the surface
REAL(r_std), DIMENSION(npts), INTENT(in) :: tsurf
! soil temperature (K)
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil
! daily soil humidity
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum
! daily litter humidity
REAL(r_std), DIMENSION(npts), INTENT(in) :: litterhum
! 0.2 modified fields
! fraction of litter above the ground belonging to different PFTs
REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: litterpart
! metabolic and structural litter, natural and agricultural,
! above and below ground (gC/m**2 of natural or agricultural ground)
REAL(r_std), DIMENSION(npts,nlitt,nvegtypes,nlevs), INTENT(inout) :: litter
! dead leaves on ground, per PFT, metabolic and structural,
! in gC/(m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: dead_leaves
! ratio Lignine/Carbon in structural litter, above and below ground,
! natural and agricultural (gC/m**2)
REAL(r_std), DIMENSION(npts,nvegtypes,nlevs), INTENT(inout) :: lignin_struc
! 0.3 output
! fraction of soil covered by dead leaves
REAL(r_std), DIMENSION(npts), INTENT(out) :: deadleaf_cover
! litter heterotrophic respiration (first in gC/day/m**2 of natural/agricultural ground,
! but output in gC/day/m**2 of total ground)
REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(out) :: resp_hetero_litter
! quantity of carbon going into carbon pools from litter decomposition
! (gC/(m**2 of nat/agri ground)/day)
REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(out) :: soilcarbon_input
! temperature control of heterotrophic respiration, above and below
REAL(r_std), DIMENSION(npts,nlevs), INTENT(out) :: control_temp
! moisture control of heterotrophic respiration
REAL(r_std), DIMENSION(npts,nlevs), INTENT(out) :: control_moist
! 0.4 local
! C/N ratio
REAL(r_std), SAVE, DIMENSION(nparts) :: CN
! what fraction of leaves, wood, etc. goes into metabolic and structural litterpools
REAL(r_std), SAVE, DIMENSION(nparts,nlitt) :: litterfrac
! Lignine/C ratio of the different plant parts
REAL(r_std), SAVE, DIMENSION(nparts) :: LC
! soil levels (m)
REAL(r_std), SAVE, DIMENSION(0:nbdl) :: z_soil
! scaling depth for soil activity (m)
REAL(r_std), PARAMETER :: z_decomp = 0.2
! integration constant for vertical profiles
REAL(r_std), DIMENSION(npts) :: rpc
! residence time in litter pools (days)
REAL(r_std), SAVE, DIMENSION(nlitt) :: litter_tau
! decomposition flux fraction that goes into soil (litter -> carbon, above and below)
! rest goes into atmosphere
REAL(r_std), SAVE, DIMENSION(nlitt,ncarb,nlevs) :: frac_soil
! temperature used for decompostition in soil (K)
REAL(r_std), DIMENSION(npts) :: tsoil_decomp
! humidity used for decompostition in soil
REAL(r_std), DIMENSION(npts) :: soilhum_decomp
! fraction of structural or metabolic litter decomposed
REAL(r_std), DIMENSION(npts) :: fd
! quantity of structural or metabolic litter decomposed (gC/m**2)
REAL(r_std), DIMENSION(npts) :: qd
! old structural litter, natural and agricultural, above and below (gC/m**2)
REAL(r_std), DIMENSION(npts,nvegtypes,nlevs) :: old_struc
! increase of litter, per PFT, metabolic and structural,
! above and below ground (gC/m**2 of natural or agricultural ground)
REAL(r_std), DIMENSION(npts,npft,nlitt,nlevs) :: litter_inc_PFT
! increase of metabolic and structural litter, natural and agricultural,
! above and below ground (gC/m**2 of natural or agricultural ground)
REAL(r_std), DIMENSION(npts,nlitt,nvegtypes,nlevs) :: litter_inc
! lignin increase in structural litter, natural and agricultural,
! above and below ground (gC/m**2 of natural or agricultural ground)
REAL(r_std), DIMENSION(npts,nvegtypes,nlevs) :: lignin_struc_inc
! metabolic and structural litter above the ground per PFT ( for natural PFTs)
REAL(r_std), DIMENSION(npts,npft,nlitt) :: litter_pft
! intermediate array for looking for minimum
REAL(r_std), DIMENSION(npts) :: zdiff_min
! for messages
CHARACTER*10, DIMENSION(nlitt) :: litter_str
CHARACTER*22, DIMENSION(nparts) :: part_str
CHARACTER*7, DIMENSION(ncarb) :: carbon_str
CHARACTER*5, DIMENSION(nlevs) :: level_str
! Indices
INTEGER(i_std) :: i,j,k,l,m
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering littercalc'
!
! 1 Initialisations
!
IF ( firstcall ) THEN
!
! 1.1 get soil "constants"
!
! 1.1.1 C/N ratios
CN(ileaf) = 40.0
CN(isapabove) = 40.0
CN(isapbelow) = 40.0
CN(iheartabove) = 40.0
CN(iheartbelow) = 40.0
CN(iroot) = 40.0
CN(ifruit) = 40.0
CN(icarbres) = 40.0
! 1.1.2 Lignine/C ratios
LC(ileaf) = 0.22
LC(isapabove) = 0.35
LC(isapbelow) = 0.35
LC(iheartabove) = 0.35
LC(iheartbelow) = 0.35
LC(iroot) = 0.22
LC(ifruit) = 0.22
LC(icarbres) = 0.22
! 1.1.3 litter fractions:
! what fraction of leaves, wood, etc. goes into metabolic and structural litterpools
DO k = 1, nparts
litterfrac(k,imetabolic) = 0.85 - 0.018 * LC(k) * CN(k)
litterfrac(k,istructural) = 1. - litterfrac(k,imetabolic)
ENDDO
! 1.1.4 residence times in litter pools (days)
litter_tau(imetabolic) = .066 * one_year !!!!???? .5 years
litter_tau(istructural) = .245 * one_year !!!!???? 3 years
! 1.1.5 decomposition flux fraction that goes into soil
! (litter -> carbon, above and below)
! 1-frac_soil goes into atmosphere
frac_soil(:,:,:) = zero
! structural litter: lignin fraction goes into slow pool + respiration,
! rest into active pool + respiration
frac_soil(istructural,iactive,iabove) = .55
frac_soil(istructural,iactive,ibelow) = .45
frac_soil(istructural,islow,iabove) = .7
frac_soil(istructural,islow,ibelow) = .7
! metabolic litter: all goes into active pool + respiration.
! Nothing into slow or passive pool.
frac_soil(imetabolic,iactive,iabove) = .45
frac_soil(imetabolic,iactive,ibelow) = .45
!
! 1.2 soil levels
!
z_soil(0) = 0.
z_soil(1:nbdl) = diaglev(1:nbdl)
!
! 1.3 messages
!
litter_str(imetabolic) = 'metabolic'
litter_str(istructural) = 'structural'
carbon_str(iactive) = 'active'
carbon_str(islow) = 'slow'
carbon_str(ipassive) = 'passive'
level_str(iabove) = 'above'
level_str(ibelow) = 'below'
part_str(ileaf) = 'leaves'
part_str(isapabove) = 'sap above ground'
part_str(isapbelow) = 'sap below ground'
part_str(iheartabove) = 'heartwood above ground'
part_str(iheartbelow) = 'heartwood below ground'
part_str(iroot) = 'roots'
part_str(ifruit) = 'fruits'
part_str(icarbres) = 'carbohydrate reserve'
WRITE(numout,*) 'litter:'
WRITE(numout,*) ' > C/N ratios: '
DO k = 1, nparts
WRITE(numout,*) ' ', part_str(k), ': ',CN(k)
ENDDO
WRITE(numout,*) ' > Lignine/C ratios: '
DO k = 1, nparts
WRITE(numout,*) ' ', part_str(k), ': ',LC(k)
ENDDO
WRITE(numout,*) ' > fraction of compartment that goes into litter: '
DO k = 1, nparts
DO m = 1, nlitt
WRITE(numout,*) ' ', part_str(k), '-> ',litter_str(m), ':',litterfrac(k,m)
ENDDO
ENDDO
WRITE(numout,*) ' > scaling depth for decomposition (m): ',z_decomp
WRITE(numout,*) ' > minimal carbon residence time in litter pools (d):'
DO m = 1, nlitt
WRITE(numout,*) ' ',litter_str(m),':',litter_tau(m)
ENDDO
WRITE(numout,*) ' > litter decomposition flux fraction that really goes '
WRITE(numout,*) ' into carbon pools (rest into the atmosphere):'
DO m = 1, nlitt
DO l = 1, nlevs
DO k = 1, ncarb
WRITE(numout,*) ' ',litter_str(m),' ',level_str(l),' -> ',&
carbon_str(k),':', frac_soil(m,k,l)
ENDDO
ENDDO
ENDDO
firstcall = .FALSE.
ENDIF
!
! 1.3 litter above the ground per PFT.
!
DO j = 1, npft
IF ( natural(j) ) THEN
m = inat
ELSE
m = iagri
ENDIF
DO k = 1, nlitt
litter_pft(:,j,k) = litterpart(:,j,k) * litter(:,k,m,iabove)
ENDDO
ENDDO
!
! 1.4 set output to zero
!
deadleaf_cover(:) = zero
resp_hetero_litter(:,:) = zero
soilcarbon_input(:,:,:) = zero
!
! 2 Add biomass to different litterpools (per m**2 of nat/agri ground)
!
!
! 2.1 first, save old structural litter (needed for lignin fractions).
! nat/agri, above/below
!
DO l = 1, nlevs
DO m = 1, nvegtypes
old_struc(:,m,l) = litter(:,istructural,m,l)
ENDDO
ENDDO
!
! 2.2 update litter, dead leaves, and lignin content in structural litter
!
litter_inc(:,:,:,:) = zero
lignin_struc_inc(:,:,:) = zero
DO j = 1, npft
! 2.2.1 natural or agricultural litter
IF ( natural(j) ) THEN
m = inat
ELSE
m = iagri
ENDIF
DO k = 1, nlitt ! metabolic and structural
! 2.2.2 calculate litter increase (per m**2 of average agricultural or
! natural ground).
! Only a given fracion of fruit turnover is directly coverted into litter.
! Litter increase for each PFT, structural and metabolic, above/below
litter_inc_PFT(:,j,k,iabove) = &
litterfrac(ileaf,k) * bm_to_litter(:,j,ileaf) + &
litterfrac(isapabove,k) * bm_to_litter(:,j,isapabove) + &
litterfrac(iheartabove,k) * bm_to_litter(:,j,iheartabove) + &
litterfrac(ifruit,k) * bm_to_litter(:,j,ifruit) + &
litterfrac(icarbres,k) * bm_to_litter(:,j,icarbres) + &
litterfrac(ileaf,k) * turnover(:,j,ileaf) + &
litterfrac(isapabove,k) * turnover(:,j,isapabove) + &
litterfrac(iheartabove,k) * turnover(:,j,iheartabove) + &
litterfrac(ifruit,k) * turnover(:,j,ifruit) + &
litterfrac(icarbres,k) * turnover(:,j,icarbres)
litter_inc_PFT(:,j,k,ibelow) = &
litterfrac(isapbelow,k) * bm_to_litter(:,j,isapbelow) + &
litterfrac(iheartbelow,k) * bm_to_litter(:,j,iheartbelow) + &
litterfrac(iroot,k) * bm_to_litter(:,j,iroot) + &
litterfrac(isapbelow,k) * turnover(:,j,isapbelow) + &
litterfrac(iheartbelow,k) * turnover(:,j,iheartbelow) + &
litterfrac(iroot,k) * turnover(:,j,iroot)
! litter increase, met/struct, nat/agri, above/below
litter_inc(:,k,m,iabove) = litter_inc(:,k,m,iabove) + litter_inc_PFT(:,j,k,iabove)
litter_inc(:,k,m,ibelow) = litter_inc(:,k,m,ibelow) + litter_inc_PFT(:,j,k,ibelow)
! 2.2.3 dead leaves, for soil cover.
dead_leaves(:,j,k) = &
dead_leaves(:,j,k) + &
litterfrac(ileaf,k) * ( bm_to_litter(:,j,ileaf) + turnover(:,j,ileaf) )
! 2.2.4 lignin increase in structural litter
IF ( k .EQ. istructural ) THEN
lignin_struc_inc(:,m,iabove) = &
lignin_struc_inc(:,m,iabove) + &
LC(ileaf) * bm_to_litter(:,j,ileaf) + &
LC(isapabove) * bm_to_litter(:,j,isapabove) + &
LC(iheartabove) * bm_to_litter(:,j,iheartabove) + &
LC(ifruit) * bm_to_litter(:,j,ifruit) + &
LC(icarbres) * bm_to_litter(:,j,icarbres) + &
LC(ileaf) * turnover(:,j,ileaf) + &
LC(isapabove) * turnover(:,j,isapabove) + &
LC(iheartabove) * turnover(:,j,iheartabove) + &
LC(ifruit) * turnover(:,j,ifruit) + &
LC(icarbres) * turnover(:,j,icarbres)
lignin_struc_inc(:,m,ibelow) = &
lignin_struc_inc(:,m,ibelow) + &
LC(isapbelow) * bm_to_litter(:,j,isapbelow) + &
LC(iheartbelow) * bm_to_litter(:,j,iheartbelow) + &
LC(iroot) * bm_to_litter(:,j,iroot) + &
LC(isapbelow)*turnover(:,j,isapbelow) + &
LC(iheartbelow)*turnover(:,j,iheartbelow) + &
LC(iroot)*turnover(:,j,iroot)
ENDIF
ENDDO
ENDDO
! 3.2.5 add new litter (struct/met, nat/agri, above/below)
litter(:,:,:,:) = litter(:,:,:,:) + litter_inc(:,:,:,:)
! 3.2.6 for security: can't add more lignin than structural litter
! (nat/agri, above/below)
DO l = 1, nlevs
DO m = 1, nvegtypes
lignin_struc_inc(:,m,l) = &
MIN( lignin_struc_inc(:,m,l), litter_inc(:,istructural,m,l) )
ENDDO
ENDDO
! 3.2.7 new lignin content: add old lignin and lignin increase, divide by
! total structural litter (nat/agri, above/below)
WHERE ( litter(:,istructural,:,:) .GT. 0.0 )
lignin_struc(:,:,:) = &
( lignin_struc(:,:,:)*old_struc(:,:,:) + lignin_struc_inc(:,:,:) ) / &
litter(:,istructural,:,:)
ELSEWHERE
lignin_struc(:,:,:) = zero
ENDWHERE
!
! 3.3 new litter fraction per PFT (for structural and metabolic litter, above
! the ground). Fractions are calculated separately for the natural and
! for the agricultural ground.
!
DO j = 1, npft
IF ( natural(j) ) THEN
m = inat
ELSE
m = iagri
ENDIF
WHERE ( litter(:,:,m,iabove) .GT. 0.0 )
litterpart(:,j,:) = &
( litter_pft(:,j,:) + litter_inc_PFT(:,j,:,iabove) ) / litter(:,:,m,iabove)
ELSEWHERE
litterpart(:,j,:) = zero
ENDWHERE
ENDDO
!
! 4 Temperature control on decay: Factor between 0 and 1
!
!
! 4.1 above: surface temperature
!
control_temp(:,iabove) = control_temp_func (npts, tsurf)
!
! 4.2 below: convolution of temperature and decomposer profiles
! (exponential decomposer profile supposed)
!
! 4.2.1 rpc is an integration constant such that the integral of the root profile is 1.
rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_decomp ) )
! 4.2.2 integrate over the nbdl levels
tsoil_decomp(:) = 0.0
DO l = 1, nbdl
tsoil_decomp(:) = &
tsoil_decomp(:) + tsoil(:,l) * rpc(:) * &
( EXP( -z_soil(l-1)/z_decomp ) - EXP( -z_soil(l)/z_decomp ) )
ENDDO
control_temp(:,ibelow) = control_temp_func (npts, tsoil_decomp)
!
! 5 Moisture control. Factor between 0 and 1
!
!
! 5.1 above the ground: litter humidity
!
control_moist(:,iabove) = control_moist_func (npts, litterhum)
!
! 5.2 below: convolution of humidity and decomposer profiles
! (exponential decomposer profile supposed)
!
! 5.2.1 rpc is an integration constant such that the integral of the root profile is 1.
rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_decomp ) )
! 5.2.2 integrate over the nbdl levels
soilhum_decomp(:) = 0.0
DO l = 1, nbdl
soilhum_decomp(:) = &
soilhum_decomp(:) + soilhum(:,l) * rpc(:) * &
( EXP( -z_soil(l-1)/z_decomp ) - EXP( -z_soil(l)/z_decomp ) )
ENDDO
control_moist(:,ibelow) = control_moist_func (npts, soilhum_decomp)
!
! 6 fluxes from litter to carbon pools and respiration
!
DO l = 1, nlevs
DO m = 1, nvegtypes
!
! 6.1 structural litter: goes into active and slow carbon pools + respiration
!
! 6.1.1 total quantity of structural litter which is decomposed
fd(:) = dt/litter_tau(istructural) * &
control_temp(:,l) * control_moist(:,l) * exp( -3. * lignin_struc(:,m,l) )
qd(:) = litter(:,istructural,m,l) * fd(:)
litter(:,istructural,m,l) = litter(:,istructural,m,l) - qd(:)
! 6.1.2 decompose same fraction of structural part of dead leaves. Not exact
! as lignine content is not the same as that of the total structural litter.
! to avoid a multiple (for ibelow and iabove) modification of dead_leaves,
! we do this test to do this calcul only ones in 1,nlev loop
if (l == iabove) dead_leaves(:,m,istructural) = dead_leaves(:,m,istructural) * ( 1. - fd(:) )
! 6.1.3 non-lignin fraction of structural litter goes into
! active carbon pool + respiration
soilcarbon_input(:,iactive,m) = soilcarbon_input(:,iactive,m) + &
frac_soil(istructural,iactive,l) * qd(:) * ( 1. - lignin_struc(:,m,l) ) / dt
resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
( 1. - frac_soil(istructural,iactive,l) ) * qd(:) * &
( 1. - lignin_struc(:,m,l) ) / dt
! 6.1.4 lignin fraction of structural litter goes into
! slow carbon pool + respiration
soilcarbon_input(:,islow,m) = soilcarbon_input(:,islow,m) + &
frac_soil(istructural,islow,l) * qd(:) * lignin_struc(:,m,l) / dt
resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
( 1. - frac_soil(istructural,islow,l) ) * qd(:) * lignin_struc(:,m,l) / dt
!
! 6.2 metabolic litter goes into active carbon pool + respiration
!
! 6.2.1 total quantity of metabolic litter that is decomposed
fd(:) = dt/litter_tau(imetabolic) * control_temp(:,l) * control_moist(:,l)
qd(:) = litter(:,imetabolic,m,l) * fd(:)
litter(:,imetabolic,m,l) = litter(:,imetabolic,m,l) - qd(:)
! 6.2.2 decompose same fraction of metabolic part of dead leaves.
! to avoid a multiple (for ibelow and iabove) modification of dead_leaves,
! we do this test to do this calcul only ones in 1,nlev loop
if (l == iabove) dead_leaves(:,m,imetabolic) = dead_leaves(:,m,imetabolic) * ( 1. - fd(:) )
! 6.2.3 put decomposed litter into carbon pool + respiration
soilcarbon_input(:,iactive,m) = soilcarbon_input(:,iactive,m) + &
frac_soil(imetabolic,iactive,l) * qd(:) / dt
resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
( 1. - frac_soil(imetabolic,iactive,l) ) * qd(:) / dt
ENDDO
ENDDO
!
! 7 transform respiration from gC/day/(m**2 of nat/agri ground) to
! gC/day/(m**2 of total ground), as it goes into the atmosphere.
!
resp_hetero_litter(:,iagri) = resp_hetero_litter(:,iagri) * ( 1. - space_nat(:) )
resp_hetero_litter(:,inat) = resp_hetero_litter(:,inat) * ( space_nat(:) )
!
! 8 calculate fraction of total soil covered by dead leaves
!
CALL deadleaf (npts, space_nat, dead_leaves, deadleaf_cover)
IF (bavard.GE.4) WRITE(numout,*) 'Leaving littercalc'
END SUBROUTINE littercalc
SUBROUTINE deadleaf (npts, space_nat, dead_leaves, deadleaf_cover)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! dead leaves on ground, per PFT, metabolic and structural,
! in gC/(m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(in) :: dead_leaves
! 0.2. output
! fraction of soil covered by dead leaves
REAL(r_std), DIMENSION(npts), INTENT(out) :: deadleaf_cover
! 0.3. local
! LAI of dead leaves
REAL(r_std), DIMENSION(npts) :: dead_lai
! Index
INTEGER(i_std) :: j
!
! 1 LAI of dead leaves
!
dead_lai(:) = zero
DO j = 1, npft
IF ( natural(j) ) THEN
dead_lai(:) = dead_lai(:) + space_nat(:) * &
( dead_leaves(:,j,imetabolic) + dead_leaves(:,j,istructural) ) * sla(j)
ELSE
dead_lai(:) = dead_lai(:) + ( 1. - space_nat(:) ) * &
( dead_leaves(:,j,imetabolic) + dead_leaves(:,j,istructural) ) * sla(j)
ENDIF
ENDDO
!
! 2 fraction of soil covered by dead leaves
!
deadleaf_cover(:) = 1. - exp( - 0.5 * dead_lai(:) )
IF (bavard.GE.4) WRITE(numout,*) 'Leaving deadleaf'
END SUBROUTINE deadleaf
FUNCTION control_moist_func (npts, moist_in) RESULT (moistfunc_result)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! relative humidity
REAL(r_std), DIMENSION(npts), INTENT(in) :: moist_in
! 0.2 result
! moisture control factor
REAL(r_std), DIMENSION(npts) :: moistfunc_result
moistfunc_result(:) = -1.1 * moist_in(:) * moist_in(:) + 2.4 * moist_in(:) - 0.29
moistfunc_result(:) = MAX( 0.25_r_std, MIN( 1._r_std, moistfunc_result(:) ) )
END FUNCTION control_moist_func
FUNCTION control_temp_func (npts, temp_in) RESULT (tempfunc_result)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! temperature (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: temp_in
! 0.2 result
! temperature control factor
REAL(r_std), DIMENSION(npts) :: tempfunc_result
tempfunc_result(:) = exp( 0.69 * ( temp_in(:) - (ZeroCelsius+30.) ) / 10. )
tempfunc_result(:) = MIN( 1._r_std, tempfunc_result(:) )
END FUNCTION control_temp_func
END MODULE stomate_litter
ORCHIDEE/src_stomate/stomate_lpj.f90 0000754 0103600 0005670 00000107417 11164403473 017123 0 ustar acamlmd lmdjus ! Stomate: phenology, allocation, etc.
!
! authors: A. Botta, P. Friedlingstein, C. Morphopoulos, N. Viovy, et al.
!
! bits and pieces put together by G. Krinner
!
! version 0.0: August 1998
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_lpj.f90,v 1.14 2007/06/13 07:44:34 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_lpj
! modules used:
USE ioipsl
USE stomate_constants
USE lpj_constraints
USE lpj_pftinout
USE lpj_kill
USE lpj_crown
USE lpj_fire
USE lpj_gap
USE lpj_light
USE lpj_establish
USE lpj_cover
USE stomate_prescribe
USE stomate_phenology
USE stomate_alloc
USE stomate_npp
USE stomate_turnover
USE stomate_litter
USE stomate_soilcarbon
USE stomate_vmax
USE stomate_assimtemp
! routine added
USE stomate_deforestation
USE stomate_natagritot
! USE Write_Field_p
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC StomateLpj,StomateLpj_clear
CONTAINS
SUBROUTINE StomateLpj_clear
CALL prescribe_clear
CALL phenology_clear
CALL npp_calc_clear
CALL turn_clear
CALL soilcarbon_clear
CALL constraints_clear
CALL establish_clear
CALL fire_clear
CALL gap_clear
CALL light_clear
CALL pftinout_clear
CALL alloc_clear
END SUBROUTINE StomateLpj_clear
SUBROUTINE StomateLpj (npts, dt_days, EndOfYear, &
neighbours, resolution, space_nat, &
clay, herbivores, &
tsurf_daily, tsoil_daily, t2m_daily, t2m_min_daily, &
litterhum_daily, soilhum_daily, &
maxmoiavail_lastyear, minmoiavail_lastyear, &
gdd0_lastyear, precip_lastyear, &
moiavail_month, moiavail_week, tlong_ref, t2m_month, t2m_week, &
tsoil_month, soilhum_month, &
gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
turnover_longterm, gpp_daily, time_lowgpp, &
time_hum_min, maxfpc_lastyear, resp_maint_part, &
PFTpresent, age, fireindex, firelitter, &
leaf_age, leaf_frac, biomass, ind, adapted, regenerate, &
senescence, when_growthinit, &
litterpart, litter, dead_leaves, carbon, black_carbon, lignin_struc, &
veget_max, veget, npp_longterm, lm_lastyearmax, veget_lastlight, &
everywhere, need_adjacent, RIP_time, &
lai, rprof,npp_daily, turnover_daily, turnover_time,&
control_moist, control_temp, soilcarbon_input, &
co2_to_bm, co2_fire, resp_hetero, resp_maint, resp_growth, &
height, deadleaf_cover, vcmax, vjmax, t_photo_min, t_photo_opt, t_photo_max,bm_to_litter, &
prod10,prod100,flux10, flux100, space_nat_new,veget_max_new, &
convflux,cflux_prod10,cflux_prod100, defor)
! deforestation variables added as arguments
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step of Stomate in days
REAL(r_std), INTENT(in) :: dt_days
! indices of the 8 neighbours of each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
INTEGER(i_std), DIMENSION(npts,8), INTENT(in) :: neighbours
! resolution at each grid point in m (1=E-W, 2=N-S)
REAL(r_std), DIMENSION(npts,2), INTENT(in) :: resolution
! total natural space (fraction of total space)
! REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
REAL(r_std), DIMENSION(npts), INTENT(inout) :: space_nat
! clay fraction
REAL(r_std), DIMENSION(npts), INTENT(in) :: clay
! time constant of probability of a leaf to be eaten by a herbivore (days)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: herbivores
! daily surface temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: tsurf_daily
! daily soil temperatures (K)
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil_daily
! daily 2 meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_daily
! daily minimum 2 meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_min_daily
! daily litter humidity
REAL(r_std), DIMENSION(npts), INTENT(in) :: litterhum_daily
! daily soil humidity
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum_daily
! last year's maximum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
! last year's minimum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
! last year's GDD0
REAL(r_std), DIMENSION(npts), INTENT(in) :: gdd0_lastyear
! lastyear's precipitation (mm/year)
REAL(r_std), DIMENSION(npts), INTENT(in) :: precip_lastyear
! "monthly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
! "weekly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
! "long term" 2 meter reference temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
! "monthly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
! "weekly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
! "monthly" soil temperatures (K)
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil_month
! "monthly" soil humidity
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum_month
! growing degree days, threshold -5 deg C (for phenology)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gdd_m5_dormance
! growing degree days, since midwinter (for phenology)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_midwinter
! number of chilling days, since leaves were lost (for phenology)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ncd_dormance
! number of growing days, threshold -5 deg C (for phenology)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ngd_minus5
! "long term" turnover rate (gC/(m**2 of nat/agri ground)/year)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: turnover_longterm
! daily gross primary productivity (gC/(m**2 of nat/agri ground)/day)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gpp_daily
! duration of dormance (d)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_lowgpp
! time elapsed since strongest moisture availability (d)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_hum_min
! last year's maximum fpc for each natural PFT, on *natural* ground
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxfpc_lastyear
! maintenance respiration of different plant parts (gC/day/m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,nparts,npft), INTENT(in) :: resp_maint_part
! 0.2 modified fields
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
! age (years)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
! Probability of fire
REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: fireindex
! Longer term litter above the ground, gC/m**2 of nat/agri ground
REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: firelitter
! leaf age (days)
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! density of individuals (1/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
! Winter too cold? between 0 and 1
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: adapted
! Winter sufficiently cold? between 0 and 1
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: regenerate
! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: senescence
! how many days ago was the beginning of the growing season
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
! fraction of litter above the ground belonging to different PFTs
REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: litterpart
! metabolic and structural litter, natural and agricultural,
! above and below ground (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,nlitt,nvegtypes,nlevs), INTENT(inout) :: litter
! dead leaves on ground, per PFT, metabolic and structural,
! in gC/(m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: dead_leaves
! carbon pool: active, slow, or passive, natural and agricultural
! (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(inout) :: carbon
! black carbon on the ground (gC/(m**2 of total ground))
REAL(r_std), DIMENSION(npts), INTENT(inout) :: black_carbon
! ratio Lignine/Carbon in structural litter, above and below ground,
! natural and agricultural (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,nvegtypes,nlevs), INTENT(inout) :: lignin_struc
! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
! fractional coverage on natural/agricultural ground, taking into
! account LAI (=grid-scale fpc)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
! "long term" net primary productivity (gC/(m**2 of nat/agri ground)/year)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: npp_longterm
! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_lastyearmax
! vegetation fractions (on natural/agri ground) after last light competition
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_lastlight
! is the PFT everywhere in the grid box or very localized (after its introduction)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
! in order for this PFT to be introduced, does it have to be present in an
! adjacent grid box?
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: need_adjacent
! How much time ago was the PFT eliminated for the last time (y)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: RIP_time
! Turnover_time of leaves for grasses (d)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: turnover_time
! 0.3 output
! leaf area index OF AN INDIVIDUAL PLANT
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lai
! root depth. This will, one day, be a prognostic variable. It will be calculated by
! STOMATE (save in restart file & give to hydrology module!), probably somewhere
! in the allocation routine. For the moment, it is prescribed.
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: rprof
! net primary productivity (gC/day/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: npp_daily
! Turnover rates (gC/(m**2 of nat/agri ground)/day)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: turnover_daily
! moisture control of heterotrophic respiration
REAL(r_std), DIMENSION(npts,nlevs), INTENT(inout) :: control_moist
! temperature control of heterotrophic respiration, above and below
REAL(r_std), DIMENSION(npts,nlevs), INTENT(inout) :: control_temp
! quantity of carbon going into carbon pools from litter decomposition
! (gC/(m**2 of nat/agri ground)/day)
REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(inout) :: soilcarbon_input
! co2 taken up (gC/(m**2 of total ground)/day)
REAL(r_std), DIMENSION(npts), INTENT(out) :: co2_to_bm
! carbon emitted into the atmosphere by fire (living and dead biomass)
! (in gC/m**2 of total ground/day)
REAL(r_std), DIMENSION(npts), INTENT(out) :: co2_fire
! heterotrophic respiration (gC/day/m**2 of total ground)
REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: resp_hetero
! maintenance respiration (gC/day/(m**2 of total ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: resp_maint
! growth respiration (gC/day/(m**2 of total ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: resp_growth
! height of vegetation (m)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: height
! fraction of soil covered by dead leaves
REAL(r_std), DIMENSION(npts), INTENT(out) :: deadleaf_cover
! Maximum rate of carboxylation
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: vcmax
! Maximum rate of RUbp regeneration
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: vjmax
! Minimum temperature for photosynthesis (deg C)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_min
! Optimum temperature for photosynthesis (deg C)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_opt
! Maximum temperature for photosynthesis (deg C)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_max
! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: bm_to_litter
! 0.4 local
! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
! REAL(r_std), DIMENSION(npts,npft,nparts) :: bm_to_litter
! total conversion of biomass to litter (gC/(m**2)) / day
REAL(r_std), DIMENSION(npts,npft) :: tot_bm_to_litter
! total living biomass (gC/(m**2))
REAL(r_std), DIMENSION(npts,npft) :: tot_live_biomass
! total turnover rate (gC/(m**2)) / day
REAL(r_std), DIMENSION(npts,npft) :: tot_turnover
! total soil and litter carbon (gC/(m**2))
REAL(r_std), DIMENSION(npts) :: tot_soil_carb
! crown area of individuals (m**2)
REAL(r_std), DIMENSION(npts,npft) :: cn_ind
! fraction that goes into plant part
REAL(r_std), DIMENSION(npts,npft,nparts) :: f_alloc
! space availability for trees
REAL(r_std), DIMENSION(npts) :: avail_tree
! space availability for grasses
REAL(r_std), DIMENSION(npts) :: avail_grass
! deforestation variables + EndOfYear
! Do update of yearly variables? This variable must be .TRUE. once a year
LOGICAL :: EndOfYear
! new "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft),INTENT(in) :: veget_max_new
! new total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat_new
! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
! (10 or 100 + 1 : input from year of deforestation)
REAL(r_std),DIMENSION(npts,0:10), INTENT(inout) :: prod10
REAL(r_std),DIMENSION(npts,0:100), INTENT(inout) :: prod100
! annual release from the 10/100 year-turnover pool compartments
REAL(r_std),DIMENSION(npts,10), INTENT(inout) :: flux10
REAL(r_std),DIMENSION(npts,100), INTENT(inout) :: flux100
! release during first year following deforestation
REAL(r_std),DIMENSION(npts) :: convflux
! total annual release from the 10/100 year-turnover pool
REAL(r_std),DIMENSION(npts) :: cflux_prod10, cflux_prod100
! total products remaining in the pool after the annual release
REAL(r_std),DIMENSION(npts) :: prod10_total, prod100_total
! total flux from conflux and the 10/100 year-turnover pool
REAL(r_std),DIMENSION(npts) :: cflux_prod_total
! deforestation flag
LOGICAL, INTENT(in) :: defor
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering stomate_lpj'
!
! 1 Initializations
!
!
! 1.1 set outputs to zero
!
co2_to_bm(:) = 0.0
co2_fire(:) = 0.0
npp_daily(:,:) = 0.0
turnover_daily(:,:,:) = 0.0
resp_maint(:,:) = 0.0
resp_growth(:,:) = 0.0
!
! 1.2 initialize some variables
!
bm_to_litter(:,:,:) = 0.0
cn_ind(:,:) = 0.0
!
! 1.3 Prescribe some vegetation characteristics if the vegetation is not dynamic and
! for agricultural PFTs.
! IF the DGVM is not activated, the density of individuals and their crown
! areas don't matter, but they should be defined for the case we switch on
! the DGVM afterwards.
! At first call, if the DGVM is not activated, impose a minimum biomass for
! prescribed PFTs and declare them present.
!
CALL prescribe (npts, &
space_nat, &
veget_max, PFTpresent, everywhere, when_growthinit, &
biomass, leaf_frac, ind, cn_ind)
!
! 2 climatic constraints for PFT presence and regenerativeness
! call this even when DGVM is not activated so that "adapted" and "regenerate"
! are kept up to date for the moment when the DGVM is activated.
!
CALL constraints (npts, dt_days, &
t2m_month, t2m_min_daily, when_growthinit, &
adapted, regenerate)
!
! 3 PFTs in and out, based on climate criteria
!
IF ( control%ok_dgvm ) THEN
!
! 3.1 do introduction/elimination
!
CALL pftinout (npts, dt_days, adapted, regenerate, &
neighbours, space_nat, veget, veget_max, &
biomass, ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, &
PFTpresent, everywhere, when_growthinit, need_adjacent, RIP_time, &
co2_to_bm, &
avail_tree, avail_grass)
!
! 3.2 reset attributes for eliminated PFTs.
! This also kills PFTs that had 0 leafmass during the last year. The message
! "... after pftinout" is misleading in this case.
!
CALL kill (npts, 'pftinout ', lm_lastyearmax, &
ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
lai, age, leaf_age, leaf_frac, &
when_growthinit, everywhere, veget, veget_max, bm_to_litter)
!
! 3.3 calculate new crown area and maximum vegetation cover
!
CALL crown (npts, PFTpresent, &
ind, biomass, &
veget_max, cn_ind, height)
ENDIF
!
! 4 phenology
!
CALL phenology (npts, dt_days, PFTpresent, &
veget_max, space_nat, &
tlong_ref, t2m_month, t2m_week, gpp_daily, &
maxmoiavail_lastyear, minmoiavail_lastyear, &
moiavail_month, moiavail_week, &
gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
senescence, time_lowgpp, time_hum_min, &
biomass, leaf_frac, leaf_age, &
when_growthinit, co2_to_bm, lai)
!
! 5 allocation
!
CALL alloc (npts, dt_days, &
lai, veget_max, senescence, when_growthinit, &
moiavail_week, tsoil_month, soilhum_month, &
biomass, leaf_age, leaf_frac, rprof, f_alloc)
!
! 6 maintenance and growth respiration. NPP
!
CALL npp_calc (npts, dt_days, space_nat, &
PFTpresent, &
tlong_ref, t2m_daily, tsoil_daily, lai, rprof, &
gpp_daily, f_alloc, resp_maint_part,&
biomass, leaf_age, leaf_frac, age, &
resp_maint, resp_growth, npp_daily)
IF ( control%ok_dgvm ) THEN
! new provisional crown area and maximum vegetation cover after growth
CALL crown (npts, PFTpresent, &
ind, biomass, &
veget_max, cn_ind, height)
ENDIF
!
! 7 fire.
!
CALL fire (npts, dt_days, space_nat, litterpart, &
litterhum_daily, t2m_daily, lignin_struc, &
fireindex, firelitter, biomass, ind, &
litter, dead_leaves, bm_to_litter, black_carbon, &
co2_fire)
IF ( control%ok_dgvm ) THEN
! reset attributes for eliminated PFTs
CALL kill (npts, 'fire ', lm_lastyearmax, &
ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
lai, age, leaf_age, leaf_frac, &
when_growthinit, everywhere, veget, veget_max, bm_to_litter)
ENDIF
!
! 8 tree mortality. Does not depend on age, therefore does not change crown area.
!
CALL gap (npts, dt_days, &
npp_longterm, turnover_longterm, lm_lastyearmax, &
PFTpresent, biomass, ind, bm_to_litter)
IF ( control%ok_dgvm ) THEN
! reset attributes for eliminated PFTs
CALL kill (npts, 'gap ', lm_lastyearmax, &
ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
lai, age, leaf_age, leaf_frac, &
when_growthinit, everywhere, veget, veget_max, bm_to_litter)
ENDIF
!
! 9 calculate vcmax, vjmax and photosynthesis temperatures
!
CALL vmax (npts, dt_days, &
leaf_age, leaf_frac, &
vcmax, vjmax)
CALL assim_temp (npts, tlong_ref, t2m_month, &
t_photo_min, t_photo_opt, t_photo_max)
!
! 10 leaf senescence and other turnover processes. New lai
!
CALL turn (npts, dt_days, PFTpresent, &
herbivores, &
maxmoiavail_lastyear, minmoiavail_lastyear, &
moiavail_week, moiavail_month,tlong_ref, t2m_month, t2m_week, veget_max, &
leaf_age, leaf_frac, age, lai, biomass, &
turnover_daily, senescence,turnover_time)
!
! 11 light competition
!
IF ( control%ok_dgvm ) THEN
!
! 11.1 do light competition
!
CALL light (npts, dt_days, &
PFTpresent, cn_ind, lai, maxfpc_lastyear, &
ind, biomass, veget_lastlight, bm_to_litter)
!
! 11.2 reset attributes for eliminated PFTs
!
CALL kill (npts, 'light ', lm_lastyearmax, &
ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
lai, age, leaf_age, leaf_frac, &
when_growthinit, everywhere, veget, veget_max, bm_to_litter)
ENDIF
!
! 12 establishment of saplings
!
IF ( control%ok_dgvm ) THEN
!
! 12.1 do establishment
!
CALL establish (npts, dt_days, PFTpresent, regenerate, &
neighbours, resolution, space_nat, need_adjacent, herbivores, &
precip_lastyear, gdd0_lastyear, lm_lastyearmax, &
cn_ind, lai, avail_tree, avail_grass, &
leaf_age, leaf_frac, &
ind, biomass, age, everywhere, co2_to_bm)
!
! 12.2 calculate new crown area (and maximum vegetation cover)
!
CALL crown (npts, PFTpresent, &
ind, biomass, &
veget_max, cn_ind, height)
ENDIF
!
! 13 calculate final LAI and vegetation cover.
!
CALL cover (npts, cn_ind, ind, biomass, &
veget_max, veget, lai)
!
! 14 the whole litter stuff:
! litter update, lignin content, PFT parts, litter decay,
! litter heterotrophic respiration, dead leaf soil cover.
! No vertical discretisation in the soil for litter decay.
!
! 15.1 deforestation
IF(defor) then
IF(EndOfYear) then
CALL deforestation (npts, dt_days, space_nat,space_nat_new, veget_max, veget_max_new, &
biomass, ind, age, PFTpresent, senescence, when_growthinit, &
everywhere, veget, &
co2_to_bm, bm_to_litter, bm_sapl, tree, cn_ind,flux10,flux100, &
prod10,prod100,prod10_total,prod100_total,&
convflux,cflux_prod_total,cflux_prod10,cflux_prod100,leaf_frac,&
npp_longterm, lm_lastyearmax)
ENDIF
ENDIF
tot_soil_carb = (litter(:,istructural,inat,iabove) + litter(:,imetabolic,inat,iabove) + &
& litter(:,istructural,inat,ibelow) + litter(:,imetabolic,inat,ibelow) + &
& carbon(:,iactive,inat) + &
& carbon(:,islow,inat)+ carbon(:,ipassive,inat))*space_nat(:) + &
& (litter(:,istructural,iagri,iabove)+ litter(:,istructural,iagri,ibelow) + &
& litter(:,imetabolic,iagri,ibelow) + litter(:,imetabolic,iagri,iabove) + &
& carbon(:,iactive,iagri) + carbon(:,islow,iagri) + &
& carbon(:,ipassive,iagri))*(1-space_nat(:))+ deadleaf_cover
tot_live_biomass = biomass(:,:,ileaf) + biomass(:,:,isapabove) + biomass(:,:,isapbelow) +&
& biomass(:,:,iheartabove) + biomass(:,:,iheartbelow) + &
& biomass(:,:,iroot)+ biomass(:,:,ifruit)+ biomass(:,:,icarbres)
tot_turnover = turnover_daily(:,:,ileaf) + turnover_daily(:,:,isapabove) + &
& turnover_daily(:,:,isapbelow) + turnover_daily(:,:,iheartabove) + &
& turnover_daily(:,:,iheartbelow) + turnover_daily(:,:,iroot) + &
& turnover_daily(:,:,ileaf) + turnover_daily(:,:,icarbres)
tot_bm_to_litter = bm_to_litter(:,:,ileaf) + bm_to_litter(:,:,isapabove) +&
& bm_to_litter(:,:,isapbelow) + bm_to_litter(:,:,iheartbelow) +&
& bm_to_litter(:,:,iheartabove) + bm_to_litter(:,:,iroot) + &
& bm_to_litter(:,:,ifruit) + bm_to_litter(:,:,icarbres)
!
! 17 history
!
! 2d
CALL histwrite (hist_id_stomate, 'RESOLUTION_X', itime, &
resolution(:,1), npts, hori_index)
CALL histwrite (hist_id_stomate, 'RESOLUTION_Y', itime, &
resolution(:,2), npts, hori_index)
CALL histwrite (hist_id_stomate, 'SPACE_NAT', itime, &
space_nat(:), npts, hori_index)
! CALL histwrite (hist_id_stomate, 'TOTAL_SOIL_CARB', itime, &
! tot_soil_carb, npts, hori_index)
CALL histwrite (hist_id_stomate, 'LITTER_STR_AB_NAT', itime, &
litter(:,istructural,inat,iabove), npts, hori_index)
CALL histwrite (hist_id_stomate, 'LITTER_STR_AB_AGRI', itime, &
litter(:,istructural,iagri,iabove), npts, hori_index)
CALL histwrite (hist_id_stomate, 'LITTER_MET_AB_NAT', itime, &
litter(:,imetabolic,inat,iabove), npts, hori_index)
CALL histwrite (hist_id_stomate, 'LITTER_MET_AB_AGRI', itime, &
litter(:,imetabolic,iagri,iabove), npts, hori_index)
CALL histwrite (hist_id_stomate, 'LITTER_STR_BE_NAT', itime, &
litter(:,istructural,inat,ibelow), npts, hori_index)
CALL histwrite (hist_id_stomate, 'LITTER_STR_BE_AGRI', itime, &
litter(:,istructural,iagri,ibelow), npts, hori_index)
CALL histwrite (hist_id_stomate, 'LITTER_MET_BE_NAT', itime, &
litter(:,imetabolic,inat,ibelow), npts, hori_index)
CALL histwrite (hist_id_stomate, 'LITTER_MET_BE_AGRI', itime, &
litter(:,imetabolic,iagri,ibelow), npts, hori_index)
CALL histwrite (hist_id_stomate, 'DEADLEAF_COVER', itime, &
deadleaf_cover, npts, hori_index)
CALL histwrite (hist_id_stomate, 'CARBON_ACTIVE_NAT', itime, &
carbon(:,iactive,inat), npts, hori_index)
CALL histwrite (hist_id_stomate, 'CARBON_ACTIVE_AGRI', itime, &
carbon(:,iactive,iagri), npts, hori_index)
CALL histwrite (hist_id_stomate, 'CARBON_SLOW_NAT', itime, &
carbon(:,islow,inat), npts, hori_index)
CALL histwrite (hist_id_stomate, 'CARBON_SLOW_AGRI', itime, &
carbon(:,islow,iagri), npts, hori_index)
CALL histwrite (hist_id_stomate, 'CARBON_PASSIVE_NAT', itime, &
carbon(:,ipassive,inat), npts, hori_index)
CALL histwrite (hist_id_stomate, 'CARBON_PASSIVE_AGRI', itime, &
carbon(:,ipassive,iagri), npts, hori_index)
CALL histwrite (hist_id_stomate, 'T2M_MONTH', itime, &
t2m_month, npts, hori_index)
CALL histwrite (hist_id_stomate, 'T2M_WEEK', itime, &
t2m_week, npts, hori_index)
CALL histwrite (hist_id_stomate, 'HET_RESP_NAT', itime, &
resp_hetero(:,inat), npts, hori_index)
CALL histwrite (hist_id_stomate, 'HET_RESP_AGRI', itime, &
resp_hetero(:,iagri), npts, hori_index)
CALL histwrite (hist_id_stomate, 'BLACK_CARBON', itime, &
black_carbon, npts, hori_index)
CALL histwrite (hist_id_stomate, 'FIREINDEX_NAT', itime, &
fireindex(:,inat), npts, hori_index)
CALL histwrite (hist_id_stomate, 'LITTERHUM', itime, &
litterhum_daily, npts, hori_index)
CALL histwrite (hist_id_stomate, 'CO2_FIRE', itime, &
co2_fire, npts, hori_index)
CALL histwrite (hist_id_stomate, 'CO2_TAKEN', itime, &
co2_to_bm, npts, hori_index)
! deforestation variables
CALL histwrite (hist_id_stomate, 'CONVFLUX', itime, &
convflux, npts, hori_index)
CALL histwrite (hist_id_stomate, 'CFLUX_PROD10', itime, &
cflux_prod10, npts, hori_index)
CALL histwrite (hist_id_stomate, 'CFLUX_PROD100', itime, &
cflux_prod100, npts, hori_index)
! 3d
CALL histwrite (hist_id_stomate, 'LAI', itime, &
lai, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'VEGET', itime, &
veget, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'VEGET_MAX', itime, &
veget_max, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'NPP', itime, &
npp_daily, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'GPP', itime, &
gpp_daily, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'IND', itime, &
ind, npts*npft, horipft_index)
! CALL histwrite (hist_id_stomate, 'TOTAL_M', itime, &
! tot_live_biomass, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'LEAF_M', itime, &
biomass(:,:,ileaf), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'SAP_M_AB', itime, &
biomass(:,:,isapabove), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'SAP_M_BE', itime, &
biomass(:,:,isapbelow), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'HEART_M_AB', itime, &
biomass(:,:,iheartabove), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'HEART_M_BE', itime, &
biomass(:,:,iheartbelow), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'ROOT_M', itime, &
biomass(:,:,iroot), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'FRUIT_M', itime, &
biomass(:,:,ifruit), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'RESERVE_M', itime, &
biomass(:,:,icarbres), npts*npft, horipft_index)
! CALL histwrite (hist_id_stomate, 'TOTAL_TURN', itime, &
! tot_turnover, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'LEAF_TURN', itime, &
turnover_daily(:,:,ileaf), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'SAP_AB_TURN', itime, &
turnover_daily(:,:,isapabove), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'ROOT_TURN', itime, &
turnover_daily(:,:,iroot), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'FRUIT_TURN', itime, &
turnover_daily(:,:,ifruit), npts*npft, horipft_index)
! CALL histwrite (hist_id_stomate, 'TOTAL_BM_LITTER', itime, &
! tot_bm_to_litter, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'LEAF_BM_LITTER', itime, &
bm_to_litter(:,:,ileaf), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'SAP_AB_BM_LITTER', itime, &
bm_to_litter(:,:,isapabove), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'SAP_BE_BM_LITTER', itime, &
bm_to_litter(:,:,isapbelow), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'HEART_AB_BM_LITTER', itime, &
bm_to_litter(:,:,iheartabove), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'HEART_BE_BM_LITTER', itime, &
bm_to_litter(:,:,iheartbelow), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'ROOT_BM_LITTER', itime, &
bm_to_litter(:,:,iroot), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'FRUIT_BM_LITTER', itime, &
bm_to_litter(:,:,ifruit), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'RESERVE_BM_LITTER', itime, &
bm_to_litter(:,:,icarbres), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'MAINT_RESP', itime, &
resp_maint, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'GROWTH_RESP', itime, &
resp_growth, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'AGE', itime, &
age, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'HEIGHT', itime, &
height, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'MOISTRESS', itime, &
moiavail_week, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'VCMAX', itime, &
vcmax, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'TURNOVER_TIME', itime, &
turnover_time, npts*npft, horipft_index)
! deforestation variables
CALL histwrite (hist_id_stomate, 'PROD10', itime, &
prod10, npts*11, horip11_index)
CALL histwrite (hist_id_stomate, 'PROD100', itime, &
prod100, npts*101, horip101_index)
CALL histwrite (hist_id_stomate, 'FLUX10', itime, &
flux10, npts*10, horip10_index)
CALL histwrite (hist_id_stomate, 'FLUX100', itime, &
flux100, npts*100, horip100_index)
IF (bavard.GE.4) WRITE(numout,*) 'Leaving stomate_lpj'
END SUBROUTINE StomateLpj
END MODULE stomate_lpj
ORCHIDEE/src_stomate/stomate_natagritot.f90 0000754 0103600 0005670 00000004343 11164403473 020504 0 ustar acamlmd lmdjus ! Transform from (X per m**2 of total ground) to (X per m**2 of nat/agri ground)
! and inverse operation
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_natagritot.f90,v 1.6 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_natagritot
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC natagritot
CONTAINS
SUBROUTINE natagritot (npts, direction, space_nat, field)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! total -> nat/agri or nat/agri -> total ?
INTEGER(i_std), INTENT(in) :: direction
! total natural space
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! 0.2 modified 2-dimensional field
! characteristic to be transformed
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: field
! 0.3 local
! index
INTEGER(i_std) :: j
! =========================================================================
IF ( direction .EQ. ito_natagri ) THEN
!
! 1 Transform from (X per m**2 of total ground) to (X per m**2 of nat/agri ground)
!
DO j = 1, npft
IF ( natural(j) ) THEN
WHERE ( space_nat(:) .GT. 0.0 )
field(:,j) = field(:,j) / space_nat(:)
ELSEWHERE
field(:,j) = 0.0
ENDWHERE
ELSE
WHERE ( space_nat(:) .LT. 1.0 )
field(:,j) = field(:,j) / ( 1. - space_nat(:) )
ELSEWHERE
field(:,j) = 0.0
ENDWHERE
ENDIF
ENDDO
ELSEIF ( direction .EQ. ito_total ) THEN
!
! 2 Transform from (X per m**2 of nat/agri ground) to (X per m**2 of total ground)
!
DO j = 1, npft
IF ( natural(j) ) THEN
field(:,j) = field(:,j) * space_nat(:)
ELSE
field(:,j) = field(:,j) * ( 1. - space_nat(:) )
ENDIF
ENDDO
ELSE
STOP 'natagritot: wrong direction'
ENDIF
END SUBROUTINE natagritot
END MODULE stomate_natagritot
ORCHIDEE/src_stomate/stomate_npp.f90 0000754 0103600 0005670 00000040244 11164403473 017125 0 ustar acamlmd lmdjus ! Npp: Maintenance and growth respiration
! We calculte first the maintenance rspiration. This is substracted from the
! allocatable biomass (and from the present biomass if the GPP is too low).
! Of the rest, a part is lost as growth respiration, while the other part is
! effectively allocated.
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_npp.f90,v 1.10 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_npp
! modules used:
USE ioipsl
USE stomate_constants
USE stomate_natagritot
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC npp_calc,npp_calc_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE npp_calc_clear
firstcall=.TRUE.
END SUBROUTINE npp_calc_clear
SUBROUTINE npp_calc (npts, dt, space_nat, &
PFTpresent, &
tlong_ref, t2m, tsoil, lai, rprof, &
gpp, f_alloc, resp_maint_part,&
biomass, leaf_age, leaf_frac, age, &
resp_maint, resp_growth, npp)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step (days)
REAL(r_std), INTENT(in) :: dt
! fraction of total space that is natural
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! long term annual mean 2 meter reference temperature
REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
! 2 meter temperature
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m
! soil temperature (K)
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil
! leaf area index
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
! root depth (m)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: rprof
! gross primary productivity (gC/days/(m**2 of natural/agricultural ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gpp
! fraction that goes into plant part
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: f_alloc
! maintenance respiration of different plant parts (gC/day/m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: resp_maint_part
! 0.2 modified fields
! biomass (gC/(m**2 of natural/agricultural ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! leaf age (days)
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! age (years)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
! 0.3 output
! maintenance respiration (gC/day/m**2 of total ground)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: resp_maint
! autotrophic respiration (gC/day/m**2 of total ground)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: resp_growth
! net primary productivity (gC/day/m**2 of natural/agricultural ground)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: npp
! 0.4 local
! maximum fraction of allocatable biomass used for maintenance respiration
REAL(r_std), PARAMETER :: tax_max = 0.8
! soil levels (m)
REAL(r_std), SAVE, DIMENSION(0:nbdl) :: z_soil
! root temperature (convolution of root and soil temperature profiles)
REAL(r_std), DIMENSION(npts,npft) :: t_root
! maintenance respiration coefficients at 0 deg C (g/g d**-1)
REAL(r_std), DIMENSION(npts,npft,nparts) :: coeff_maint
! temperature which is pertinent for maintenance respiration (K)
REAL(r_std), DIMENSION(npts,nparts) :: t_maint
! integration constant for root profile
REAL(r_std), DIMENSION(npts) :: rpc
! long term annual mean temperature, C
REAL(r_std), DIMENSION(npts) :: tl
! slope of maintenance respiration coefficient (1/K)
REAL(r_std), DIMENSION(npts) :: slope
! growth respiration of different plant parts (gC/day/m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,nparts) :: resp_growth_part
! allocatable biomass (gC/m**2 of nat/agri ground) for the whole plant
REAL(r_std), DIMENSION(npts,npft) :: bm_alloc_tot
! biomass increase, i.e. NPP per plant part
REAL(r_std), DIMENSION(npts,npft,nparts) :: bm_alloc
! biomass increase
REAL(r_std), DIMENSION(npts) :: bm_add
! new biomass
REAL(r_std), DIMENSION(npts) :: bm_new
! leaf mass in youngest age class (gC/m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,npft) :: leaf_mass_young
! leaf mass after maintenance respiration
REAL(r_std), DIMENSION(npts,npft) :: lm_old
! biomass created when biomass<0 because of dark respiration (gC/m**2 of nat/agri ground)
REAL(r_std), DIMENSION(npts,npft) :: bm_create
! maximum part of allocatable biomass used for respiration
REAL(r_std), DIMENSION(npts) :: bm_tax_max
! biomass that remains to be taken away
REAL(r_std), DIMENSION(npts) :: bm_pump
! Index
INTEGER(i_std) :: i,j,k,l,m
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering npp'
!
! 1 Initializations
!
!
! 1.1 first call
!
IF ( firstcall ) THEN
! 1.1.1 soil levels
z_soil(0) = 0.
z_soil(1:nbdl) = diaglev(1:nbdl)
! 1.1.2 messages
WRITE(numout,*) 'npp:'
WRITE(numout,*) ' > max. fraction of allocatable biomass used for'// &
' maint. resp.:', tax_max
firstcall = .FALSE.
ENDIF
!
! 1.2 set output to zero
!
resp_maint(:,:) = 0.0
resp_growth(:,:) = 0.0
npp(:,:) = 0.0
!
! 1.3 root temperature: convolution of root and temperature profiles
! suppose exponential root profile.
!
DO j = 1, npft
! 1.3.1 rpc is an integration constant such that the integral of the root profile is 1.
rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / rprof(:,j) ) )
! 1.3.2 integrate over the nbdl levels
t_root(:,j) = 0.0
DO l = 1, nbdl
t_root(:,j) = &
t_root(:,j) + tsoil(:,l) * rpc(:) * &
( EXP( -z_soil(l-1)/rprof(:,j) ) - EXP( -z_soil(l)/rprof(:,j) ) )
ENDDO
ENDDO
!
! 1.4 total allocatable biomass
!
bm_alloc_tot(:,:) = gpp(:,:) * dt
!
! 2 define maintenance respiration coefficients
!
DO j = 1, npft
!
! 2.1 temperature which is taken for the plant part we are talking about
!
! 2.1.1 parts above the ground
t_maint(:,ileaf) = t2m(:)
t_maint(:,isapabove) = t2m(:)
t_maint(:,ifruit) = t2m(:)
! 2.1.2 parts below the ground
t_maint(:,isapbelow) = t_root(:,j)
t_maint(:,iroot) = t_root(:,j)
! 2.1.3 heartwood: does not respire. Any temperature
t_maint(:,iheartbelow) = t_root(:,j)
t_maint(:,iheartabove) = t2m(:)
! 2.1.4 reserve: above the ground for trees, below for grasses
IF ( tree(j) ) THEN
t_maint(:,icarbres) = t2m(:)
ELSE
t_maint(:,icarbres) = t_root(:,j)
ENDIF
!
! 2.2 calculate coefficient
!
tl(:) = tlong_ref(:) - ZeroCelsius
slope(:) = maint_resp_slope(j,1) + tl(:) * maint_resp_slope(j,2) + &
tl(:)*tl(:) * maint_resp_slope(j,3)
DO k = 1, nparts
coeff_maint(:,j,k) = &
MAX( coeff_maint_zero(j,k) * &
( 1. + slope(:) * (t_maint(:,k)-ZeroCelsius) ), 0._r_std )
ENDDO
ENDDO
!
! 3 calculate maintenance and growth respiration.
! NPP = GPP - maintenance resp - growth resp.
!
DO j = 1, npft
!
! 3.1 maintenance respiration of the different plant parts
!
!
! 3.2 Total maintenance respiration of the plant
! VPP killer:
! resp_maint(:,j) = SUM( resp_maint_part(:,:), DIM=2 )
!
resp_maint(:,j) = 0.0
!with the new calculation of hourly respiration, we must verify that PFT as not been killed after calcul of resp_maint_part in stomate
DO k= 1, nparts
WHERE (PFTpresent(:,j))
resp_maint(:,j) = resp_maint(:,j) + resp_maint_part(:,j,k)
ENDWHERE
ENDDO
!
! 3.3 This maintenance respiration is taken away from the newly produced
! allocatable biomass. However, we avoid that no allocatable biomass remains.
! If the respiration is larger than a given fraction of the allocatable biomass,
! the rest is taken from the tissues themselves.
! We suppose that respiration is not dependent on leaf age ->
! do not change age structure.
!
! maximum part of allocatable biomass used for respiration
bm_tax_max(:) = tax_max * bm_alloc_tot(:,j)
DO i = 1, npts
IF ( ( bm_alloc_tot(i,j) .GT. 0.0 ) .AND. &
( ( resp_maint(i,j) * dt ) .LT. bm_tax_max(i) ) ) THEN
bm_alloc_tot(i,j) = bm_alloc_tot(i,j) - resp_maint(i,j) * dt
ELSEIF ( resp_maint(i,j) .GT. 0.0 ) THEN
! remaining allocatable biomass
bm_alloc_tot(i,j) = bm_alloc_tot(i,j) - bm_tax_max(i)
! biomass that remains to be taken away from tissues
bm_pump(i) = resp_maint(i,j) * dt - bm_tax_max(i)
! take biomass from tissues
biomass(i,j,ileaf) = biomass(i,j,ileaf) - &
bm_pump(i) * resp_maint_part(i,j,ileaf) / resp_maint(i,j)
biomass(i,j,isapabove) = biomass(i,j,isapabove) - &
bm_pump(i) * resp_maint_part(i,j,isapabove) / resp_maint(i,j)
biomass(i,j,isapbelow) = biomass(i,j,isapbelow) - &
bm_pump(i) * resp_maint_part(i,j,isapbelow) / resp_maint(i,j)
biomass(i,j,iroot) = biomass(i,j,iroot) - &
bm_pump(i) * resp_maint_part(i,j,iroot) / resp_maint(i,j)
biomass(i,j,ifruit) = biomass(i,j,ifruit) - &
bm_pump(i) * resp_maint_part(i,j,ifruit) / resp_maint(i,j)
biomass(i,j,icarbres) = biomass(i,j,icarbres) - &
bm_pump(i) * resp_maint_part(i,j,icarbres) / resp_maint(i,j)
ENDIF
ENDDO ! Fortran95: WHERE - ELSEWHERE construct
!
! 3.4 dispatch allocatable biomass
!
DO k = 1, nparts
bm_alloc(:,j,k) = f_alloc(:,j,k) * bm_alloc_tot(:,j)
ENDDO
!
! 3.5 growth respiration of a plant part is a given fraction of the
! remaining allocatable biomass.
!
resp_growth_part(:,:) = frac_growthresp * bm_alloc(:,j,:) / dt
bm_alloc(:,j,:) = ( 1. - frac_growthresp ) * bm_alloc(:,j,:)
!
! 3.6 Total growth respiration of the plant
! VPP killer:
! resp_growth(:,j) = SUM( resp_growth_part(:,:), DIM=2 )
!
resp_growth(:,j) = 0.0
DO k = 1, nparts
resp_growth(:,j) = resp_growth(:,j) + resp_growth_part(:,k)
ENDDO
ENDDO
!
! 4 update the biomass, but save the old leaf mass for later
! "old" leaf mass is leaf mass after maintenance respiration
!
lm_old(:,:) = biomass(:,:,ileaf)
biomass(:,:,:) = biomass(:,:,:) + bm_alloc(:,:,:)
!
! 5 biomass can become negative in some rare cases, as the GPP can be negative
! (dark respiration).
! In this case, set biomass to some small value. This creation of matter is taken into
! account by decreasing the autotrophic respiration. In this case, maintenance respiration
! can become negative !!!
!
DO k = 1, nparts
WHERE ( biomass(:,:,k) .LT. 0.0 )
bm_create(:,:) = min_stomate - biomass(:,:,k)
biomass(:,:,k) = biomass(:,:,k) + bm_create(:,:)
resp_maint(:,:) = resp_maint(:,:) - bm_create(:,:) / dt
ENDWHERE
ENDDO
!
! 6 Calculate the NPP (gC/(m**2 of nat/agri ground/day)
!
npp(:,:) = gpp(:,:) - resp_growth(:,:) - resp_maint(:,:)
!
! 7 transform respiration from gC/(m**2 of nat/agri ground)/day) into
! gC/(m**2 of total ground)/day), as it goes into the atmosphere.
!
CALL natagritot (npts, ito_total, space_nat, resp_maint)
CALL natagritot (npts, ito_total, space_nat, resp_growth)
!
! 8 leaf age
!
!
! 8.1 Decrease leaf age in youngest class if new leaf biomass is higher than old one.
!
leaf_mass_young(:,:) = leaf_frac(:,:,1) * lm_old(:,:) + bm_alloc(:,:,ileaf)
WHERE ( ( bm_alloc(:,:,ileaf) .GT. 0.0 ) .AND. &
( leaf_mass_young(:,:) .GT. 0.0 ) )
leaf_age(:,:,1) = leaf_age(:,:,1) * ( leaf_mass_young(:,:) - bm_alloc(:,:,ileaf) ) / &
leaf_mass_young(:,:)
ENDWHERE
!
! 8.2 new age class fractions (fraction in youngest class increases)
!
! 8.2.1 youngest class: new mass in youngest class divided by total new mass
WHERE ( biomass(:,:,ileaf) .GT. min_stomate )
leaf_frac(:,:,1) = leaf_mass_young(:,:) / biomass(:,:,ileaf)
ENDWHERE
! 8.2.2 other classes: old mass in leaf age class divided by new mass
DO m = 2, nleafages
WHERE ( biomass(:,:,ileaf) .GT. min_stomate )
leaf_frac(:,:,m) = leaf_frac(:,:,m) * lm_old(:,:) / biomass(:,:,ileaf)
ENDWHERE
ENDDO
!
! 9 Plant age (years)
!
!
! 9.1 Increase age at every time step
!
WHERE ( PFTpresent(:,:) )
age(:,:) = age(:,:) + dt/one_year
ELSEWHERE
age(:,:) = 0.0
ENDWHERE
!
! 9.2 For grasses, decrease age
! if new biomass is higher than old one.
! For trees, age is treated in "establish" if vegetation is dynamic,
! and in turnover routines if it is static (in this case, only take
! into account the age of the heartwood).
!
DO j = 1, npft
IF ( .NOT. tree(j) ) THEN
! Only four compartments for grasses
! VPP killer:
! bm_new(:) = SUM( biomass(:,j,:), DIM=2 )
! bm_add(:) = SUM( bm_alloc(:,j,:), DIM=2 )
bm_new(:) = biomass(:,j,ileaf) + biomass(:,j,isapabove) + &
biomass(:,j,iroot) + biomass(:,j,ifruit)
bm_add(:) = bm_alloc(:,j,ileaf) + bm_alloc(:,j,isapabove) + &
bm_alloc(:,j,iroot) + bm_alloc(:,j,ifruit)
WHERE ( ( bm_new(:) .GT. 0.0 ) .AND. ( bm_add(:) .GT. 0.0 ) )
age(:,j) = age(:,j) * ( bm_new(:) - bm_add(:) ) / bm_new(:)
ENDWHERE
ENDIF
ENDDO
!
! 10 history
!
CALL histwrite (hist_id_stomate, 'BM_ALLOC_LEAF', itime, &
bm_alloc(:,:,ileaf), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_AB', itime, &
bm_alloc(:,:,isapabove), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_BE', itime, &
bm_alloc(:,:,isapbelow), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'BM_ALLOC_ROOT', itime, &
bm_alloc(:,:,iroot), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'BM_ALLOC_FRUIT', itime, &
bm_alloc(:,:,ifruit), npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'BM_ALLOC_RES', itime, &
bm_alloc(:,:,icarbres), npts*npft, horipft_index)
IF (bavard.GE.4) WRITE(numout,*) 'Leaving npp'
END SUBROUTINE npp_calc
END MODULE stomate_npp
ORCHIDEE/src_stomate/stomate_phenology.f90 0000754 0103600 0005670 00000111602 11164403473 020331 0 ustar acamlmd lmdjus ! Phenology
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_phenology.f90,v 1.9 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_phenology
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC phenology,phenology_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
LOGICAL, SAVE :: firstcall_hum = .TRUE.
LOGICAL, SAVE :: firstcall_moi = .TRUE.
LOGICAL, SAVE :: firstcall_humgdd = .TRUE.
LOGICAL, SAVE :: firstcall_moigdd = .TRUE.
CONTAINS
SUBROUTINE phenology_clear
firstcall=.TRUE.
firstcall_hum=.TRUE.
firstcall_moi = .TRUE.
firstcall_humgdd = .TRUE.
firstcall_moigdd = .TRUE.
END SUBROUTINE phenology_clear
SUBROUTINE phenology (npts, dt, PFTpresent, &
veget_max, space_nat, &
tlong_ref, t2m_month, t2m_week, gpp, &
maxmoiavail_lastyear, minmoiavail_lastyear, &
moiavail_month, moiavail_week, &
gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
senescence, time_lowgpp, time_hum_min, &
biomass, leaf_frac, leaf_age, &
when_growthinit, co2_to_bm, lai)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step in days
REAL(r_std), INTENT(in) :: dt
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! "long term" 2 meter reference temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
! "monthly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
! "weekly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
! daily gross primary productivity (gC/(m**2 of nat/agri ground)/day)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gpp
! last year's maximum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
! last year's minimum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
! "monthly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
! "weekly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
! growing degree days, threshold -5 deg C
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gdd_m5_dormance
! growing degree days, since midwinter
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_midwinter
! number of chilling days since leaves were lost
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ncd_dormance
! number of growing days, threshold -5 deg C
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ngd_minus5
! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: senescence
! duration of dormance (d)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_lowgpp
! time elapsed since strongest moisture availability (d)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_hum_min
! 0.2 modified fields
! biomass (gC/(m**2 of natural or agricultural ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! leaf age (days)
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
! how many days ago was the beginning of the growing season
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
! co2 taken up (gC/(m**2 of total ground)/day)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: co2_to_bm
! 0.3 output
! leaf area index
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
! 0.4 local
! take carbon from atmosphere if carbohydrate reserve too small?
LOGICAL, PARAMETER :: always_init = .FALSE.
! minimum time (d) since last beginning of a growing season
REAL(r_std), PARAMETER :: min_growthinit_time = 300.
! are we allowed to decalre the beginning of the growing season?
LOGICAL, DIMENSION(npts,npft) :: allow_initpheno
! biomass we would like to have
REAL(r_std), DIMENSION(npts) :: bm_wanted
! biomass we use (from carbohydrate reserve or from atmosphere)
REAL(r_std), DIMENSION(npts) :: bm_use
! minimum leaf mass (gC/(m**2 of natural or agricultural ground))
REAL(r_std), DIMENSION(npts) :: lm_min
! does the leaf age distribution have to be reset?
LOGICAL(r_std), DIMENSION(npts) :: age_reset
! indices
INTEGER(i_std) :: i,j,m
! signal to start putting leaves on
LOGICAL, DIMENSION(npts,npft) :: begin_leaves
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering phenology'
!
! 1 first call
!
IF ( firstcall ) THEN
WRITE(numout,*) 'phenology:'
WRITE(numout,*) ' > take carbon from atmosphere if carbohydrate' // &
' reserve too small: ', always_init
WRITE(numout,*) ' > minimum time since last beginning of a growing' // &
' season (d): ', min_growthinit_time
firstcall = .FALSE.
ENDIF
!
! 2 various things
!
!
! 2.1 allow detection of the beginning of the growing season if dormance was
! long enough and last beginning of growing season was a sufficiently
! long time ago
!
DO j = 1, npft
WHERE ( ( time_lowgpp(:,j) .GE. pheno_crit%lowgpp_time(j) ) .AND. &
( when_growthinit(:,j) .GT. min_growthinit_time ) )
allow_initpheno(:,j) = .TRUE.
ELSEWHERE
allow_initpheno(:,j) = .FALSE.
ENDWHERE
ENDDO
!
! 2.2 increase counter: how many days ago was the beginning of the growing season
! Needed for allocation
!
when_growthinit(:,:) = when_growthinit(:,:) + dt
!
! 3 Check biometeorological conditions
!
! default: phenology does not start
begin_leaves(:,:) = .FALSE.
! different kinds of phenology
DO j = 1, npft
SELECT CASE ( pheno_crit%pheno_model(j) )
CASE ( 'hum' )
CALL pheno_hum (npts, j, PFTpresent, allow_initpheno, &
moiavail_month, moiavail_week, &
maxmoiavail_lastyear, minmoiavail_lastyear, &
begin_leaves)
CASE ( 'moi' )
CALL pheno_moi (npts, j, PFTpresent, allow_initpheno, &
time_hum_min, &
moiavail_month, moiavail_week, &
begin_leaves)
CASE ( 'ncdgdd' )
CALL pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
ncd_dormance, gdd_midwinter, &
t2m_month, t2m_week, begin_leaves)
CASE ( 'ngd' )
CALL pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd_minus5, &
t2m_month, t2m_week, begin_leaves)
CASE ( 'humgdd' )
CALL pheno_humgdd (npts, j, PFTpresent, allow_initpheno, gdd_m5_dormance, &
maxmoiavail_lastyear, minmoiavail_lastyear, &
tlong_ref, t2m_month, t2m_week, &
moiavail_week, moiavail_month, &
begin_leaves)
CASE ( 'moigdd' )
CALL pheno_moigdd (npts, j, PFTpresent, allow_initpheno, gdd_m5_dormance, &
time_hum_min, &
tlong_ref, t2m_month, t2m_week, &
moiavail_week, moiavail_month, &
begin_leaves)
CASE ( 'none' )
! no action
CASE default
WRITE(numout,*) 'phenology: don''t know how to treat this PFT.'
WRITE(numout,*) ' number:',j
WRITE(numout,*) ' phenology model: ',pheno_crit%pheno_model(j)
STOP
END SELECT
ENDDO
!
! 4 leaves start to grow if meteorological conditions are favourable and if
! leaf regrowth is allowed (cf also turnover)
!
DO j = 1, npft
age_reset(:) = .FALSE.
DO i = 1, npts
IF ( begin_leaves(i,j) ) THEN
lm_min(i) = veget_max(i,j) * pheno_crit%lai_initmin(j) / sla(j)
! do we have to put a minimum biomass into the leaves?
IF ( biomass(i,j,ileaf) .LT. lm_min(i) ) THEN
!
! 4.1 determine how much biomass we can use
!
bm_wanted(i) = 2. * lm_min(i)
! eventually take the missing carbon from the atmosphere and
! put it into carbohydrate reserve
IF ( always_init .AND. ( biomass(i,j,icarbres) .LT. bm_wanted(i) ) ) THEN
IF ( natural(j) ) THEN
co2_to_bm(i) = co2_to_bm(i) + &
( bm_wanted(i) - biomass(i,j,icarbres) ) * space_nat(i) / dt
ELSE
co2_to_bm(i) = co2_to_bm(i) + &
( bm_wanted(i) - biomass(i,j,icarbres) ) * ( 1. - space_nat(i) ) / dt
ENDIF
biomass(i,j,icarbres) = bm_wanted(i)
ENDIF
bm_use(i) = MIN( biomass(i,j,icarbres), bm_wanted(i) )
!
! 4.2 dispatch that biomass on leaves and roots
!
biomass(i,j,ileaf) = biomass(i,j,ileaf) + bm_use(i) / 2.
biomass(i,j,iroot) = biomass(i,j,iroot) + bm_use(i) / 2.
!
! 4.3 decrease reservoir biomass
!
biomass(i,j,icarbres) = biomass(i,j,icarbres) - bm_use(i)
!
! 4.4 decide whether we have to reset then leaf age distribution
! (done later for better vectorization)
!
age_reset(i) = .TRUE.
ENDIF ! leaf mass is very low
!
! 4.5 reset counter: start of the growing season
!
when_growthinit(i,j) = 0.0
ENDIF ! start of the growing season
ENDDO ! loop over grid points
!
! 4.6 reset leaf age distribution where necessary
! simply say that everything is in the youngest age class
!
! 4.6.1 fractions
WHERE ( age_reset(:) )
leaf_frac(:,j,1) = 1.0
ENDWHERE
DO m = 2, nleafages
WHERE ( age_reset(:) )
leaf_frac(:,j,m) = 0.0
ENDWHERE
ENDDO
! 4.6.2 ages
DO m = 1, nleafages
WHERE ( age_reset(:) )
leaf_age(:,j,m) = 0.0
ENDWHERE
ENDDO
ENDDO ! loop over PFTs
IF (bavard.GE.4) WRITE(numout,*) 'Leaving phenology'
END SUBROUTINE phenology
!
! ==============================================================================
! Phenology: begins if "weekly" soil humidity starts to exceed a certain threshold
! value. This value depends on last year's max and min humidity ...
! Always initiate growing season if soil moisture exceeds a certain threshold.
!
SUBROUTINE pheno_hum (npts, j, PFTpresent, allow_initpheno, &
moiavail_month, moiavail_week, &
maxmoiavail_lastyear, minmoiavail_lastyear, &
begin_leaves)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! PFT index
INTEGER(i_std), INTENT(in) :: j
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! are we allowed to decalre the beginning of the growing season?
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
! "monthly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
! "weekly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
! last year's maximum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
! last year's minimum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
! 0.2 output
! signal to start putting leaves on
LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
! 0.3 local
! moisture availability above which moisture tendency doesn't matter
REAL(r_std), PARAMETER :: moiavail_always_tree = 1.0
REAL(r_std), PARAMETER :: moiavail_always_grass = 0.6
REAL(r_std) :: moiavail_always
! first call
REAL(r_std), DIMENSION(npts) :: availability_crit
! index
INTEGER(i_std) :: i
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering hum'
!
! Initializations
!
!
! 1.1 messages
!
IF ( firstcall_hum ) THEN
WRITE(numout,*) 'pheno_hum:'
WRITE(numout,*) ' > moisture availability above which moisture tendency doesn''t matter: '
WRITE(numout,*) ' trees:', moiavail_always_tree
WRITE(numout,*) ' grasses:', moiavail_always_grass
firstcall_hum = .FALSE.
ENDIF
!
! 1.2 initialize output
!
begin_leaves(:,j) = .FALSE.
!
! 1.3 check the prescribed critical value
!
IF ( pheno_crit%hum_frac(j) .EQ. undef ) THEN
WRITE(numout,*) 'hum: pheno_crit%hum_frac is undefined for PFT',j
WRITE(numout,*) 'We stop.'
STOP
ENDIF
!
! 1.4 critical moisture availability above which we always detect the beginning of the
! growing season.
!
IF ( tree(j) ) THEN
moiavail_always = moiavail_always_tree
ELSE
moiavail_always = moiavail_always_grass
ENDIF
!
! 2 PFT has to be there and start of growing season must be allowed
!
DO i = 1, npts
IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
! critical availability: depends on last year's max and min.
availability_crit(i) = minmoiavail_lastyear(i,j) + pheno_crit%hum_frac(j) * &
( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
! the favorable season starts if the "monthly" moisture availability is still quite
! low, but the "weekly" availability is already higher (as it reacts faster).
! If monthly moisture availability is high enough, also initiate growing season if
! this has not happened yet.
IF ( ( ( moiavail_week(i,j) .GE. availability_crit(i) ) .AND. &
( moiavail_month(i,j) .LT. moiavail_week(i,j) ) ) .OR. &
( moiavail_month(i,j) .GE. moiavail_always ) ) THEN
begin_leaves(i,j) = .TRUE.
ENDIF
ENDIF ! PFT there and start of growing season allowed
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving hum'
END SUBROUTINE pheno_hum
!
! ==============================================================================
! Phenology: begins if moisture minium was a sufficiently long time ago.
! Additionally, "weekly" soil humidity must be higher that "monthly" soil
! humidity.
!
SUBROUTINE pheno_moi (npts, j, PFTpresent, allow_initpheno, &
time_hum_min, &
moiavail_month, moiavail_week, &
begin_leaves)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! PFT index
INTEGER(i_std), INTENT(in) :: j
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! are we allowed to decalre the beginning of the growing season?
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
! time elapsed since strongest moisture availability (d)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_hum_min
! "monthly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
! "weekly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
! 0.2 output
! signal to start putting leaves on
LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
! 0.3 local
! moisture availability above which moisture tendency doesn't matter
! moisture availability above which moisture tendency doesn't matter
REAL(r_std), PARAMETER :: moiavail_always_tree = 1.0
REAL(r_std), PARAMETER :: moiavail_always_grass = 0.6
REAL(r_std) :: moiavail_always
! index
INTEGER(i_std) :: i
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering moi'
!
! Initializations
!
!
! 1.1 messages
!
IF ( firstcall_moi ) THEN
WRITE(numout,*) 'pheno_moi:'
WRITE(numout,*) ' > moisture availability above which moisture tendency doesn''t matter: '
WRITE(numout,*) ' trees:', moiavail_always_tree
WRITE(numout,*) ' grasses:', moiavail_always_grass
firstcall_moi = .FALSE.
ENDIF
!
! 1.2 initialize output
!
begin_leaves(:,j) = .FALSE.
!
! 1.3 check the prescribed critical value
!
IF ( pheno_crit%hum_min_time(j) .EQ. undef ) THEN
WRITE(numout,*) 'moi: pheno_crit%hum_min_time is undefined for PFT',j
WRITE(numout,*) 'We stop.'
STOP
ENDIF
!
! 1.4 critical moisture availability above which we always detect the beginning of the
! growing season.
!
IF ( tree(j) ) THEN
moiavail_always = moiavail_always_tree
ELSE
moiavail_always = moiavail_always_grass
ENDIF
!
! 2 PFT has to be there and start of growing season must be allowed
!
DO i = 1, npts
IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
! the favorable season starts if the moisture minimum was a sufficiently long
! time ago and if the "monthly" moisture availability is lower than the "weekly"
! availability (this means that soil moisture is increasing).
! If monthly moisture availability is high enough, also initiate growing season if
! this has not happened yet.
IF ( ( ( moiavail_week(i,j) .GT. moiavail_month(i,j) ) .AND. &
( time_hum_min(i,j) .GT. pheno_crit%hum_min_time(j) ) ) .OR. &
( moiavail_month(i,j) .GE. moiavail_always ) ) THEN
begin_leaves(i,j) = .TRUE.
ENDIF
ENDIF ! PFT there and start of growing season allowed
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving moi'
END SUBROUTINE pheno_moi
!
! ==============================================================================
! Phenology: leaves are put on if gdd exceeds a critical value.
! Additionally, there has to be at least some moisture.
! Set gdd to undef if beginning of the growing season detected.
!
SUBROUTINE pheno_humgdd (npts, j, PFTpresent, allow_initpheno, gdd, &
maxmoiavail_lastyear, minmoiavail_lastyear, &
tlong_ref, t2m_month, t2m_week, &
moiavail_week, moiavail_month, &
begin_leaves)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! PFT index
INTEGER(i_std), INTENT(in) :: j
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! are we allowed to decalre the beginning of the growing season?
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
! growing degree days, calculated since leaves have fallen
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gdd
! last year's maximum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
! last year's minimum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
! "long term" 2 meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
! "monthly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
! "weekly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
! "weekly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
! "monthly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
! 0.2 output
! signal to start putting leaves on
LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
! 0.3 local
! moisture availability above which moisture tendency doesn't matter
! moisture availability above which moisture tendency doesn't matter
REAL(r_std), PARAMETER :: moiavail_always_tree = 1.0
REAL(r_std), PARAMETER :: moiavail_always_grass = 0.6
REAL(r_std) :: moiavail_always
! monthly temp. above which temp. tendency doesn't matter
REAL(r_std), PARAMETER :: t_always = ZeroCelsius + 10.
! critical moisture availability
REAL(r_std), DIMENSION(npts) :: moiavail_crit
! long term temperature, C
REAL(r_std), DIMENSION(npts) :: tl
! critical GDD
REAL(r_std), DIMENSION(npts) :: gdd_crit
! index
INTEGER(i_std) :: i
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering humgdd'
!
! 1 Initializations
!
!
! 1.1 messages
!
IF ( firstcall_humgdd ) THEN
WRITE(numout,*) 'pheno_humgdd:'
WRITE(numout,*) ' > moisture availability above which moisture tendency doesn''t matter: '
WRITE(numout,*) ' trees:', moiavail_always_tree
WRITE(numout,*) ' grasses:', moiavail_always_grass
WRITE(numout,*) ' > monthly temp. above which temp. tendency doesn''t matter: ', &
t_always
firstcall_humgdd = .FALSE.
ENDIF
!
! 1.2 initialize output
!
begin_leaves(:,j) = .FALSE.
!
! 1.3 check the prescribed critical values
!
IF ( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) THEN
WRITE(numout,*) 'humgdd: pheno_crit%gdd is undefined for PFT',j
WRITE(numout,*) 'We stop.'
STOP
ENDIF
IF ( pheno_crit%hum_frac(j) .EQ. undef ) THEN
WRITE(numout,*) 'humgdd: pheno_crit%hum_frac is undefined for PFT',j
WRITE(numout,*) 'We stop.'
STOP
ENDIF
!
! 1.4 critical moisture availability above which we always detect the beginning of the
! growing season.
!
IF ( tree(j) ) THEN
moiavail_always = moiavail_always_tree
ELSE
moiavail_always = moiavail_always_grass
ENDIF
!
! 2 PFT has to be there, start of growing season must be allowed,
! and gdd has to be defined
!
DO i = 1, npts
IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
( gdd(i,j) .NE. undef ) ) THEN
! is critical gdd reached and is temperature increasing?
! be sure that at least some humidity
moiavail_crit(i) = minmoiavail_lastyear(i,j) + pheno_crit%hum_frac(j) * &
( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
tl(i) = tlong_ref(i) - ZeroCelsius
gdd_crit(i) = pheno_crit%gdd(j,1) + tl(i)*pheno_crit%gdd(j,2) + &
tl(i)*tl(i)*pheno_crit%gdd(j,3)
IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
( t2m_month(i) .GT. t_always ) ) .AND. &
( ( ( moiavail_week(i,j) .GE. moiavail_crit(i) ) .AND. &
( moiavail_month(i,j) .LT. moiavail_crit(i) ) ) .OR. &
( moiavail_month(i,j) .GE. moiavail_always ) ) ) THEN
begin_leaves(i,j) = .TRUE.
ENDIF
ENDIF ! PFT there and start of growing season allowed
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving humgdd'
END SUBROUTINE pheno_humgdd
!
! ==============================================================================
! Phenology: leaves are put on if gdd exceeds a critical value.
! Additionally, a certain time must have elapsed since the moisture minimum.
! Set gdd to undef if beginning of the growing season detected.
!
SUBROUTINE pheno_moigdd (npts, j, PFTpresent, allow_initpheno, gdd, &
time_hum_min, &
tlong_ref, t2m_month, t2m_week, &
moiavail_week, moiavail_month, &
begin_leaves)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! PFT index
INTEGER(i_std), INTENT(in) :: j
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! are we allowed to decalre the beginning of the growing season?
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
! growing degree days, calculated since leaves have fallen
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gdd
! time elapsed since strongest moisture availability (d)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_hum_min
! "long term" 2 meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
! "monthly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
! "weekly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
! "weekly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
! "monthly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
! 0.2 output
! signal to start putting leaves on
LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
! 0.3 local
! moisture availability above which moisture tendency doesn't matter
! moisture availability above which moisture tendency doesn't matter
REAL(r_std), PARAMETER :: moiavail_always_tree = 1.0
REAL(r_std), PARAMETER :: moiavail_always_grass = 0.6
REAL(r_std) :: moiavail_always
! monthly temp. above which temp. tendency doesn't matter
REAL(r_std), PARAMETER :: t_always = ZeroCelsius + 10.
! long term temperature, C
REAL(r_std), DIMENSION(npts) :: tl
! critical GDD
REAL(r_std), DIMENSION(npts) :: gdd_crit
! index
INTEGER(i_std) :: i
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering moigdd'
!
! 1 Initializations
!
!
! 1.1 messages
!
IF ( firstcall_moigdd ) THEN
WRITE(numout,*) 'pheno_moigdd:'
WRITE(numout,*) ' > moisture availability above which moisture tendency doesn''t matter: '
WRITE(numout,*) ' trees:', moiavail_always_tree
WRITE(numout,*) ' grasses:', moiavail_always_grass
WRITE(numout,*) ' > monthly temp. above which temp. tendency doesn''t matter: ', &
t_always
firstcall_moigdd = .FALSE.
ENDIF
!
! 1.2 initialize output
!
begin_leaves(:,j) = .FALSE.
!
! 1.3 check the prescribed critical values
!
IF ( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) THEN
WRITE(numout,*) 'moigdd: pheno_crit%gdd is undefined for PFT',j
WRITE(numout,*) 'We stop.'
STOP
ENDIF
IF ( pheno_crit%hum_min_time(j) .EQ. undef ) THEN
WRITE(numout,*) 'moigdd: pheno_crit%hum_min_time is undefined for PFT',j
WRITE(numout,*) 'We stop.'
STOP
ENDIF
!
! 1.4 critical moisture availability above which we always detect the beginning of the
! growing season.
!
IF ( tree(j) ) THEN
moiavail_always = moiavail_always_tree
ELSE
moiavail_always = moiavail_always_grass
ENDIF
!
! 2 PFT has to be there, start of growing season must be allowed,
! and gdd has to be defined
!
DO i = 1, npts
IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
( gdd(i,j) .NE. undef ) ) THEN
! is critical gdd reached and is temperature increasing?
! has enough time gone by since moisture minimum and is moisture increasing?
tl(i) = tlong_ref(i) - ZeroCelsius
gdd_crit(i) = pheno_crit%gdd(j,1) + tl(i)*pheno_crit%gdd(j,2) + &
tl(i)*tl(i)*pheno_crit%gdd(j,3)
IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
( t2m_month(i) .GT. t_always ) ) .AND. &
( ( ( time_hum_min(i,j) .GT. pheno_crit%hum_min_time(j) ) .AND. &
( moiavail_week(i,j) .GT. moiavail_month(i,j) ) ) .OR. &
( moiavail_month(i,j) .GE. moiavail_always ) ) ) THEN
begin_leaves(i,j) = .TRUE.
ENDIF
ENDIF ! PFT there and start of growing season allowed
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving moigdd'
END SUBROUTINE pheno_moigdd
!
! ==============================================================================
! Phenology: leaves are put on if a certain relationship between ncd since leaves were
! lost (number of chilling days) and gdd since midwinter (growing degree
! days) is fulfilled
!
SUBROUTINE pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
ncd_dormance, gdd_midwinter, &
t2m_month, t2m_week, begin_leaves)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! PFT index
INTEGER(i_std), INTENT(in) :: j
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! are we allowed to decalre the beginning of the growing season?
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
! number of chilling days since leaves were lost
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ncd_dormance
! growing degree days since midwinter
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_midwinter
! "monthly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
! "weekly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
! 0.2 output
! signal to start putting leaves on
LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
! 0.3 local
! index
INTEGER(i_std) :: i
! critical gdd
REAL(r_std) :: gdd_min
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering ncdgdd'
!
! 1 Initializations
!
!
! 1.1 initialize output
!
begin_leaves(:,j) = .FALSE.
!
! 1.2 check the prescribed critical values
!
IF ( pheno_crit%ncdgdd_temp(j) .EQ. undef ) THEN
WRITE(numout,*) 'ncdgdd: pheno_crit%ncdgdd_temp is undefined for PFT',j
WRITE(numout,*) 'We stop.'
STOP
ENDIF
!
! 2 PFT has to be there and start of growing season must be allowed
!
DO i = 1, npts
IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
( gdd_midwinter(i,j) .NE. undef ) .AND. &
( ncd_dormance(i,j) .NE. undef ) ) THEN
! critical gdd
gdd_min = ( 603. / exp(0.0091*ncd_dormance(i,j)) - 64. )
! has the critical gdd been reached and are temperatures increasing?
IF ( ( gdd_midwinter(i,j) .GE. gdd_min ) .AND. &
( t2m_week(i) .GT. t2m_month(i) ) ) THEN
begin_leaves(i,j) = .TRUE.
gdd_midwinter(i,j)=undef
ENDIF
ENDIF ! PFT there and start of growing season allowed
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving ncdgdd'
END SUBROUTINE pheno_ncdgdd
!
! ==============================================================================
! Phenology: leaves are put on if ngd (number of growing days, defined as
! days with t>-5 deg C) exceeds a critical value.
!
SUBROUTINE pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd, &
t2m_month, t2m_week, begin_leaves)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! PFT index
INTEGER(i_std), INTENT(in) :: j
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! are we allowed to decalre the beginning of the growing season?
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
! growing degree days
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ngd
! "monthly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
! "weekly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
! 0.2 output
! signal to start putting leaves on
LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
! 0.3 local
! index
INTEGER(i_std) :: i
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering ngd'
!
! Initializations
!
!
! 1.1 initialize output
!
begin_leaves(:,j) = .FALSE.
!
! 1.2 check the prescribed critical value
!
IF ( pheno_crit%ngd(j) .EQ. undef ) THEN
WRITE(numout,*) 'ngd: pheno_crit%ngd is undefined for PFT',j
WRITE(numout,*) 'We stop.'
STOP
ENDIF
!
! 2 PFT has to be there and start of growing season must be allowed
!
DO i = 1, npts
IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
! is critical ngd reached and are temperatures increasing?
IF ( ( ngd(i,j) .GE. pheno_crit%ngd(j) ) .AND. &
( t2m_week(i) .GT. t2m_month(i) ) ) THEN
begin_leaves(i,j) = .TRUE.
ENDIF
ENDIF ! PFT there and start of growing season allowed
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving ngd'
END SUBROUTINE pheno_ngd
END MODULE stomate_phenology
ORCHIDEE/src_stomate/stomate_prescribe.f90 0000754 0103600 0005670 00000020471 11164403473 020306 0 ustar acamlmd lmdjus ! Initialize density of individuals and crown area to some reasonable value
! if the DGVM is not (yet) activated.
! Prescribe density of individuals and crown area for agricultural PFTs.
! At first call, if the DGVM is not (yet) activated, impose some biomass if zero
! for a prescribed PFT. Initialize leaf age classes.
! At first call, if the DGVM is not (yet) activated, declare PFT present if its
! prescribed vegetation cover is above 0
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_prescribe.f90,v 1.9 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_prescribe
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC prescribe,prescribe_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE prescribe_clear
firstcall=.TRUE.
END SUBROUTINE prescribe_clear
SUBROUTINE prescribe (npts, &
space_nat, &
veget_max, PFTpresent, everywhere, when_growthinit, &
biomass, leaf_frac, ind, cn_ind)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! 0.2 modified fields
! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
! PFT present
LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
! is the PFT everywhere in the grid box or very localized (after its introduction)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
! how many days ago was the beginning of the growing season
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! density of individuals (1/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
! crown area of individuals (m**2)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: cn_ind
! 0.3 output
! 0.4 local
! generic tree crown area (m**2)
REAL(r_std), PARAMETER :: cn_tree = 4.
! stem diameter (m)
REAL(r_std), DIMENSION(npts) :: dia
! woodmass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts) :: woodmass
! woodmass of an individual (gC)
REAL(r_std), DIMENSION(npts) :: woodmass_ind
! index
INTEGER(i_std) :: i,j
! =========================================================================
DO j = 1, npft
! only when the DGVM is not activated or agricultural PFT.
IF ( ( .NOT. control%ok_dgvm ) .OR. ( .NOT. natural(j) ) ) THEN
!
! 1 crown area
!
cn_ind(:,j) = 0.0
IF ( tree(j) ) THEN
!
! 1.1 trees
!
dia(:) = 0.0
DO i = 1, npts
IF ( veget_max(i,j) .GT. 0.0 ) THEN
! 1.1.1 calculate total wood mass
woodmass(i) = biomass(i,j,isapabove) + biomass(i,j,isapbelow) + &
biomass(i,j,iheartabove) + biomass(i,j,iheartbelow)
IF ( woodmass(i) .GT. min_stomate ) THEN
! 1.1.2 calculate critical density of individuals
ind(i,j) = woodmass(i) / &
( pipe_density*pi/4.*pipe_tune2 * maxdia(j)**(2.+pipe_tune3) )
! 1.1.3 individual biomass corresponding to this critical density of individuals
woodmass_ind(i) = woodmass(i) / ind(i,j)
! 1.1.4 stem diameter
dia(i) = ( woodmass_ind(i) / ( pipe_density * pi/4. * pipe_tune2 ) ) ** &
( 1. / ( 2. + pipe_tune3 ) )
! 1.1.5 crown area, provisional
cn_ind(i,j) = pipe_tune1 * MIN( maxdia(j), dia(i) ) ** 1.6
! 1.1.6 do we have to recalculate the crown area?
IF ( cn_ind(i,j) * ind(i,j) .GT. 1.002* veget_max(i,j) ) THEN
ind(i,j) = veget_max(i,j) / cn_ind(i,j)
ELSE
ind(i,j) = ( veget_max(i,j) / &
( pipe_tune1 * (woodmass(i)/(pipe_density*pi/4.*pipe_tune2))**(1.6/(2.+pipe_tune3)) ) ) &
** (1./(1.-(1.6/(2.+pipe_tune3))))
woodmass_ind(i) = woodmass(i) / ind(i,j)
dia(i) = ( woodmass_ind(i) / ( pipe_density * pi/4. * pipe_tune2 ) ) ** &
( 1. / ( 2. + pipe_tune3 ) )
! final crown area
cn_ind(i,j) = pipe_tune1 * MIN( maxdia(j), dia(i) ) ** 1.6
ENDIF
ELSE
! woodmass = 0 => impose some value
dia(:) = maxdia(j)
cn_ind(i,j) = pipe_tune1 * MIN( maxdia(j), dia(i) ) ** 1.6
ENDIF
ENDIF ! veget_max .GT. 0.
ENDDO ! loop over grid points
ELSE
!
! 1.2 grasses: always 1m**2
!
WHERE ( veget_max(:,j) .GT. 0.0 )
cn_ind(:,j) = 1.0
ENDWHERE
ENDIF ! tree/grass?
!
! 2 density of individuals
!
WHERE ( veget_max(:,j) .GT. 0.0 )
ind(:,j) = veget_max(:,j) / cn_ind(:,j)
ELSEWHERE
ind(:,j) = 0.0
ENDWHERE
ENDIF ! not natural or DGVM not activated?
ENDDO ! loop over PFTs
!
! 4 first call
!
IF ( firstcall ) THEN
WRITE(numout,*) 'prescribe:'
! impose some biomass if zero and PFT prescribed
WRITE(numout,*) ' > Imposing initial biomass for prescribed trees, '// &
'initial reserve mass for prescribed grasses.'
WRITE(numout,*) ' > Declaring prescribed PFTs present.'
DO j = 1, npft
DO i = 1, npts
! is vegetation static or PFT agricultural?
IF ( ( .NOT. control%ok_dgvm ) .OR. &
( ( .NOT. natural(j) ) .AND. ( veget_max(i,j) .GT. min_stomate ) ) ) THEN
!
! 4.1 trees
!
IF ( tree(j) .AND. &
( veget_max(i,j) .GT. min_stomate ) .AND. &
( SUM( biomass(i,j,:) ) .LE. min_stomate ) ) THEN
biomass(i,j,:) = 40. * bm_sapl(j,:) * ind(i,j)
! set leaf age classes
leaf_frac(i,j,:) = 0.0
leaf_frac(i,j,1) = 1.0
! set time since last beginning of growing season
when_growthinit(i,j) = large_value
! seasonal trees: no leaves at beginning
IF ( pheno_crit%pheno_model(j) .NE. 'none' ) THEN
biomass(i,j,ileaf) = 0.0
leaf_frac(i,j,1) = 0.0
ENDIF
ENDIF
!
! 4.2 grasses
!
IF ( ( .NOT. tree(j) ) .AND. &
( veget_max(i,j) .GT. min_stomate ) .AND. &
( SUM( biomass(i,j,:) ) .LE. min_stomate ) ) THEN
biomass(i,j,icarbres) = bm_sapl(j,icarbres) * ind(i,j)
! set leaf age classes
leaf_frac(i,j,:) = 0.0
leaf_frac(i,j,1) = 1.0
! set time since last beginning of growing season
when_growthinit(i,j) = large_value
ENDIF
!
! 4.3 declare PFT present everywhere in that grid box
!
IF ( veget_max(i,j) .GT. min_stomate ) THEN
PFTpresent(i,j) = .TRUE.
everywhere(i,j) = 1.
ENDIF
ENDIF ! not control%ok_dgvm or agricultural
ENDDO
ENDDO
firstcall = .FALSE.
ENDIF
END SUBROUTINE prescribe
END MODULE stomate_prescribe
ORCHIDEE/src_stomate/stomate_resp.f90 0000754 0103600 0005670 00000016702 11164403473 017303 0 ustar acamlmd lmdjus !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_resp.f90,v 1.6 2007/05/28 14:57:23 ssipsl Exp $
!IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
! calculate maintenance respiration on an hourly time step (NV 14/5/2002)
MODULE stomate_resp
! modules used:
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC maint_respiration,maint_respiration_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE maint_respiration_clear
firstcall=.TRUE.
END SUBROUTINE maint_respiration_clear
SUBROUTINE maint_respiration ( npts,dt,t2m,tlong_ref,stempdiag,height,veget_max,space_nat,&
rprof,biomass,resp_maint_part_radia)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step (seconds)
REAL(r_std), INTENT(in) :: dt
! 2 m air temperature (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m
! 2 m air temperature (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
! natural space
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! Soil temperature
REAL(r_std),DIMENSION (npts,nbdl), INTENT (in) :: stempdiag
! height of vegetation (m)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: height
! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
! root depth (m)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: rprof
! biomass (gC/m**2)
REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: biomass
! 0.2 modified fields
! 0.3 output
! maintenance respiration of different parts (gC/dt/m**2 of total ground)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: resp_maint_part_radia
! 0.4 local
! leaf area index
REAL(r_std), DIMENSION(npts,npft) :: lai
! soil levels (m)
REAL(r_std), SAVE, DIMENSION(0:nbdl) :: z_soil
! root temperature (convolution of root and soil temperature profiles)
REAL(r_std), DIMENSION(npts,npft) :: t_root
! maintenance respiration coefficients at 0 deg C (g/g d**-1)
REAL(r_std), DIMENSION(npts,npft,nparts) :: coeff_maint
! temperature which is pertinent for maintenance respiration (K)
REAL(r_std), DIMENSION(npts,nparts) :: t_maint
! integration constant for root profile
REAL(r_std), DIMENSION(npts) :: rpc
! temperature which is pertinent for maintenance respiration (K)
REAL(r_std), DIMENSION(npts,nparts) :: t_maint_radia
! long term annual mean temperature, C
REAL(r_std), DIMENSION(npts) :: tl
! slope of maintenance respiration coefficient (1/K)
REAL(r_std), DIMENSION(npts) :: slope
! Index
INTEGER(i_std) :: i,j,k,l,m
!
!
! 2 define maintenance respiration coefficients
!
IF (bavard.GE.3) WRITE(numout,*) 'Entering respiration'
!
! 1 Initializations
!
IF ( firstcall ) THEN
! 1.1.1 soil levels
z_soil(0) = 0.
z_soil(1:nbdl) = diaglev(1:nbdl)
! 1.1.2 messages
WRITE(numout,*) 'respiration:'
firstcall = .FALSE.
ENDIF
!
!
! 1 do initialisation
!
DO j = 1, npft
! 1.3.1 rpc is an integration constant such that the integral of the root profile is 1.
rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / rprof(:,j) ) )
! 1.3.2 integrate over the nbdl levels
t_root(:,j) = 0.0
DO l = 1, nbdl
t_root(:,j) = &
t_root(:,j) + stempdiag(:,l) * rpc(:) * &
( EXP( -z_soil(l-1)/rprof(:,j) ) - EXP( -z_soil(l)/rprof(:,j) ) )
ENDDO
ENDDO
DO j = 1, npft
!
! 2.1 temperature which is taken for the plant part we are talking about
!
! 2.1.1 parts above the ground
t_maint_radia(:,ileaf) = t2m(:)
t_maint_radia(:,isapabove) = t2m(:)
t_maint_radia(:,ifruit) = t2m(:)
! 2.1.2 parts below the ground
t_maint_radia(:,isapbelow) = t_root(:,j)
t_maint_radia(:,iroot) = t_root(:,j)
! 2.1.3 heartwood: does not respire. Any temperature
t_maint_radia(:,iheartbelow) = t_root(:,j)
t_maint_radia(:,iheartabove) = t2m(:)
! 2.1.4 reserve: above the ground for trees, below for grasses
IF ( tree(j) ) THEN
t_maint_radia(:,icarbres) = t2m(:)
ELSE
t_maint_radia(:,icarbres) = t_root(:,j)
ENDIF
!
! 2.2 calculate coefficient
!
tl(:) = tlong_ref(:) - ZeroCelsius
slope(:) = maint_resp_slope(j,1) + tl(:) * maint_resp_slope(j,2) + &
tl(:)*tl(:) * maint_resp_slope(j,3)
DO k = 1, nparts
coeff_maint(:,j,k) = &
MAX( (coeff_maint_zero(j,k)*dt/one_day) * &
( 1. + slope(:) * (t_maint_radia(:,k)-ZeroCelsius) ), 0._r_std )
ENDDO
ENDDO
!
! 3 calculate maintenance respiration.
!
DO j = 1, npft
!
! 3.1 maintenance respiration of the different plant parts
!
IF (natural(j)) THEN
WHERE ( veget_max(:,j) .GT. 0.0 )
lai(:,j) = biomass(:,j,ileaf)*space_nat / veget_max(:,j) * sla(j)
ELSEWHERE
lai(:,j) = 0.0
ENDWHERE
ELSE
WHERE ( veget_max(:,j) .GT. 0.0 )
lai(:,j) = biomass(:,j,ileaf)*(1-space_nat) / veget_max(:,j) * sla(j)
ELSEWHERE
lai(:,j) = 0.0
ENDWHERE
ENDIF
DO k = 1, nparts
IF ( k .EQ. ileaf ) THEN
! Leaves: respiration depends on leaf mass AND LAI.
WHERE ( (biomass(:,j,ileaf) .GT. min_stomate) .AND. (lai(:,j) .GT. 0.0) )
resp_maint_part_radia(:,j,k) = coeff_maint(:,j,k) * biomass(:,j,k) * &
( .3*lai(:,j) + 1.4*(1.-exp(-.5*lai(:,j))) ) / lai(:,j)
ELSEWHERE
resp_maint_part_radia(:,j,k) = 0.0
ENDWHERE
ELSE
resp_maint_part_radia(:,j,k) = coeff_maint(:,j,k) * biomass(:,j,k)
ENDIF
ENDDO
!
! 3.2 Total maintenance respiration of the plant
! VPP killer:
! resp_maint(:,j) = SUM( resp_maint_part(:,:), DIM=2 )
!
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving respiration'
END SUBROUTINE maint_respiration
END MODULE stomate_resp
ORCHIDEE/src_stomate/stomate_season.f90 0000754 0103600 0005670 00000072435 11164403473 017627 0 ustar acamlmd lmdjus ! Calculate long-term meteorological parameters from daily temperatures
! and precipitations (essentially for phenology)
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_season.f90,v 1.11 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_season
! modules used:
USE ioipsl
USE stomate_constants
USE stomate_natagritot
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC season,season_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE season_clear
firstcall=.TRUE.
END SUBROUTINE season_clear
SUBROUTINE season (npts, dt, EndOfYear, space_nat, &
veget, veget_max, &
moiavail_daily, t2m_daily, tsoil_daily, soilhum_daily, &
precip_daily, npp_daily, biomass, turnover_daily, gpp_daily, when_growthinit, &
maxmoiavail_lastyear, maxmoiavail_thisyear, &
minmoiavail_lastyear, minmoiavail_thisyear, &
maxgppweek_lastyear, maxgppweek_thisyear, &
gdd0_lastyear, gdd0_thisyear, &
precip_lastyear, precip_thisyear, &
lm_lastyearmax, lm_thisyearmax, &
maxfpc_lastyear, maxfpc_thisyear, &
moiavail_month, moiavail_week, t2m_longterm, tlong_ref, t2m_month, t2m_week, &
tsoil_month, soilhum_month, &
npp_longterm, turnover_longterm, gpp_week, &
gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, time_lowgpp, &
time_hum_min, hum_min_dormance, herbivores)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step in days
REAL(r_std), INTENT(in) :: dt
! update yearly variables?
LOGICAL, INTENT(in) :: EndOfYear
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! coverage fraction of a PFT. Here: fraction of total ground.
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget
! "maximal" coverage fraction of a PFT (for LAI -> infinity)
! Here: fraction of total ground.
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
! Daily moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_daily
! Daily 2 meter temperature (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_daily
! Daily soil temperature (K)
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil_daily
! Daily soil humidity
REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum_daily
! Daily mean precipitation (mm/day)
REAL(r_std), DIMENSION(npts), INTENT(in) :: precip_daily
! daily net primary productivity (gC/m**2/day)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: npp_daily
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: biomass
! Turnover rates (gC/m**2/day)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: turnover_daily
! daily gross primary productivity (Here: gC/(m**2 of total ground)/day)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gpp_daily
! how many days ago was the beginning of the growing season
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: when_growthinit
! 0.2 modified fields
! last year's maximum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxmoiavail_lastyear
! this year's maximum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxmoiavail_thisyear
! last year's minimum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: minmoiavail_lastyear
! this year's minimum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: minmoiavail_thisyear
! last year's maximum weekly GPP
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxgppweek_lastyear
! this year's maximum weekly GPP
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxgppweek_thisyear
! last year's annual GDD0
REAL(r_std), DIMENSION(npts), INTENT(inout) :: gdd0_lastyear
! this year's annual GDD0
REAL(r_std), DIMENSION(npts), INTENT(inout) :: gdd0_thisyear
! last year's annual precipitation (mm/year)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: precip_lastyear
! this year's annual precipitation (mm/year)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: precip_thisyear
! last year's maximum leaf mass, for each PFT (gC/m**2)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_lastyearmax
! this year's maximum leaf mass, for each PFT (gC/m**2)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_thisyearmax
! last year's maximum fpc for each natural PFT, on *natural* ground
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxfpc_lastyear
! this year's maximum fpc for each PFT, on *total* ground
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxfpc_thisyear
! "monthly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: moiavail_month
! "weekly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: moiavail_week
! "long term" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: t2m_longterm
! "long term" refernce 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: tlong_ref
! "monthly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: t2m_month
! "weekly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(inout) :: t2m_week
! "monthly" soil temperatures (K)
REAL(r_std), DIMENSION(npts,nbdl), INTENT(inout) :: tsoil_month
! "monthly" soil humidity
REAL(r_std), DIMENSION(npts,nbdl), INTENT(inout) :: soilhum_month
! "long term" net primary productivity (gC/m**2/year)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: npp_longterm
! "long term" turnover rate (gC/m**2/year)
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: turnover_longterm
! "weekly" GPP (gC/day/(m**2 covered)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gpp_week
! growing degree days, threshold -5 deg. C
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_m5_dormance
! growing degree days since midwinter
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_midwinter
! number of chilling days since leaves were lost
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ncd_dormance
! number of growing days
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ngd_minus5
! duration of dormance (d)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: time_lowgpp
! time elapsed since strongest moisture availability (d)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: time_hum_min
! minimum moisture during dormance
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: hum_min_dormance
! 0.3 output (diagnostic)
! time constant of probability of a leaf to be eaten by a herbivore (days)
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: herbivores
! 0.4 local
! indices
INTEGER(i_std) :: j
! rapport maximal GPP/GGP_max pour dormance
REAL(r_std), PARAMETER :: gppfrac_dormance = 0.2
! maximum ncd (d) (to avoid floating point underflows)
REAL(r_std) :: ncd_max
! parameters for herbivore activity
REAL(r_std), PARAMETER :: hvc1 = 0.019
REAL(r_std), PARAMETER :: hvc2 = 1.38
REAL(r_std), PARAMETER :: leaf_frac=.33
! sum of natural fpcs
REAL(r_std), DIMENSION(npts) :: sumfpc_nat
! weights
REAL(r_std), DIMENSION(npts) :: weighttot
! natural long-term leaf NPP ( gC/m**2/year)
REAL(r_std), DIMENSION(npts) :: nlflong_nat
! residence time of green tissue (years)
REAL(r_std), DIMENSION(npts) :: green_age
! herbivore consumption (gC/m**2/day)
REAL(r_std), DIMENSION(npts) :: consumption
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering season'
!
! 1 Initializations
!
ncd_max = 3. * one_year
IF ( firstcall ) THEN
!
! 1.1 messages
!
IF ( bavard .GE. 1 ) THEN
WRITE(numout,*) 'season: '
WRITE(numout,*) ' > rapport maximal GPP/GGP_max pour dormance: ',gppfrac_dormance
WRITE(numout,*) ' > maximum possible ncd (d): ',ncd_max
WRITE(numout,*) ' > herbivore consumption C (gC/m2/day) as a function of NPP (gC/m2/d):'
WRITE(numout,*) ' C=',hvc1,' * NPP^',hvc2
WRITE(numout,*) ' > for herbivores, suppose that ',leaf_frac*100., &
'% of NPP is allocated to leaves'
ENDIF
!
! 1.2 Check whether longer-term meteorological parameters are initialized
! to zero
!
! 1.2.1 moisture availabilities
! 1.2.1.1 "monthly"
IF ( ABS( SUM( moiavail_month(:,:) ) ) .LT. min_stomate ) THEN
! in this case, set them it today's moisture availability
WRITE(numout,*) 'Warning! We have to initialize the ''monthly'' moisture availabilities.'
moiavail_month(:,:) = moiavail_daily(:,:)
ENDIF
! 1.2.1.2 "weekly"
IF ( ABS( SUM( moiavail_week(:,:) ) ) .LT. min_stomate ) THEN
! in this case, set them it today's moisture availability
WRITE(numout,*) 'Warning! We have to initialize the ''weekly'' moisture availabilities.'
moiavail_week(:,:) = moiavail_daily(:,:)
ENDIF
! 1.2.2 2-meter temperatures
! 1.2.2.1 "long term"
IF ( ABS( SUM( t2m_longterm(:) ) ) .LT. min_stomate ) THEN
! in this case, set them to today's temperature
WRITE(numout,*) 'Warning! We have to initialize the ''long term'' 2m temperatures.'
t2m_longterm(:) = t2m_daily(:)
ENDIF
! 1.2.2.2 "monthly"
IF ( ABS( SUM( t2m_month(:) ) ) .LT. min_stomate ) THEN
! in this case, set them to today's temperature
WRITE(numout,*) 'Warning! We have to initialize the ''monthly'' 2m temperatures.'
t2m_month(:) = t2m_daily(:)
ENDIF
! 1.2.2.3 "weekly"
IF ( ABS( SUM( t2m_week(:) ) ) .LT. min_stomate ) THEN
! in this case, set them to today's temperature
WRITE(numout,*) 'Warning! We have to initialize the ''weekly'' 2m temperatures.'
t2m_week(:) = t2m_daily(:)
ENDIF
! 1.2.3 "monthly" soil temperatures
IF ( ABS( SUM( tsoil_month(:,:) ) ) .LT. min_stomate ) THEN
! in this case, set them to today's temperature
WRITE(numout,*) 'Warning!'// &
' We have to initialize the ''monthly'' soil temperatures.'
tsoil_month(:,:) = tsoil_daily(:,:)
ENDIF
! 1.2.4 "monthly" soil humidity
IF ( ABS( SUM( soilhum_month(:,:) ) ) .LT. min_stomate ) THEN
! in this case, set them to today's humidity
WRITE(numout,*) 'Warning!'// &
' We have to initialize the ''monthly'' soil humidity.'
soilhum_month(:,:) = soilhum_daily(:,:)
ENDIF
! 1.2.5 growing degree days, threshold -5 deg C
IF ( ABS( SUM( gdd_m5_dormance(:,:) ) ) .LT. min_stomate ) THEN
WRITE(numout,*) 'Warning! Growing degree days (-5 deg) are initialized to ''undef''.'
gdd_m5_dormance(:,:) = undef
ENDIF
! 1.2.6 growing degree days since midwinter
IF ( ABS( SUM( gdd_midwinter(:,:) ) ) .LT. min_stomate ) THEN
WRITE(numout,*) 'Warning! Growing degree days since midwinter' // &
' are initialized to ''undef''.'
gdd_midwinter(:,:) = undef
ENDIF
! 1.2.7 number of chilling days since leaves were lost
IF ( ABS( SUM( ncd_dormance(:,:) ) ) .LT. min_stomate ) THEN
WRITE(numout,*) 'Warning! Number of chilling days is initialized to ''undef''.'
ncd_dormance(:,:) = undef
ENDIF
! 1.2.8 number of growing days, threshold -5 deg C
IF ( ABS( SUM( ngd_minus5(:,:) ) ) .LT. min_stomate ) THEN
WRITE(numout,*) 'Warning! Number of growing days (-5 deg) is initialized to 0.'
ENDIF
! 1.2.9 "long term" npp
IF ( ABS( SUM( npp_longterm(:,:) ) ) .LT. min_stomate ) THEN
WRITE(numout,*) 'Warning! Long term NPP is initialized to 0.'
ENDIF
! 1.2.10 "long term" turnover
IF ( ABS( SUM( turnover_longterm(:,:,:) ) ) .LT. min_stomate ) THEN
WRITE(numout,*) 'Warning! Long term turnover is initialized to 0.'
ENDIF
! 1.2.11 "weekly" GPP
IF ( ABS( SUM( gpp_week(:,:) ) ) .LT. min_stomate ) THEN
WRITE(numout,*) 'Warning! Weekly GPP is initialized to 0.'
ENDIF
! 1.2.12 minimum moisture availabilities
IF ( ABS( SUM( minmoiavail_thisyear(:,:) ) ) .LT. min_stomate ) THEN
! in this case, set them to a very high value
WRITE(numout,*) 'Warning! We have to initialize this year''s minimum '// &
'moisture availabilities.'
minmoiavail_thisyear(:,:) = large_value
ENDIF
!
! 1.3 reset flag
!
firstcall = .FALSE.
ENDIF
!
! 2 moisture availabilities
!
!
! 2.1 "monthly"
!
moiavail_month = ( moiavail_month * ( pheno_crit%tau_hum_month - dt ) + &
moiavail_daily * dt ) / pheno_crit%tau_hum_month
WHERE ( ABS(moiavail_month(:,:)) .LT. EPSILON(0.) )
moiavail_month(:,:) = 0.
ENDWHERE
!
! 2.2 "weekly"
!
moiavail_week = ( moiavail_week * ( pheno_crit%tau_hum_week - dt ) + &
moiavail_daily * dt ) / pheno_crit%tau_hum_week
WHERE ( ABS(moiavail_week(:,:)) .LT. EPSILON(0.) )
moiavail_week(:,:) = 0.
ENDWHERE
!
! 3 2-meter temperatures
!
!
! 3.1 "long term"
!
t2m_longterm = ( t2m_longterm * ( pheno_crit%tau_longterm - dt ) + &
t2m_daily * dt ) / pheno_crit%tau_longterm
WHERE ( ABS(t2m_longterm(:)) .LT. EPSILON(0.) )
t2m_longterm(:) = 0.
ENDWHERE
!
! 3.2 "long term reference"
! This temperature is used for recalculating PFT-specific parameters such as
! critical photosynthesis temperatures of critical GDDs for phenology. This
! means that if the reference temperature varies, the PFTs adapt to them.
! Therefore the reference temperature can vary only if the vegetation is not
! static.
!
tlong_ref(:) = MAX( tlong_ref_min, MIN( tlong_ref_max, t2m_longterm(:) ) )
!
! 3.3 "monthly"
!
t2m_month = ( t2m_month * ( pheno_crit%tau_t2m_month - dt ) + &
t2m_daily * dt ) / pheno_crit%tau_t2m_month
WHERE ( ABS(t2m_month(:)) .LT. EPSILON(0.) )
t2m_month(:) = 0.
ENDWHERE
!
! 3.4 "weekly"
!
t2m_week = ( t2m_week * ( pheno_crit%tau_t2m_week - dt ) + &
t2m_daily * dt ) / pheno_crit%tau_t2m_week
WHERE ( ABS(t2m_week(:)) .LT. EPSILON(0.) )
t2m_week(:) = 0.
ENDWHERE
!
! 4 ''monthly'' soil temperatures
!
tsoil_month = ( tsoil_month * ( pheno_crit%tau_tsoil_month - dt ) + &
tsoil_daily(:,:) * dt ) / pheno_crit%tau_tsoil_month
WHERE ( ABS(tsoil_month(:,:)) .LT. EPSILON(0.) )
tsoil_month(:,:) = 0.
ENDWHERE
!
! 5 ''monthly'' soil humidity
!
soilhum_month = ( soilhum_month * ( pheno_crit%tau_soilhum_month - dt ) + &
soilhum_daily * dt ) / pheno_crit%tau_soilhum_month
WHERE ( ABS(soilhum_month(:,:)) .LT. EPSILON(0.) )
soilhum_month(:,:) = 0.
ENDWHERE
!
! 6 dormance (d)
! when gpp is low, increase dormance time. Otherwise, set it to zero.
! NV: special case (3rd condition): plant is accumulating carbohydrates
! and does never use them. In this case, we allow the plant to
! detect a beginning of the growing season by declaring it dormant
!
WHERE ( ( gpp_week(:,:) .EQ. 0.0 ) .OR. &
( gpp_week(:,:) .LT. gppfrac_dormance * maxgppweek_lastyear(:,:) ) .OR. &
( ( when_growthinit(:,:) .GT. 2.*one_year ) .AND. &
( biomass(:,:,icarbres) .GT. biomass(:,:,ileaf)*4. ) ) )
time_lowgpp(:,:) = time_lowgpp(:,:) + dt
ELSEWHERE
time_lowgpp(:,:) = 0.0
ENDWHERE
!
! 7 growing degree days, threshold -5 deg C
!
DO j = 1, npft
! only for PFTs for which critical gdd is defined
! gdd_m5_dormance is set to 0 at the end of the growing season. It is set to undef
! at the beginning of the growing season.
IF ( ALL(pheno_crit%gdd(j,:) .NE. undef) ) THEN
!
! 7.1 set to zero if undef and no gpp
!
WHERE ( ( time_lowgpp(:,j) .GT. 0.0 ) .AND. ( gdd_m5_dormance(:,j) .EQ. undef ) )
gdd_m5_dormance(:,j) = 0.0
ENDWHERE
!
! 7.2 set to undef if there is gpp
!
WHERE ( time_lowgpp(:,j) .EQ. 0.0 )
gdd_m5_dormance(:,j) = undef
ENDWHERE
!
! 7.3 normal update where gdd_m5_dormance is defined
!
WHERE ( ( t2m_daily(:) .GT. (ZeroCelsius-5.) ) .AND. &
( gdd_m5_dormance(:,j) .NE. undef ) )
gdd_m5_dormance(:,j) = gdd_m5_dormance(:,j) + &
dt * ( t2m_daily(:) - (ZeroCelsius-5.) )
ENDWHERE
WHERE ( gdd_m5_dormance(:,j) .NE. undef )
gdd_m5_dormance(:,j) = gdd_m5_dormance(:,j) * &
( pheno_crit%tau_gdd - dt ) / pheno_crit%tau_gdd
ENDWHERE
ENDIF
ENDDO
WHERE ( ABS(gdd_m5_dormance(:,:)) .LT. EPSILON(0.) )
gdd_m5_dormance(:,:) = 0.
ENDWHERE
!
! 8 growing degree days since midwinter
!
DO j = 1, npft
! only for PFTs for which ncdgdd_crittemp is defined
IF ( pheno_crit%ncdgdd_temp(j) .NE. undef ) THEN
!
! 8.1 set to 0 if undef and if we detect "midwinter"
!
WHERE ( ( gdd_midwinter(:,j) .EQ. undef ) .AND. &
( t2m_month(:) .LT. t2m_week(:) ) .AND. &
( t2m_month(:) .LT. t2m_longterm(:) ) )
gdd_midwinter(:,j) = 0.0
ENDWHERE
!
! 8.2 set to undef if we detect "midsummer"
!
WHERE ( ( t2m_month(:) .GT. t2m_week(:) ) .AND. &
( t2m_month(:) .GT. t2m_longterm(:) ) )
gdd_midwinter(:,j) = undef
ENDWHERE
!
! 8.3 normal update
!
WHERE ( ( gdd_midwinter(:,j) .NE. undef ) .AND. &
( t2m_daily(:) .GT. pheno_crit%ncdgdd_temp(j)+ZeroCelsius ) )
gdd_midwinter(:,j) = &
gdd_midwinter(:,j) + &
dt * ( t2m_daily(:) - ( pheno_crit%ncdgdd_temp(j)+ZeroCelsius ) )
ENDWHERE
ENDIF
ENDDO
!
! 9 number of chilling days since leaves were lost
!
DO j = 1, npft
IF ( pheno_crit%ncdgdd_temp(j) .NE. undef ) THEN
!
! 9.1 set to zero if undef and no gpp
!
WHERE ( ( time_lowgpp(:,j) .GT. 0.0 ) .AND. ( ncd_dormance(:,j) .EQ. undef ) )
ncd_dormance(:,j) = 0.0
ENDWHERE
!
! 9.2 set to undef if there is gpp
!
WHERE ( time_lowgpp(:,j) .EQ. 0.0 )
ncd_dormance(:,j) = undef
ENDWHERE
!
! 9.3 normal update where ncd_dormance is defined
!
WHERE ( ( ncd_dormance(:,j) .NE. undef ) .AND. &
( t2m_daily(:) .LE. pheno_crit%ncdgdd_temp(j)+ZeroCelsius ) )
ncd_dormance(:,j) = MIN( ncd_dormance(:,j) + dt, ncd_max )
ENDWHERE
ENDIF
ENDDO
!
! 10 number of growing days, threshold -5 deg C
!
DO j = 1, npft
!
! 10.1 Where there is GPP, set ngd to 0
! This means that we only take into account ngds when the leaves are off
!
WHERE ( time_lowgpp(:,j) .LT. min_stomate )
ngd_minus5(:,j) = 0.0
ENDWHERE
!
! 10.2 normal update
!
WHERE ( t2m_daily(:) .GT. (ZeroCelsius-5.) )
ngd_minus5(:,j) = ngd_minus5(:,j) + dt
ENDWHERE
ngd_minus5(:,j) = ngd_minus5(:,j) * ( pheno_crit%tau_ngd - dt ) / pheno_crit%tau_ngd
ENDDO
WHERE ( ABS(ngd_minus5(:,:)) .LT. EPSILON(0.) )
ngd_minus5(:,:) = 0.
ENDWHERE
!
! 11 minimum humidity since dormance began and time elapsed since this minimum
!
DO j = 1, npft
IF ( pheno_crit%hum_min_time(j) .NE. undef ) THEN
!
! 11.1 initialize if undef and no gpp
!
WHERE ( ( time_lowgpp(:,j) .GT. 0.0 ) .AND. &
( ( time_hum_min(:,j) .EQ. undef ) .OR. ( hum_min_dormance(:,j) .EQ. undef ) ) )
time_hum_min(:,j) = 0.0
hum_min_dormance(:,j) = moiavail_month(:,j)
ENDWHERE
!
! 11.2 set to undef where there is gpp
!
WHERE ( time_lowgpp(:,j) .EQ. 0.0 )
time_hum_min(:,j) = undef
hum_min_dormance(:,j) = undef
ENDWHERE
!
! 11.3 normal update where time_hum_min and hum_min_dormance are defined
!
! 11.3.1 increase time counter
WHERE ( ( time_hum_min(:,j) .NE. undef ) .AND. &
( hum_min_dormance(:,j) .NE. undef ) )
time_hum_min(:,j) = time_hum_min(:,j) + dt
ENDWHERE
! 11.3.2 set time to zero if minimum is reached
WHERE ( ( time_hum_min(:,j) .NE. undef ) .AND. &
( hum_min_dormance(:,j) .NE. undef ) .AND. &
( moiavail_month(:,j) .LE. hum_min_dormance(:,j) ) )
hum_min_dormance(:,j) = moiavail_month(:,j)
time_hum_min(:,j) = 0.0
ENDWHERE
ENDIF
ENDDO
!
! 12 "long term" NPP. npp_daily in gC/m**2/day, npp_longterm in gC/m**2/year.
!
npp_longterm = ( npp_longterm * ( pheno_crit%tau_longterm - dt ) + &
(npp_daily*one_year) * dt ) / &
pheno_crit%tau_longterm
WHERE ( ABS(npp_longterm(:,:)) .LT. EPSILON(0.) )
npp_longterm(:,:) = 0.
ENDWHERE
!
! 13 "long term" turnover rates, in gC/m**2/year.
!
turnover_longterm = ( turnover_longterm * ( pheno_crit%tau_longterm - dt ) + &
(turnover_daily*one_year) * dt ) / &
pheno_crit%tau_longterm
WHERE ( ABS(turnover_longterm(:,:,:)) .LT. EPSILON(0.) )
turnover_longterm(:,:,:) = 0.
ENDWHERE
!
! 14 "weekly" GPP, in gC/(m**2 covered)/day (!)
! i.e. divide daily gpp (in gC/m**2 of total ground/day) by vegetation fraction
! (m**2 covered/m**2 of total ground)
!
WHERE ( veget_max .GT. 0.0 )
gpp_week = ( gpp_week * ( pheno_crit%tau_gpp_week - dt ) + &
gpp_daily/veget_max * dt ) / pheno_crit%tau_gpp_week
ELSEWHERE
gpp_week = 0.0
ENDWHERE
WHERE ( ABS(gpp_week(:,:)) .LT. EPSILON(0.) )
gpp_week(:,:) = 0.
ENDWHERE
!
! 15 maximum and minimum moisture availabilities
!
WHERE ( moiavail_daily .GT. maxmoiavail_thisyear )
maxmoiavail_thisyear = moiavail_daily
ENDWHERE
WHERE ( moiavail_daily .LT. minmoiavail_thisyear )
minmoiavail_thisyear = moiavail_daily
ENDWHERE
!
! 16 annual maximum weekly GPP
!
WHERE ( gpp_week .GT. maxgppweek_thisyear )
maxgppweek_thisyear = gpp_week
ENDWHERE
!
! 17 annual GDD0
!
WHERE ( t2m_daily .GT. ZeroCelsius )
gdd0_thisyear = gdd0_thisyear + dt * ( t2m_daily - ZeroCelsius )
ENDWHERE
!
! 18 annual precipitation
!
precip_thisyear = precip_thisyear + dt * precip_daily
!
! 19 annual maximum leaf mass
! If STOMATE is not activated, this corresponds to the maximum possible
! LAI of the PFT
!
IF ( control%ok_stomate ) THEN
WHERE ( biomass(:,:,ileaf) .GT. lm_thisyearmax(:,:) )
lm_thisyearmax(:,:) = biomass(:,:,ileaf)
ENDWHERE
ELSE
DO j = 1, npft
lm_thisyearmax(:,j) = lai_max(j) * veget_max(:,j) / sla(j)
ENDDO
ENDIF
!
! 20 annual maximum fpc for each PFT
! "veget" is defined as fraction of total ground. Therefore, maxfpc_thisyear has
! the same unit.
!
WHERE ( veget(:,:) .GT. maxfpc_thisyear(:,:) )
maxfpc_thisyear(:,:) = veget(:,:)
ENDWHERE
!
! 21 Every year, replace last year's maximum and minimum moisture availability,
! annual GDD0, annual precipitation, annual max weekly GPP, and maximum leaf mass
IF ( EndOfYear ) THEN
!
! 21.1 replace old values
!
maxmoiavail_lastyear(:,:) = maxmoiavail_thisyear(:,:)
minmoiavail_lastyear(:,:) = minmoiavail_thisyear(:,:)
maxgppweek_lastyear(:,:) = maxgppweek_thisyear(:,:)
gdd0_lastyear(:) = gdd0_thisyear(:)
precip_lastyear(:) = precip_thisyear(:)
lm_lastyearmax(:,:) = lm_thisyearmax(:,:)
maxfpc_lastyear(:,:) = maxfpc_thisyear(:,:)
!
! 21.2 reset new values
!
maxmoiavail_thisyear(:,:) = 0.0
minmoiavail_thisyear(:,:) = large_value
maxgppweek_thisyear(:,:) = 0.0
gdd0_thisyear(:) = 0.0
precip_thisyear(:) = 0.0
lm_thisyearmax(:,:) = 0.0
maxfpc_thisyear(:,:) = 0.0
!
! 21.3 Special treatment for maxfpc.
!
!
! 21.3.1 Only take into account natural PFTs
!
DO j = 1, npft
IF ( .NOT. natural(j) ) THEN
maxfpc_lastyear(:,j) = 0.0
ENDIF
ENDDO
! 21.3.2 In Stomate, veget is defined as a fraction of nat/agri ground, not as a fraction
! of total ground. maxfpc_lastyear will be compared to veget in lpj_light.
! Therefore, we have to transform maxfpc_lastyear.
! * There may be problems if space_nat has changed during the year !!! *
CALL natagritot (npts, ito_natagri, space_nat, maxfpc_lastyear)
! 21.3.3 The sum of the maxfpc_lastyear for natural PFT must not exceed fpc_crit (=.95).
! However, it can slightly exceed this value as not all PFTs reach their maximum
! fpc at the same time. Therefore, if sum(maxfpc_lastyear) for the natural PFTs
! exceeds fpc_crit, we scale the values of maxfpc_lastyear so that the sum is
! fpc_crit.
! calculate the sum of maxfpc_lastyear
sumfpc_nat(:) = 0.0
DO j = 1, npft
sumfpc_nat(:) = sumfpc_nat(:) + maxfpc_lastyear(:,j)
ENDDO
! scale so that the new sum is fpc_crit
DO j = 1, npft
WHERE ( sumfpc_nat(:) .GT. fpc_crit )
maxfpc_lastyear(:,j) = maxfpc_lastyear(:,j) * (fpc_crit/sumfpc_nat(:))
ENDWHERE
ENDDO
ENDIF ! EndOfYear
!
! 22 diagnose herbivore activity, determined through as probability for a leaf to be
! eaten in a day
! Follows McNaughton et al., Nat 341, 142-144, 1989.
!
!
! 22.1 first calculate mean long-term leaf NPP in grid box, mean residence
! time (years) of green tissue (i.e. tissue that will be eaten by
! herbivores) (crudely approximated: 6 months for seasonal and 2 years
! for evergreen) and mean length of growing season (6 months for
! seasonal and 1 year for evergreen).
!
nlflong_nat(:) = 0.
weighttot(:) = 0.
green_age(:) = 0.
!
DO j = 1, npft
!
IF ( natural(j) ) THEN
!
weighttot(:) = weighttot(:) + lm_lastyearmax(:,j)
nlflong_nat(:) = nlflong_nat(:) + npp_longterm(:,j) * leaf_frac
!
IF ( pheno_crit%pheno_model(j) .EQ. 'none' ) THEN
green_age(:) = green_age(:) + 2. * lm_lastyearmax(:,j)
ELSE
green_age(:) = green_age(:) + .5 * lm_lastyearmax(:,j)
ENDIF
!
ENDIF
!
ENDDO
!
WHERE ( weighttot(:) .GT. zero )
green_age(:) = green_age(:) / weighttot(:)
ELSEWHERE
green_age(:) = 1.
ENDWHERE
!
! 22.2 McNaughton et al. give herbivore consumption as a function of annual leaf NPP.
! The annual leaf NPP can give us an idea about the edible biomass:
!
DO j = 1, npft
!
IF ( natural(j) ) THEN
!
WHERE ( nlflong_nat(:) .GT. zero )
consumption(:) = hvc1 * nlflong_nat(:) ** hvc2
herbivores(:,j) = one_year * green_age(:) * nlflong_nat(:) / consumption(:)
ELSEWHERE
herbivores(:,j) = 100000.
ENDWHERE
!
ELSE
!
herbivores(:,j) = 100000.
!
ENDIF
!
ENDDO
IF (bavard.GE.4) WRITE(numout,*) 'Leaving season'
END SUBROUTINE season
END MODULE stomate_season
ORCHIDEE/src_stomate/stomate_soilcarbon.f90 0000754 0103600 0005670 00000016135 11164403473 020465 0 ustar acamlmd lmdjus !
! Soil dynamics. Essentially after Century.
! FOR THE MOMENT, NO VERTICAL DISCRETISATION !!!!
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_soilcarbon.f90,v 1.6 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_soilcarbon
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC soilcarbon,soilcarbon_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE soilcarbon_clear
firstcall=.TRUE.
ENDSUBROUTINE soilcarbon_clear
SUBROUTINE soilcarbon (npts, dt, clay, space_nat, &
soilcarbon_input, control_temp, control_moist, &
carbon, &
resp_hetero_soil)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step in days
REAL(r_std), INTENT(in) :: dt
! clay fraction (between 0 and 1)
REAL(r_std), DIMENSION(npts), INTENT(in) :: clay
! total natural space (fraction of total space)
REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
! quantity of carbon going into carbon pools from litter decomposition
! (gC/(m**2 of nat/agri ground)/day)
REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(in) :: soilcarbon_input
! temperature control of heterotrophic respiration
REAL(r_std), DIMENSION(npts,nlevs), INTENT(in) :: control_temp
! moisture control of heterotrophic respiration
REAL(r_std), DIMENSION(npts,nlevs), INTENT(in) :: control_moist
! 0.2 modified fields
! carbon pool: active, slow, or passive, natural and agricultural (gC/m**2 of
! natural or agricultural ground)
REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(inout) :: carbon
! 0.3 output
! soil heterotrophic respiration (first in gC/day/m**2 of natural/agricultural ground,
! but output in gC/day/m**2 of total ground)
REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(out) :: resp_hetero_soil
! 0.4 local
! residence time in carbon pools (days)
REAL(r_std), SAVE, DIMENSION(ncarb) :: carbon_tau
! flux fractions within carbon pools
REAL(r_std), DIMENSION(npts,ncarb,ncarb) :: frac_carb
! fraction of carbon flux which goes into heterotrophic respiration
REAL(r_std), DIMENSION(npts,ncarb) :: frac_resp
! total flux out of carbon pools (gC/m**2)
REAL(r_std), DIMENSION(npts,ncarb) :: fluxtot
! fluxes between carbon pools (gC/m**2)
REAL(r_std), DIMENSION(npts,ncarb,ncarb) :: flux
! for messages
CHARACTER*7, DIMENSION(ncarb) :: carbon_str
! Indices
INTEGER(i_std) :: k,kk,m
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering soilcarbon'
!
! 1 initializations
!
!
! 1.1 get soil "constants"
!
! 1.1.1 flux fractions between carbon pools: depend on clay content, recalculated
! each time
! 1.1.1.1 from active pool: depends on clay content
frac_carb(:,iactive,iactive) = 0.0
frac_carb(:,iactive,ipassive) = 0.004
frac_carb(:,iactive,islow) = 1. - (.85-.68*clay(:)) - frac_carb(:,iactive,ipassive)
! 1.1.1.2 from slow pool
frac_carb(:,islow,islow) = .0
frac_carb(:,islow,iactive) = .42
frac_carb(:,islow,ipassive) = .03
! 1.1.1.3 from passive pool
frac_carb(:,ipassive,ipassive) = .0
frac_carb(:,ipassive,iactive) = .45
frac_carb(:,ipassive,islow) = .0
IF ( firstcall ) THEN
! 1.1.2 residence times in carbon pools (days)
carbon_tau(iactive) = .149 * one_year !!!!???? 1.5 years
carbon_tau(islow) = 5.48 * one_year !!!!???? 25 years
carbon_tau(ipassive) = 241. * one_year !!!!???? 1000 years
!
! 1.2 messages
!
carbon_str(iactive) = 'active'
carbon_str(islow) = 'slow'
carbon_str(ipassive) = 'passive'
WRITE(numout,*) 'soilcarbon:'
WRITE(numout,*) ' > minimal carbon residence time in carbon pools (d):'
DO k = 1, ncarb
WRITE(numout,*) ' ',carbon_str(k),':',carbon_tau(k)
ENDDO
WRITE(numout,*) ' > flux fractions between carbon pools: depend on clay content'
firstcall = .FALSE.
ENDIF
!
! 1.3 set output to zero
!
resp_hetero_soil(:,:) = 0.0
!
! 2 input into carbon pools
!
carbon(:,:,:) = carbon(:,:,:) + soilcarbon_input(:,:,:) * dt
!
! 3 fluxes within carbon reservoirs + respiration
!
!
! 3.1 determine fraction of flux that is respiration
! diagonal elements of frac_carb are zero
! VPP killer:
! frac_resp(:,:) = 1. - SUM( frac_carb(:,:,:), DIM=3 )
!
frac_resp(:,:) = 1. - frac_carb(:,:,iactive) - frac_carb(:,:,islow) - &
frac_carb(:,:,ipassive)
!
! 3.2 calculate fluxes
!
DO m = 1, nvegtypes
! 3.2.1 flux out of pools
DO k = 1, ncarb
! determine total flux out of pool
fluxtot(:,k) = dt/carbon_tau(k) * carbon(:,k,m) * &
control_moist(:,ibelow) * control_temp(:,ibelow)
IF ( k .EQ. iactive ) THEN
fluxtot(:,k) = fluxtot(:,k) * ( 1. - .75 * clay(:) )
ENDIF
! decrease this carbon pool
carbon(:,k,m) = carbon(:,k,m) - fluxtot(:,k)
! fluxes towards the other pools (k -> kk)
DO kk = 1, ncarb
flux(:,k,kk) = frac_carb(:,k,kk) * fluxtot(:,k)
ENDDO
ENDDO
! 3.2.2 respiration
! VPP killer:
! resp_hetero_soil(:,m) = SUM( frac_resp(:,:) * fluxtot(:,:), DIM=2 ) / dt
resp_hetero_soil(:,m) = &
( frac_resp(:,iactive) * fluxtot(:,iactive) + &
frac_resp(:,islow) * fluxtot(:,islow) + &
frac_resp(:,ipassive) * fluxtot(:,ipassive) ) / dt
! 3.2.3 add fluxes to active, slow, and passive pools
! VPP killer:
! carbon(:,:,m) = carbon(:,:,m) + SUM( flux(:,:,:), DIM=2 )
DO k = 1, ncarb
carbon(:,k,m) = carbon(:,k,m) + &
flux(:,iactive,k) + flux(:,ipassive,k) + flux(:,islow,k)
ENDDO
ENDDO
!
! 4 transform respiration from gC/day/(m**2 of nat/agri ground) to
! gC/day/(m**2 of total ground), as it goes into the atmosphere.
!
resp_hetero_soil(:,iagri) = resp_hetero_soil(:,iagri) * ( 1. - space_nat(:) )
resp_hetero_soil(:,inat) = resp_hetero_soil(:,inat) * ( space_nat(:) )
IF (bavard.GE.4) WRITE(numout,*) 'Leaving soilcarbon'
END SUBROUTINE soilcarbon
END MODULE stomate_soilcarbon
ORCHIDEE/src_stomate/stomate_turnover.f90 0000754 0103600 0005670 00000056217 11164403473 020223 0 ustar acamlmd lmdjus ! This subroutine calculates:
! 1-6 : leaf senescence, climatic and as a function of leaf age. New LAI.
! 7 : herbivores
! 8 : fruit turnover for trees.
! 9 : sapwood conversion.
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_turnover.f90,v 1.11 2007/05/28 14:44:55 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_turnover
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC turn, turn_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE turn_clear
firstcall=.TRUE.
END SUBROUTINE turn_clear
SUBROUTINE turn (npts, dt, PFTpresent, &
herbivores, &
maxmoiavail_lastyear, minmoiavail_lastyear, &
moiavail_week, moiavail_month, tlong_ref, t2m_month, t2m_week, veget_max, &
leaf_age, leaf_frac, age, lai, biomass, &
turnover, senescence,turnover_time)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step in days
REAL(r_std), INTENT(in) :: dt
! PFT exists
LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
! time constant of probability of a leaf to be eaten by a herbivore (days)
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: herbivores
! last year's maximum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
! last year's minimum moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
! "weekly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
! "monthly" moisture availability
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
! "long term" 2 meter reference temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
! "monthly" 2-meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
! "weekly" 2 meter temperatures (K)
REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
! 0.2 modified fields
! age of the leaves (days)
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! age (years)
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
! leaf area index
REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
! biomass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
! turnover_time of grasse
REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: turnover_time
! 0.3 output
! Turnover rates (gC/day/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: turnover
! is the plant senescent?
! (interesting only for deciduous trees: carbohydrate reserve)
LOGICAL, DIMENSION(npts,npft), INTENT(out) :: senescence
! 0.4 local
! mean age of the leaves (days)
REAL(r_std), DIMENSION(npts,npft) :: leaf_meanage
! Intermediate variable for turnover
REAL(r_std), DIMENSION(npts) :: dturnover
! critical moisture availability, function of last year's moisture availability
REAL(r_std), DIMENSION(npts) :: moiavail_crit
! long term annual mean temperature, C
REAL(r_std), DIMENSION(npts) :: tl
! critical senescence temperature, function of long term annual temperature (K)
REAL(r_std), DIMENSION(npts) :: t_crit
! shed the remaining leaves?
LOGICAL, DIMENSION(npts) :: shed_rest
! Sapwood conversion (gC/day(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts) :: sapconv
! old heartwood mass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts) :: hw_old
! new heartwood mass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts) :: hw_new
! old leaf mass (gC/(m**2 of nat/agri ground))
REAL(r_std), DIMENSION(npts) :: lm_old
! leaf mass change for each age class
REAL(r_std), DIMENSION(npts,nleafages) :: delta_lm
! turnover rate
REAL(r_std), DIMENSION(npts) :: turnover_rate
! critical leaf age (d)
REAL(r_std), DIMENSION(npts,npft) :: leaf_age_crit
! instantaneous turnover time
REAL(r_std), DIMENSION(npts,npft) :: new_turnover_time
! Index
INTEGER(i_std) :: j,m
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering turnover'
!
! 1 messages
!
IF ( firstcall ) THEN
WRITE(numout,*) 'turnover:'
WRITE(numout,*) ' > minimum mean leaf age for senescence (d): ',pheno_crit%min_leaf_age_for_senescence
firstcall = .FALSE.
ENDIF
!
! 2 Initializations
!
!
! 2.1 set output to zero
!
turnover(:,:,:) = 0.0
new_turnover_time=0.0
senescence(:,:) = .FALSE.
!
! 2.2 mean leaf age. Should actually be recalculated at the end of this routine,
! but it does not change too fast.
!
leaf_meanage(:,:) = 0.0
DO m = 1, nleafages
leaf_meanage(:,:) = leaf_meanage(:,:) + leaf_age(:,:,m) * leaf_frac(:,:,m)
ENDDO
!
! 3 different types of "climatic" leaf senescence
! does not change age structure.
!
DO j = 1, npft
!
! 3.1 determine if there is climatic senescence
!
SELECT CASE ( pheno_crit%senescence_type(j) )
CASE ( 'cold' )
! 3.1.1 summergreen species:
! monthly temperature low and temperature tendency negative ?
! critical temperature for senescence may depend on long term annual mean temperature
tl(:) = tlong_ref(:) - ZeroCelsius
t_crit(:) = ZeroCelsius + pheno_crit%senescence_temp(j,1) + &
tl(:) * pheno_crit%senescence_temp(j,2) + &
tl(:)*tl(:) * pheno_crit%senescence_temp(j,3)
WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. &
( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ) .AND. &
( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) )
senescence(:,j) = .TRUE.
ENDWHERE
CASE ( 'dry' )
! 3.1.2 raingreen species:
! does moisture availability drop below critical level?
moiavail_crit(:) = &
MIN( MAX( minmoiavail_lastyear(:,j) + pheno_crit%hum_frac(j) * &
( maxmoiavail_lastyear(:,j) - minmoiavail_lastyear(:,j) ), &
pheno_crit%senescence_hum(j) ), &
pheno_crit%nosenescence_hum(j) )
WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. &
( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ) .AND. &
( moiavail_week(:,j) .LT. moiavail_crit(:) ) )
senescence(:,j) = .TRUE.
ENDWHERE
CASE ( 'mixed' )
! 3.1.3 mixed criterion:
! moisture availability drops below critical level, or
! monthly temperature low and temperature tendency negative
moiavail_crit(:) = &
MIN( MAX( minmoiavail_lastyear(:,j) + pheno_crit%hum_frac(j) * &
( maxmoiavail_lastyear(:,j) - minmoiavail_lastyear(:,j) ), &
pheno_crit%senescence_hum(j) ), &
pheno_crit%nosenescence_hum(j) )
tl(:) = tlong_ref(:) - ZeroCelsius
t_crit(:) = ZeroCelsius + pheno_crit%senescence_temp(j,1) + &
tl(:) * pheno_crit%senescence_temp(j,2) + &
tl(:)*tl(:) * pheno_crit%senescence_temp(j,3)
IF ( tree(j) ) THEN
! critical temperature for senescence may depend on long term annual mean temperature
WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. &
( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ) .AND. &
( ( moiavail_week(:,j) .LT. moiavail_crit(:) ) .OR. &
( ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) ) ) )
senescence(:,j) = .TRUE.
ENDWHERE
ELSE
new_turnover_time(:,j)=pheno_crit%max_turnover_time(j)+20
WHERE ((moiavail_week(:,j) .LT. moiavail_month(:,j))&
.AND. (moiavail_week(:,j) .LT. pheno_crit%nosenescence_hum(j)))
new_turnover_time(:,j)=pheno_crit%max_turnover_time(j) * &
& moiavail_week(:,j)/ pheno_crit%nosenescence_hum(j) + &
& pheno_crit%min_turnover_time(j)
ENDWHERE
! WHERE ((t2m_month(:) .LT. t_crit(:)+5) .AND. ( t2m_week(:) .LT. t2m_month(:) ))
! new_turnover_time(:,j)=new_turnover_time(:,j)*((t2m_month(:)-t_crit(:))/5*0.4+0.6)
! ENDWHERE
! WHERE (new_turnover_time(:,j) .LT. pheno_crit%min_turnover_time(j))
! new_turnover_time(:,j)=pheno_crit%min_turnover_time(j)
! ENDWHERE
WHERE (new_turnover_time(:,j) .GT. turnover_time(:,j)*1.1)
new_turnover_time(:,j)=pheno_crit%max_turnover_time(j)+20
ENDWHERE
WHERE ( ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) &
& .AND. ( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ))
new_turnover_time(:,j)=pheno_crit%min_turnover_time(j)
ENDWHERE
! print *,'t_crit=',t_crit
turnover_time(:,j)=(turnover_time(:,j)*10./dt+new_turnover_time(:,j))/(10./dt+1.)
ENDIF
CASE ( 'none' )
! evergreen species: no climatic senescence
CASE default
WRITE(numout,*) 'turnover: don''t know how to treat this PFT.'
WRITE(numout,*) ' number: ',j
WRITE(numout,*) ' senescence type: ',pheno_crit%senescence_type(j)
STOP
END SELECT
!
! 3.2 drop leaves and roots, plus stems and fruits for grasses
!
IF ( tree(j) ) THEN
! 3.2.1 trees
WHERE ( senescence(:,j) )
turnover(:,j,ileaf) = biomass(:,j,ileaf) * dt / pheno_crit%leaffall(j)
turnover(:,j,iroot) = biomass(:,j,iroot) * dt / pheno_crit%leaffall(j)
biomass(:,j,ileaf) = biomass(:,j,ileaf) - turnover(:,j,ileaf)
biomass(:,j,iroot) = biomass(:,j,iroot) - turnover(:,j,iroot)
ENDWHERE
ELSE
! 3.2.2 grasses
WHERE (turnover_time(:,j) .LT. pheno_crit%max_turnover_time(j))
turnover(:,j,ileaf) = biomass(:,j,ileaf) * dt / turnover_time(:,j)
turnover(:,j,isapabove) = biomass(:,j,isapabove) * dt / turnover_time(:,j)
turnover(:,j,iroot) = biomass(:,j,iroot) * dt / turnover_time(:,j)
turnover(:,j,ifruit) = biomass(:,j,ifruit) * dt / turnover_time(:,j)
ELSEWHERE
turnover(:,j,ileaf)=0.0
turnover(:,j,isapabove) =0.0
turnover(:,j,iroot) = 0.0
turnover(:,j,ifruit) =0.0
ENDWHERE
biomass(:,j,ileaf) = biomass(:,j,ileaf) - turnover(:,j,ileaf)
biomass(:,j,isapabove) = biomass(:,j,isapabove) - turnover(:,j,isapabove)
biomass(:,j,iroot) = biomass(:,j,iroot) - turnover(:,j,iroot)
biomass(:,j,ifruit) = biomass(:,j,ifruit) - turnover(:,j,ifruit)
ENDIF ! tree/grass
ENDDO ! loop over PFTs
!
! 4 At a certain age, leaves fall off, even if the climate would allow a green plant
! all year round.
! Decay rate varies with leaf age.
! Roots, fruits (and stems) follow leaves.
! Note that plant is not declared senescent in this case (important for allocation:
! if the plant loses leaves because of their age, it can renew them).
!
DO j = 1, npft
! save old leaf mass
lm_old(:) = biomass(:,j,ileaf)
! initialize leaf mass change in age class
delta_lm(:,:) = 0.0
IF ( tree(j) ) THEN
!
! 4.1 trees: leaves, roots, fruits
! roots and fruits follow leaves.
!
! 4.1.1 critical age: prescribed for trees
leaf_age_crit(:,j) = pheno_crit%leafagecrit(j)
! 4.1.2 loop over leaf age classes
DO m = 1, nleafages
turnover_rate(:) =0
WHERE ( leaf_age(:,j,m) .GT. leaf_age_crit(:,j)/2. )
turnover_rate(:) = &
MIN( 0.99_r_std, dt / ( leaf_age_crit(:,j) * &
( leaf_age_crit(:,j) / leaf_age(:,j,m) )**4._r_std ) )
dturnover(:) = biomass(:,j,ileaf) * leaf_frac(:,j,m) * turnover_rate(:)
turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
! save leaf mass change
delta_lm(:,m) = - dturnover(:)
dturnover(:) = biomass(:,j,iroot) * leaf_frac(:,j,m) * turnover_rate(:)
turnover(:,j,iroot) = turnover(:,j,iroot) + dturnover(:)
biomass(:,j,iroot) = biomass(:,j,iroot) - dturnover(:)
dturnover(:) = biomass(:,j,ifruit) * leaf_frac(:,j,m) * turnover_rate(:)
turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
ENDWHERE
ENDDO
ELSE
!
! 4.2 grasses: leaves, roots, fruits, sap.
! roots, fruits, and sap follow leaves.
!
! 4.2.1 critical leaf age depends on long-term temperature:
! generally, lower turnover in cooler climates.
leaf_age_crit(:,j) = &
MIN( pheno_crit%leafagecrit(j) * 1.5_r_std , &
MAX( pheno_crit%leafagecrit(j) * 0.75_r_std, &
pheno_crit%leafagecrit(j) - 10._r_std * &
( tlong_ref(:)-ZeroCelsius-20._r_std ) ) )
! 4.2.2 loop over leaf age classes
DO m = 1, nleafages
WHERE ( leaf_age(:,j,m) .GT. leaf_age_crit(:,j)/2. )
turnover_rate(:) = &
MIN( 0.99_r_std, dt / ( leaf_age_crit(:,j) * &
( leaf_age_crit(:,j) / leaf_age(:,j,m) )**4._r_std ) )
dturnover(:) = biomass(:,j,ileaf) * leaf_frac(:,j,m) * turnover_rate(:)
turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
! save leaf mass change
delta_lm(:,m) = - dturnover(:)
dturnover(:) = biomass(:,j,isapabove) * leaf_frac(:,j,m) * turnover_rate(:)
turnover(:,j,isapabove) = turnover(:,j,isapabove) + dturnover(:)
biomass(:,j,isapabove) = biomass(:,j,isapabove) - dturnover(:)
dturnover(:) = biomass(:,j,iroot) * leaf_frac(:,j,m) * turnover_rate(:)
turnover(:,j,iroot) = turnover(:,j,iroot) + dturnover(:)
biomass(:,j,iroot) = biomass(:,j,iroot) - dturnover(:)
dturnover(:) = biomass(:,j,ifruit) * leaf_frac(:,j,m) * turnover_rate(:)
turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
ENDWHERE
ENDDO
ENDIF ! tree/grass ?
!
! 4.3 recalculate fraction in each leaf age class
! new fraction = new leaf mass of that fraction / new total leaf mass
! = ( old fraction*old total leaf mass + biomass change of that fraction ) /
! new total leaf mass
!
DO m = 1, nleafages
WHERE ( biomass(:,j,ileaf) .GT. 0.0 )
leaf_frac(:,j,m) = ( leaf_frac(:,j,m)*lm_old(:) + delta_lm(:,m) ) / biomass(:,j,ileaf)
ELSEWHERE
leaf_frac(:,j,m) = 0.0
ENDWHERE
ENDDO
ENDDO ! loop over PFTs
!
! 5 new (provisional) lai
!
! DO j = 1, npft
! WHERE ( PFTpresent(:,j) )
! lai(:,j) = biomass(:,j,ileaf) / veget_max(:,j) * sla(j)
! ELSEWHERE
! lai(:,j) = 0.0
! ENDWHERE
!
! ENDDO
!
! 6 definitely drop leaves if very low leaf mass during senescence.
! Also drop fruits and loose fine roots.
! Set lai to zero if necessary
! Check whether leaf regrowth is immediately allowed.
!
DO j = 1, npft
shed_rest(:) = .FALSE.
!
! 6.1 deciduous trees
!
IF ( tree(j) .AND. ( pheno_crit%senescence_type(j) .NE. 'none' ) ) THEN
! check whether we shed the remaining leaves
WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. senescence(:,j) .AND. &
( biomass(:,j,ileaf) .LT. (pheno_crit%lai_initmin(j) / 2.)* veget_max(:,j)/sla(j) ) )
shed_rest(:) = .TRUE.
turnover(:,j,ileaf) = turnover(:,j,ileaf) + biomass(:,j,ileaf)
turnover(:,j,iroot) = turnover(:,j,iroot) + biomass(:,j,iroot)
turnover(:,j,ifruit) = turnover(:,j,ifruit) + biomass(:,j,ifruit)
biomass(:,j,ileaf) = 0.0
biomass(:,j,iroot) = 0.0
biomass(:,j,ifruit) = 0.0
! reset leaf age
leaf_meanage(:,j) = 0.0
ENDWHERE
ENDIF
!
! 6.2 grasses: also convert stems
!
IF ( .NOT. tree(j) ) THEN
! Shed the remaining leaves if LAI very low.
WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. senescence(:,j) .AND. &
( biomass(:,j,ileaf) .LT. (pheno_crit%lai_initmin(j) / 2.)* veget_max(:,j)/sla(j) ))
shed_rest(:) = .TRUE.
turnover(:,j,ileaf) = turnover(:,j,ileaf) + biomass(:,j,ileaf)
turnover(:,j,isapabove) = turnover(:,j,isapabove) + biomass(:,j,isapabove)
turnover(:,j,iroot) = turnover(:,j,iroot) + biomass(:,j,iroot)
turnover(:,j,ifruit) = turnover(:,j,ifruit) + biomass(:,j,ifruit)
biomass(:,j,ileaf) = 0.0
biomass(:,j,isapabove) = 0.0
biomass(:,j,iroot) = 0.0
biomass(:,j,ifruit) = 0.0
! reset leaf age
leaf_meanage(:,j) = 0.0
ENDWHERE
ENDIF
!
! 6.3 reset leaf age structure
!
DO m = 1, nleafages
WHERE ( shed_rest(:) )
leaf_age(:,j,m) = 0.0
leaf_frac(:,j,m) = 0.0
ENDWHERE
ENDDO
ENDDO
!
! 7 Elephants, cows, gazelles. No lions.
! Does not modify leaf age structure.
!
IF ( ok_herbivores ) THEN
! herbivore activity allowed. Eat when there are leaves. Otherwise,
! there won't be many fruits anyway.
DO j = 1, npft
IF ( tree(j) ) THEN
! trees: only leaves and fruits are affected
WHERE ( biomass(:,j,ileaf) .GT. 0.0 )
dturnover(:) = biomass(:,j,ileaf) * dt / herbivores(:,j)
turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
dturnover(:) = biomass(:,j,ifruit) * dt / herbivores(:,j)
turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
ENDWHERE
ELSE
! grasses: the whole biomass above the ground: leaves, fruits, stems
WHERE ( biomass(:,j,ileaf) .GT. 0.0 )
WHERE ( (herbivores(:,j) .GT. 0.01) .AND. (herbivores(:,j) .LT. 100000.) )
dturnover(:) = biomass(:,j,ileaf) * dt / herbivores(:,j)
turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
dturnover(:) = biomass(:,j,isapabove) * dt / herbivores(:,j)
turnover(:,j,isapabove) = turnover(:,j,isapabove) + dturnover(:)
biomass(:,j,isapabove) = biomass(:,j,isapabove) - dturnover(:)
dturnover(:) = biomass(:,j,ifruit) * dt / herbivores(:,j)
turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
ENDWHERE
ENDWHERE
ENDIF ! tree/grass?
ENDDO ! loop over PFTs
ENDIF
!
! 8 fruit turnover for trees
!
DO j = 1, npft
IF ( tree(j) ) THEN
dturnover(:) = biomass(:,j,ifruit) * dt / tau_fruit(j)
turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
!!$ turnover(:,j,ifruit) = biomass(:,j,ifruit) * dt / tau_fruit(j)
!!$ biomass(:,j,ifruit) = biomass(:,j,ifruit) - turnover(:,j,ifruit)
ENDIF
ENDDO
!
! 9 Conversion of sapwood to heartwood
! This is not added to "turnover" as the biomass is not lost!
!
DO j = 1, npft
IF ( tree(j) ) THEN
! for age calculations
IF ( .NOT. control%ok_dgvm ) THEN
hw_old(:) = biomass(:,j,iheartabove) + biomass(:,j,iheartbelow)
ENDIF
!
! 9.1 Calculate the rate of conversion and update masses
!
! above the ground
sapconv(:) = biomass(:,j,isapabove) * dt / tau_sap(j)
biomass(:,j,isapabove) = biomass(:,j,isapabove) - sapconv(:)
biomass(:,j,iheartabove) = biomass(:,j,iheartabove) + sapconv(:)
! below the ground
sapconv(:) = biomass(:,j,isapbelow) * dt / tau_sap(j)
biomass(:,j,isapbelow) = biomass(:,j,isapbelow) - sapconv(:)
biomass(:,j,iheartbelow) = biomass(:,j,iheartbelow) + sapconv(:)
!
! 9.2 If vegetation is not dynamic, identify the age of the heartwood
! to the age of the whole tree (otherwise, the age of the tree is
! treated in the establishment routine).
! Creation of new heartwood decreases the age of the plant.
!
IF ( .NOT. control%ok_dgvm ) THEN
hw_new(:) = biomass(:,j,iheartabove) + biomass(:,j,iheartbelow)
WHERE ( hw_new(:) .GT. 0.0 )
age(:,j) = age(:,j) * hw_old(:)/hw_new(:)
ENDWHERE
ENDIF
ENDIF
ENDDO
!
! history
!
CALL histwrite (hist_id_stomate, 'LEAF_AGE', itime, &
leaf_meanage, npts*npft, horipft_index)
CALL histwrite (hist_id_stomate, 'HERBIVORES', itime, &
herbivores, npts*npft, horipft_index)
IF (bavard.GE.4) WRITE(numout,*) 'Leaving turnover'
END SUBROUTINE turn
END MODULE stomate_turnover
ORCHIDEE/src_stomate/stomate_vmax.f90 0000754 0103600 0005670 00000016772 11164403473 017314 0 ustar acamlmd lmdjus ! calculates the leaf efficiency
!
! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_vmax.f90,v 1.8 2007/05/28 14:49:02 ssipsl Exp $
! IPSL (2006)
! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
!
MODULE stomate_vmax
! modules used:
USE ioipsl
USE stomate_constants
IMPLICIT NONE
! private & public routines
PRIVATE
PUBLIC vmax, vmax_clear
! first call
LOGICAL, SAVE :: firstcall = .TRUE.
CONTAINS
SUBROUTINE vmax_clear
firstcall=.TRUE.
END SUBROUTINE vmax_clear
SUBROUTINE vmax (npts, dt, &
leaf_age, leaf_frac, &
vcmax, vjmax)
!
! 0 declarations
!
! 0.1 input
! Domain size
INTEGER(i_std), INTENT(in) :: npts
! time step of Stomate in days
REAL(r_std), INTENT(in) :: dt
! 0.2 modified fields
! leaf age (days)
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
! fraction of leaves in leaf age class
REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
! 0.3 output
! Maximum rate of carboxylation
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: vcmax
! Maximum rate of RUbp regeneration
REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: vjmax
! 0.4 local
! offset (minimum relative vcmax)
REAL(r_std), PARAMETER :: vmax_offset = 0.3
! leaf age at which vmax attains vcmax_opt (in fraction of critical leaf age)
REAL(r_std), PARAMETER :: leafage_firstmax = 0.03
! leaf age at which vmax falls below vcmax_opt (in fraction of critical leaf age)
REAL(r_std), PARAMETER :: leafage_lastmax = 0.5
! leaf age at which vmax attains its minimum (in fraction of critical leaf age)
REAL(r_std), PARAMETER :: leafage_old = 1.
! leaf efficiency (vcmax/vcmax_opt)
REAL(r_std), DIMENSION(npts) :: leaf_efficiency
! change of fraction of leaves in age class
REAL(r_std), DIMENSION(npts,npft,nleafages) :: d_leaf_frac
! new leaf age (d)
REAL(r_std), DIMENSION(npts,nleafages) :: leaf_age_new
! sum of leaf age fractions, for normalization
REAL(r_std), DIMENSION(npts) :: sumfrac
! relative leaf age (age/critical age)
REAL(r_std), DIMENSION(npts) :: rel_age
! Index
INTEGER(i_std) :: j,m
! =========================================================================
IF (bavard.GE.3) WRITE(numout,*) 'Entering vmax'
!
! 1 Initialization
!
!
! 1.1 first call: info about flags and parameters.
!
IF ( firstcall ) THEN
WRITE(numout,*) 'vmax:'
WRITE(numout,*) ' > offset (minimum vcmax/vmax_opt):' , vmax_offset
WRITE(numout,*) ' > relative leaf age at which vmax attains vcmax_opt:', leafage_firstmax
WRITE(numout,*) ' > relative leaf age at which vmax falls below vcmax_opt:', leafage_lastmax
WRITE(numout,*) ' > relative leaf age at which vmax attains its minimum:', leafage_old
firstcall = .FALSE.
ENDIF
!
! 1.2 initialize output
!
vcmax(:,:) = 0.0
vjmax(:,:) = 0.0
!
! 2 leaf age: general increase and turnover between age classes.
!
!
! 2.1 increase leaf age
!
DO m = 1, nleafages
WHERE ( leaf_frac(:,:,m) .GT. min_stomate )
leaf_age(:,:,m) = leaf_age(:,:,m) + dt
ENDWHERE
ENDDO
!
! 2.2 turnover between leaf age classes
! d_leaf_frac(:,:,m) = what leaves m-1 and goes into m
!
DO j = 1, npft
! 2.2.1 fluxes
! nothing goes into first age class
d_leaf_frac(:,j,1) = 0.0
! from m-1 to m
DO m = 2, nleafages
d_leaf_frac(:,j,m) = leaf_frac(:,j,m-1) * dt/leaf_timecst(j)
ENDDO
! 2.2.2 new leaf age in class
! new age = ( old age * old fraction + fractional increase * age of source ) /
! new fraction
leaf_age_new(:,:) = 0.0
DO m = 2, nleafages-1
WHERE ( d_leaf_frac(:,j,m) .GT. min_stomate )
leaf_age_new(:,m) = ( ( (leaf_frac(:,j,m)- d_leaf_frac(:,j,m+1)) * leaf_age(:,j,m) ) + &
( d_leaf_frac(:,j,m) * leaf_age(:,j,m-1) ) ) / &
( leaf_frac(:,j,m) + d_leaf_frac(:,j,m)- d_leaf_frac(:,j,m+1) )
ENDWHERE
ENDDO ! Loop over age classes
WHERE ( d_leaf_frac(:,j,nleafages) .GT. min_stomate )
leaf_age_new(:,nleafages) = ( ( leaf_frac(:,j,nleafages) * leaf_age(:,j,nleafages) ) + &
( d_leaf_frac(:,j,nleafages) * leaf_age(:,j,nleafages-1) ) ) / &
( leaf_frac(:,j,nleafages) + d_leaf_frac(:,j,nleafages) )
ENDWHERE
DO m = 2, nleafages
WHERE ( d_leaf_frac(:,j,m) .GT. min_stomate )
leaf_age(:,j,m) = leaf_age_new(:,m)
ENDWHERE
ENDDO ! Loop over age classes
! 2.2.3 calculate new fraction
DO m = 2, nleafages
! where the change comes from
leaf_frac(:,j,m-1) = leaf_frac(:,j,m-1) - d_leaf_frac(:,j,m)
! where it goes to
leaf_frac(:,j,m) = leaf_frac(:,j,m) + d_leaf_frac(:,j,m)
ENDDO
! 2.2.4 renormalize fractions in order to prevent accumulation
! of numerical errors
! correct small negative values
DO m = 1, nleafages
leaf_frac(:,j,m) = MAX( 0._r_std, leaf_frac(:,j,m) )
ENDDO
! total of fractions, should be very close to one where there is leaf mass
sumfrac(:) = 0.0
DO m = 1, nleafages
sumfrac(:) = sumfrac(:) + leaf_frac(:,j,m)
ENDDO
! normalize
DO m = 1, nleafages
WHERE ( sumfrac(:) .GT. min_stomate )
leaf_frac(:,j,m) = leaf_frac(:,j,m) / sumfrac(:)
ELSEWHERE
leaf_frac(:,j,m) = 0.0
ENDWHERE
ENDDO
ENDDO ! Loop over PFTs
!
! 3 calculate vmax as a function of the age
!
DO j = 1, npft
vcmax(:,j) = 0.0
vjmax(:,j) = 0.0
! sum up over the different age classes
DO m = 1, nleafages
!
! 3.1 efficiency in each of the age classes
! increases from 0 to 1 at the beginning (rel_age < leafage_firstmax), stays 1
! until rel_age = leafage_lastmax, then decreases to vmax_offset at
! rel_age = leafage_old, then stays at vmax_offset.
!
rel_age(:) = leaf_age(:,j,m) / pheno_crit%leafagecrit(j)
leaf_efficiency(:) = MAX( vmax_offset, MIN( 1._r_std, &
vmax_offset + (1._r_std-vmax_offset) * rel_age(:) / leafage_firstmax, &
1._r_std - (1._r_std-vmax_offset) * ( rel_age(:) - leafage_lastmax ) / &
( leafage_old - leafage_lastmax ) ) )
!
! 3.2 add to mean vmax
!
vcmax(:,j) = vcmax(:,j) + vcmax_opt(j) * leaf_efficiency(:) * leaf_frac(:,j,m)
vjmax(:,j) = vjmax(:,j) + vjmax_opt(j) * leaf_efficiency(:) * leaf_frac(:,j,m)
ENDDO ! loop over age classes
ENDDO ! loop over PFTs
IF (bavard.GE.4) WRITE(numout,*) 'Leaving vmax'
END SUBROUTINE vmax
END MODULE stomate_vmax
ORCHIDEE/src_stomate/i.stomate_constants.L 0000754 0103600 0005670 00000111375 11164403473 020374 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:44 2008
FILE NAME: i.stomate_constants.f90
PROGRAM NAME: stomate_constants
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_constants.f90,v 1.17 2007/05/28 14:41:53 ssipsl Exp $
2: !IPSL (2006)
3: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
4: !-
5: MODULE stomate_constants
6: !---------------------------------------------------------------------
7: USE defprec
8: USE constantes_veg
9: !-
10: ! Number of pfts
11: INTEGER(i_std),PARAMETER :: npft = nvm-1
12: !-
13: ! bare soil in Sechiba
14: INTEGER(i_std),PARAMETER :: ibare_sechiba = 1
15: !-
16: ! which Sechiba-PFT corresponds to a given Stomate-PFT
17: INTEGER(i_std),SAVE,DIMENSION(npft) :: ipft_sechiba
18: !-
19: ! how many Stomate-PFTs correspond to each Sechiba-PFT ?
20: ! e.g. for age classes
21: INTEGER(i_std),SAVE,DIMENSION(nvm) :: npft_stomate
22: !-
23: ! 0 = no, 4 = full online diagnostics
24: INTEGER(i_std),SAVE :: bavard=1
25: ! write forcing file for carbon spinup?
26: LOGICAL,SAVE :: write_carbonforce
27: ! Horizontal indices
28: INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: hori_index
29: ! Horizonatal + PFT indices
30: INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: horipft_index
31: !-
32: ! deforestation
33: ! Horizontal + P10 indices
34: INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip10_index
35: ! Horizontal + P100 indices
36: INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip100_index
37: ! Horizontal + P11 indices
38: INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip11_index
39: ! Horizontal + P101 indices
40: INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip101_index
41: !-
42: ! time step
43: INTEGER(i_std),SAVE :: itime
44: ! STOMATE history file ID
45: INTEGER(i_std),SAVE :: hist_id_stomate
46: ! STOMATE restart file ID
47: INTEGER(i_std),SAVE :: rest_id_stomate
48: !-
49: ! Freezing point
50: REAL(r_std),PARAMETER :: ZeroCelsius = 273.15
51: ! e
52: REAL(r_std),PARAMETER :: euler = 2.71828182846
53: ! Epsilon to detect a near zero floating point
54: REAL(r_std),PARAMETER :: min_stomate = 1.E-8_r_std
55: ! some large value
56: REAL(r_std),PARAMETER :: large_value = 1.E33_r_std
57: ! Special value
58: REAL(r_std),PARAMETER :: undef = -9999.
59: !-
60: ! maximum reference long term temperature (K)
61: REAL(r_std),PARAMETER :: tlong_ref_max=303.1
62: ! minimum reference long term temperature (K)
63: REAL(r_std),PARAMETER :: tlong_ref_min=253.1
64: !-
65: ! trees and litter: indices for the parts of heart- and sapwood above
66: ! and below the ground
67: INTEGER(i_std),PARAMETER :: iabove = 1
68: INTEGER(i_std),PARAMETER :: ibelow = 2
69: INTEGER(i_std),PARAMETER :: nlevs = 2
70: !-
71: ! litter: indices for metabolic and structural part
72: INTEGER(i_std),PARAMETER :: imetabolic = 1
73: INTEGER(i_std),PARAMETER :: istructural = 2
74: INTEGER(i_std),PARAMETER :: nlitt = 2
75: !-
76: ! carbon pools: indices
77: INTEGER(i_std),PARAMETER :: iactive = 1
78: INTEGER(i_std),PARAMETER :: islow = 2
79: INTEGER(i_std),PARAMETER :: ipassive = 3
80: INTEGER(i_std),PARAMETER :: ncarb = 3
81: !-
82: ! litter fractions: indices
83: INTEGER(i_std),PARAMETER :: ileaf = 1
84: INTEGER(i_std),PARAMETER :: isapabove = 2
85: INTEGER(i_std),PARAMETER :: isapbelow = 3
86: INTEGER(i_std),PARAMETER :: iheartabove = 4
87: INTEGER(i_std),PARAMETER :: iheartbelow = 5
88: INTEGER(i_std),PARAMETER :: iroot = 6
89: INTEGER(i_std),PARAMETER :: ifruit = 7
90: INTEGER(i_std),PARAMETER :: icarbres = 8
91: INTEGER(i_std),PARAMETER :: nparts = 8
92: !-
93: ! vegetation types: natural and agricultural
94: INTEGER(i_std),PARAMETER :: inat = 1
95: INTEGER(i_std),PARAMETER :: iagri = 2
96: INTEGER(i_std),PARAMETER :: nvegtypes = 2
97: !-
98: ! transformation between types of surface
99: INTEGER(i_std),PARAMETER :: ito_natagri = 1
100: INTEGER(i_std),PARAMETER :: ito_total = 2
101: !-
102: ! leaf age discretisation ( 1 = no discretisation )
103: INTEGER(i_std),PARAMETER :: nleafages = 4
104: !-
105: ! alpha's : ?
106: REAL(r_std),PARAMETER :: alpha_grass = .5
107: REAL(r_std),PARAMETER :: alpha_tree = 1.
108: !-
109: ! type declaration for photosynthesis
110: TYPE t_photo_type
111: REAL(r_std),DIMENSION(npft) :: t_max_a
112: REAL(r_std),DIMENSION(npft) :: t_max_b
113: REAL(r_std),DIMENSION(npft) :: t_max_c
114: REAL(r_std),DIMENSION(npft) :: t_opt_a
115: REAL(r_std),DIMENSION(npft) :: t_opt_b
116: REAL(r_std),DIMENSION(npft) :: t_opt_c
117: REAL(r_std),DIMENSION(npft) :: t_min_a
118: REAL(r_std),DIMENSION(npft) :: t_min_b
119: REAL(r_std),DIMENSION(npft) :: t_min_c
120: END TYPE t_photo_type
121: !-
122: ! type declaration for phenology
123: TYPE pheno_type
124: REAL(r_std),DIMENSION(npft,3) :: gdd
125: REAL(r_std),DIMENSION(npft) :: ngd
126: REAL(r_std),DIMENSION(npft) :: ncdgdd_temp
127: REAL(r_std),DIMENSION(npft) :: hum_frac
128: REAL(r_std),DIMENSION(npft) :: lowgpp_time
129: REAL(r_std),DIMENSION(npft) :: leaffall
130: REAL(r_std),DIMENSION(npft) :: leafagecrit
131: REAL(r_std) :: tau_hum_month
132: REAL(r_std) :: tau_hum_week
133: REAL(r_std) :: tau_t2m_month
134: REAL(r_std) :: tau_t2m_week
135: REAL(r_std) :: tau_tsoil_month
136: REAL(r_std) :: tau_soilhum_month
137: REAL(r_std) :: tau_gpp_week
138: REAL(r_std) :: tau_gdd
139: REAL(r_std) :: tau_ngd
140: REAL(r_std) :: tau_longterm
141: REAL(r_std),DIMENSION(npft) :: lai_initmin
142: CHARACTER(len=6),DIMENSION(npft) :: pheno_model
143: CHARACTER(len=6),DIMENSION(npft) :: senescence_type
144: REAL(r_std),DIMENSION(npft,3) :: senescence_temp
145: REAL(r_std),DIMENSION(npft) :: senescence_hum
146: REAL(r_std),DIMENSION(npft) :: nosenescence_hum
147: REAL(r_std),DIMENSION(npft) :: max_turnover_time
148: REAL(r_std), DIMENSION(npft) :: min_leaf_age_for_senescence
149: REAL(r_std),DIMENSION(npft) :: min_turnover_time
150: !-
151: REAL(r_std),DIMENSION(npft) :: hum_min_time
152: END TYPE pheno_type
153: !-
154: ! parameters for the pipe model
155: !-
156: ! crown area = pipe_tune1. stem diameter**(1.6) (Reinicke's theory)
157: REAL(r_std),PARAMETER :: pipe_tune1 = 100.0
158: ! height=pipe_tune2 * diameter**pipe_tune3
159: REAL(r_std),PARAMETER :: pipe_tune2 = 40.0
160: REAL(r_std),PARAMETER :: pipe_tune3 = 0.5
161: ! needed for stem diameter
162: REAL(r_std),PARAMETER :: pipe_tune4 = 0.3
163: ! Density
164: REAL(r_std),PARAMETER :: pipe_density = 2.e5
165: ! one more parameter
166: REAL(r_std),PARAMETER :: pipe_k1 = 8.e3
167: !-
168: ! Maximum tree establishment rate
169: REAL(r_std),PARAMETER :: estab_max_tree = 0.12
170: ! Maximum grass establishment rate
171: REAL(r_std),PARAMETER :: estab_max_grass = 0.12
172: ! initial density of individuals
173: REAL(r_std),PARAMETER :: ind_0 = 0.02
174: !-
175: ! Do we treat PFT expansion across a grid point after introduction?
176: ! default = .FALSE.
177: LOGICAL,SAVE :: treat_expansion = .FALSE.
178: !-
179: ! herbivores?
180: LOGICAL,SAVE :: ok_herbivores = .FALSE.
181: !-
182: ! For trees, minimum fraction of crown area occupied
183: ! (due to its branches etc.)
184: ! This means that only a small fraction of its crown area
185: ! can be invaded by other trees.
186: REAL(r_std),PARAMETER :: min_cover = 0.05
187: !-
188: ! climatic parameters
189: !-
190: ! minimum precip, in mm/year
191: REAL(r_std),PARAMETER :: precip_crit = 100.
192: ! minimum gdd for establishment of saplings
193: REAL(r_std),PARAMETER :: gdd_crit = 150.
194: ! critical fpc, needed for light competition and establishment
195: REAL(r_std),PARAMETER :: fpc_crit = 0.95
196: !-
197: ! critical value for being adapted (1-1/e)
198: REAL(r_std),PARAMETER :: adapted_crit = 1. - ( 1. / euler )
199: ! critical value for being regenerative (1/e)
200: REAL(r_std),PARAMETER :: regenerate_crit = 1. / euler
201: !-
202: ! fraction of GPP which is lost as growth respiration
203: REAL(r_std),PARAMETER :: frac_growthresp = 0.28
204: !-
205: ! radius of the Earth (m)
206: REAL(r_std),PARAMETER :: R_Earth = 6378000.
207: !-
208: ! description of the PFT
209: CHARACTER(len=34),SAVE,DIMENSION(npft) :: PFT_name = &
210: & (/ 'tropical broad-leaved evergreen ', &
211: & 'tropical broad-leaved raingreen ', &
212: & 'temperate needleleaf evergreen ', &
213: & 'temperate broad-leaved evergreen ', &
214: & 'temperate broad-leaved summergreen', &
215: & 'boreal needleleaf evergreen ', &
216: & 'boreal broad-leaved summergreen', &
217: & 'boreal needleleaf summergreen', &
218: & ' C3 grass ', &
219: & ' C4 grass ', &
220: & ' C3 agriculture', &
221: & ' C4 agriculture' /)
222: ! extinction coefficient of the Monsi&Seaki (53) relationship
223: REAL(r_std),SAVE,DIMENSION(npft) :: ext_coeff
224: ! is pft a tree
225: LOGICAL,SAVE,DIMENSION(npft) :: tree
226: ! leaf type
227: ! 1=broad leaved tree, 2=needle leaved tree, 3=grass
228: INTEGER(i_std),SAVE,DIMENSION(npft) :: leaf_tab = &
229: & (/ 1, 1, 2, 1, 1, 2, &
230: & 1, 2, 3, 3, 3, 3 /)
231: ! natural?
232: LOGICAL,SAVE,DIMENSION(npft) :: natural = &
233: & (/ .TRUE., .TRUE., .TRUE., .TRUE., .TRUE., .TRUE., &
234: & .TRUE., .TRUE., .TRUE., .TRUE., .FALSE., .FALSE. /)
235: ! flamability: critical fraction of water holding capacity
236: REAL(r_std),SAVE,DIMENSION(npft) :: flam
237: ! fire resistance
238: REAL(r_std),SAVE,DIMENSION(npft) :: resist = &
239: & (/ .12, .50, .12, .50, .12, .12, &
240: & .12, .12, .0, .0, .0, .0 /)
241: ! specific leaf area (m**2/gC)
242: REAL(r_std),SAVE,DIMENSION(npft) :: sla
243: ! sapling biomass (gC/ind)
244: REAL(r_std),SAVE,DIMENSION(npft,nparts) :: bm_sapl
245: ! migration speed (m/year)
246: REAL(r_std),SAVE,DIMENSION(npft) :: migrate
247: ! maximum stem diameter from which on crown area no longer increases (m)
248: REAL(r_std),SAVE,DIMENSION(npft) :: maxdia
249: ! critical minimum temperature (K)
250: REAL(r_std),SAVE,DIMENSION(npft) :: tmin_crit
251: ! critical temperature of the coldest month (K)
252: REAL(r_std),SAVE,DIMENSION(npft) :: tcm_crit
253: ! critical values for phenology
254: TYPE(pheno_type),SAVE :: pheno_crit
255: ! time constant for leaf age discretisation (d)
256: REAL(r_std),SAVE,DIMENSION(npft) :: leaf_timecst
257: ! maximum LAI, PFT-specific
258: REAL(r_std),SAVE,DIMENSION (npft) :: lai_max = &
259: & (/ 7., 7., 5., 5., 5., 4.5, &
260: & 4.5, 3.0, 2.5, 2.5, 5., 5. /)
261: ! maintenance respiration coefficient (g/g/day) at 0 deg C
262: REAL(r_std),SAVE,DIMENSION(npft,nparts) :: coeff_maint_zero
263: ! slope of maintenance respiration coefficient (1/K, 1/K^2, 1/K^3)
264: REAL(r_std),SAVE,DIMENSION(npft,3) :: maint_resp_slope
265: ! residence time (y) of trees
266: REAL(r_std),SAVE,DIMENSION(npft) :: residence_time = &
267: & (/ 30.0, 30.0, 40.0, 40.0, 40.0, 80.0, &
268: & 80.0, 80.0, 0.0, 0.0, 0.0, 0.0 /)
269: !SZ modifications
270: ! leaf lifetime, tabulated
271: REAL(r_std),SAVE,DIMENSION(npft) :: leaflife_tab = &
272: & (/ .5, 2., .33, 1., 2., .33, &
273: & 2., 2., 2., 2., 2., 2. /)
274: ! OLD HEAD
275: !!$ & (/ .5, 1., .5, .5, 1., .5, &
276: !!$ & 1., 1., 1., 1., 1., 1. /)
277: ! type of phenology
278: ! 1=evergreen, 2=summergreen, 3=raingreen, 4=perennial
279: INTEGER(i_std),SAVE,DIMENSION(npft) :: pheno_type_tab = &
280: & (/ 1, 3, 1, 1, 2, 1, &
281: & 2, 2, 4, 4, 2, 3 /)
282: ! critical tmin, tabulated (C)
283: REAL(r_std),SAVE,DIMENSION(npft) :: tmin_crit_tab = &
284: & (/ 0.0, 0.0, -45.0, -10.0, -45.0, -60.0, &
285: & -60.0, undef, undef, undef, undef, undef /)
286: ! critical tcm, tabulated (C)
287: REAL(r_std),SAVE,DIMENSION(npft) :: tcm_crit_tab = &
288: & (/ undef, undef, 5.0, 15.5, 15.5, -2.0, &
289: & 5.0, -2.0, undef, undef, undef, undef /)
290: ! critical gdd, tabulated (C), constant c of aT^2+bT+c
291: REAL(r_std),SAVE,DIMENSION(npft) :: gdd_crit1_tab = &
292: & (/ undef, undef, undef, undef, undef, undef, &
293: & undef, undef, 184.375, 400., 125., 400. /)
294: ! critical gdd, tabulated (C), constant b of aT^2+bT+c
295: REAL(r_std),SAVE,DIMENSION(npft) :: gdd_crit2_tab = &
296: & (/ undef, undef, undef, undef, undef, undef, &
297: & undef, undef, 6.25, 0., 0., 0. /)
298: ! critical gdd, tabulated (C), constant a of aT^2+bT+c
299: REAL(r_std),SAVE,DIMENSION(npft) :: gdd_crit3_tab = &
300: & (/ undef, undef, undef, undef, undef, undef, &
301: & undef, undef, 0.03125, 0., 0., 0. /)
302: ! critical ngd, tabulated. Threshold -5 degrees
303: REAL(r_std),SAVE,DIMENSION(npft) :: ngd_crit_tab = &
304: & (/ undef, undef, undef, undef, undef, undef, &
305: & undef, 17., undef, undef, undef, undef /)
306: ! critical temperature for the ncd vs. gdd function in phenology
307: REAL(r_std),SAVE,DIMENSION(npft) :: ncdgdd_temp_tab = &
308: & (/ undef, undef, undef, undef, 5., undef, &
309: & 0., undef, undef, undef, undef, undef /)
310: ! critical humidity (relative to min/max) for phenology
311: REAL(r_std),SAVE,DIMENSION(npft) :: hum_frac_tab
312: ! minimum duration of dormance (d) for phenology
313: REAL(r_std),SAVE,DIMENSION(npft) :: lowgpp_time_tab
314: ! minimum time elapsed since moisture minimum (d)
315: REAL(r_std),SAVE,DIMENSION(npft) :: hum_min_time_tab
316: ! sapwood -> heartwood conversion time (d)
317: REAL(r_std),SAVE,DIMENSION(npft) :: tau_sap
318: ! fruit lifetime (d)
319: REAL(r_std),SAVE,DIMENSION(npft) :: tau_fruit
320: ! fraction of primary leaf and root allocation put into reserve
321: REAL(r_std),SAVE,DIMENSION(npft) :: ecureuil
322: ! Maximum rate of carboxylation
323: REAL(r_std),SAVE,DIMENSION(npft) :: vcmax_opt
324: ! Maximum rate of RUbp regeneration
325: REAL(r_std),SAVE,DIMENSION(npft) :: vjmax_opt
326: ! constants needed for photosynthesis temperatures
327: TYPE(t_photo_type),SAVE :: t_photo
328: ! lenth of death of leaves, tabulated (d)
329: REAL(r_std),SAVE,DIMENSION(npft) :: leaffall_tab
330: ! critical leaf age, tabulated (d)
331: REAL(r_std),SAVE,DIMENSION(npft) :: leafagecrit_tab
332: ! which phenology model is used? (tabulated)
333: CHARACTER(len=6),SAVE,DIMENSION(npft) :: pheno_model_tab
334: ! type of senescence, tabulated
335: CHARACTER(len=6),SAVE,DIMENSION(npft) :: senescence_type_tab
336: ! critical temperature for senescence (C),
337: ! constant c of aT^2+bT+c , tabulated
338: REAL(r_std),SAVE,DIMENSION(npft) :: senescence_temp1_tab
339: ! critical temperature for senescence (C),
340: ! constant b of aT^2+bT+c , tabulated
341: REAL(r_std),SAVE,DIMENSION(npft) :: senescence_temp2_tab
342: ! critical temperature for senescence (C),
343: ! constant a of aT^2+bT+c , tabulated
344: REAL(r_std),SAVE,DIMENSION(npft) :: senescence_temp3_tab
345: ! critical relative moisture availability for senescence
346: REAL(r_std),SAVE,DIMENSION(npft) :: senescence_hum_tab
347: ! relative moisture availability above which
348: ! there is no humidity-related senescence
349: REAL(r_std),SAVE,DIMENSION(npft) :: nosenescence_hum_tab
350: ! maximum turnover time for grasse
351: REAL(r_std),SAVE,DIMENSION(npft) :: max_turnover_time_tab
352: ! minimum turnover time for grasse
353: REAL(r_std),SAVE,DIMENSION(npft) :: min_turnover_time_tab
354: ! minimum leaf age to allow senescence g
355: REAL(r_std), SAVE, DIMENSION(npft) :: min_leaf_age_for_senescence_tab
356: !-
357: ! slope of maintenance respiration coefficient (1/K),
358: ! constant c of aT^2+bT+c , tabulated
359: REAL(r_std),SAVE,DIMENSION(npft) :: maint_resp_slope1_tab
360: ! slope of maintenance respiration coefficient (1/K),
361: ! constant b of aT^2+bT+c , tabulated
362: REAL(r_std),SAVE,DIMENSION(npft) :: maint_resp_slope2_tab
363: ! slope of maintenance respiration coefficient (1/K),
364: ! constant a of aT^2+bT+c , tabulated
365: REAL(r_std),SAVE,DIMENSION(npft) :: maint_resp_slope3_tab
366: ! maintenance respiration coefficient (g/g/day) at 0 deg C,
367: ! for leaves, tabulated
368: REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_leaf_tab
369: ! maintenance respiration coefficient (g/g/day) at 0 deg C,
370: ! for sapwood above, tabulated
371: REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_sapabove_tab
372: ! maintenance respiration coefficient (g/g/day) at 0 deg C,
373: ! for sapwood below, tabulated
374: REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_sapbelow_tab
375: ! maintenance respiration coefficient (g/g/day) at 0 deg C,
376: ! for heartwood above, tabulated
377: REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_heartabove_tab
378: ! maintenance respiration coefficient (g/g/day) at 0 deg C,
379: ! for heartwood below, tabulated
380: REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_heartbelow_tab
381: ! maintenance respiration coefficient (g/g/day) at 0 deg C,
382: ! for roots, tabulated
383: REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_root_tab
384: ! maintenance respiration coefficient (g/g/day) at 0 deg C,
385: ! for fruits, tabulated
386: REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_fruit_tab
387: ! maintenance respiration coefficient (g/g/day) at 0 deg C,
388: ! for carbohydrate reserve, tabulated
389: REAL(r_std),SAVE,DIMENSION(npft) :: cm_zero_carbres_tab
390: ! minimum photosynthesis temperature,
391: ! constant a of ax^2+bx+c (deg C), tabulated
392: REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_min_a_tab
393: ! minimum photosynthesis temperature,
394: ! constant b of ax^2+bx+c (deg C), tabulated
395: REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_min_b_tab
396: ! minimum photosynthesis temperature,
397: ! constant c of ax^2+bx+c (deg C), tabulated
398: REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_min_c_tab
399: ! optimum photosynthesis temperature,
400: ! constant a of ax^2+bx+c (deg C), tabulated
401: REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_opt_a_tab
402: ! optimum photosynthesis temperature,
403: ! constant b of ax^2+bx+c (deg C), tabulated
404: REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_opt_b_tab
405: ! optimum photosynthesis temperature,
406: ! constant c of ax^2+bx+c (deg C), tabulated
407: REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_opt_c_tab
408: ! maximum photosynthesis temperature,
409: ! constant a of ax^2+bx+c (deg C), tabulated
410: REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_max_a_tab
411: ! maximum photosynthesis temperature,
412: ! constant b of ax^2+bx+c (deg C), tabulated
413: REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_max_b_tab
414: ! maximum photosynthesis temperature,
415: ! constant c of ax^2+bx+c (deg C), tabulated
416: REAL(r_std),SAVE,DIMENSION(npft) :: tphoto_max_c_tab
417: !-
418: ! tables
419: !-
420: !-
421: DATA flam / .25, .25, .25, .25, .25, .25, &
422: .25, .25, .30, .30, .35, .35 /
423: ! DATA flam / .15, .15, .15, .15, .15, .15, &
424: ! .15, .15, .15, .15, .15, .15 /
425: !-
426: DATA hum_frac_tab / undef, .5, undef, undef, undef, undef, &
427: undef, undef, .5, .5, .5, .5 /
428: !-
429: DATA lowgpp_time_tab / undef, 30., undef, undef, 30., undef, &
430: 30., 30., 30., 30., 30., 30. /
431: !-
432: DATA hum_min_time_tab / undef, 50., undef, undef, undef, undef, &
433: undef, undef, 35., 35., 75., 75. /
434: !-
435: DATA tau_sap / 730., 730., 730., 730., 730., 730., &
436: 730., 730., undef, undef, undef, undef /
437: !-
438: DATA tau_fruit / 90., 90., 90., 90., 90., 90., &
439: 90., 90., undef, undef, undef, undef /
440: !-
441: DATA ecureuil / .0, 1., .0, .0, 1., .0, &
442: 1., 1., 1., 1., 1., 1. /
443: !-
444: ! Shilong modification
445: DATA vcmax_opt / 65., 65., 35., 40., 55., 35., &
446: 45., 35., 70., 70., 70., 70. /
447: ! OLD HEAD
448: !!$ / 65., 65., 35., 40., 55., 35., &
449: !!$ 45., 35., 80., 80., 100., 100. /
450: !modif jerome carbofor
451: ! DATA vcmax_opt / 65., 65., 50., 40., 75., 35., &
452: ! 45., 35., 80., 80., 100., 100. /
453:
454: DATA vjmax_opt / 130., 130., 70., 80., 110., 70., &
455: 90., 70., 160., 160., 200., 200. /
456: !-
457: !DATA vcmax_opt_tab / 65., 65., 37.5, 45., 60., 37.5, &
458: ! 50., 40., 100., 100., 100., 100. /
459:
460: !DATA vjmax_opt_tab / 130., 130., 75., 90., 120., 75., &
461: ! 100., 80., 200., 200., 200., 200. /
462: !-
463: DATA leaffall_tab / undef, 10., undef, undef, 10., undef, &
464: 10., 10., 10., 10., 10., 10. /
465: !-
466: ! Shilong modification
467: DATA leafagecrit_tab / 730., 180., 910., 730., 180., 910., &
468: 180., 180., 120., 120., 90., 90. /
469: ! OLD HEAD
470: !!$ DATA leafagecrit_tab / 730., 180., 910., 730., 180., 910., &
471: !!$ 180., 180., 120., 120., 120., 120. /
472: !-
473: DATA ipft_sechiba / 2, 3, 4, 5, 6, 7, &
474: 8, 9, 10, 11, 12, 13 /
475: !-
476: DATA senescence_type_tab / 'none', 'dry', 'none', 'none', 'cold', 'none', &
477: 'cold', 'cold', 'mixed', 'mixed', 'mixed', 'mixed' /
478: !-
479: DATA senescence_temp1_tab / undef, undef, undef, undef, 12., undef, &
480: 7., 2., -1.375, 5., 5., 10. /
481: DATA senescence_temp2_tab / undef, undef, undef, undef, 0., undef, &
482: 0., 0., .1, 0., 0., 0. /
483: DATA senescence_temp3_tab / undef, undef, undef, undef, 0., undef, &
484: 0., 0., .00375, 0., 0., 0. /
485: !-
486: DATA senescence_hum_tab / undef, .6, undef, undef, undef, undef, &
487: undef, undef, .2, .2, .3, .2 /
488: !-
489: DATA nosenescence_hum_tab / undef, 1., undef, undef, undef, undef, &
490: undef, undef, .3, .3, .3, .3 /
491: !-
492: DATA max_turnover_time_tab / undef, undef, undef, undef, undef, undef, &
493: undef, undef, 80., 80., 80., 80. /
494: !-
495: DATA min_turnover_time_tab / undef, undef, undef, undef, undef, undef, &
496: undef, undef, 10., 10., 10., 10. /
497: !-
498: DATA min_leaf_age_for_senescence_tab / undef, 90, undef, undef, 90, undef, &
499: 60, 60, 30., 30., 30., 30. /
500: !-
501: DATA pheno_model_tab / 'none', 'moi', 'none', 'none','ncdgdd', 'none', &
502: 'ncdgdd', 'ngd','moigdd','moigdd','moigdd','moigdd' /
503: !-
504: ! DATA maint_resp_slope1_tab / .16, .16, .16, .16, .16, .16, &
505: ! .16, .16, .16, .16, .16, .16 /
506: ! DATA maint_resp_slope2_tab / .0, .0, .0, .0, .0, .0, &
507: ! .0, .0, .0, .0, .0, .0 /
508: DATA maint_resp_slope1_tab / .12, .12, .16, .16, .16, .16, &
509: .16, .16, .16, .12, .16, .12 /
510: DATA maint_resp_slope2_tab / .0, .0, .0, .0, .0, .0, &
511: .0, .0, -.00133, .0, -.00133, .0 /
512: DATA maint_resp_slope3_tab / .0, .0, .0, .0, .0, .0, &
513: .0, .0, .0, .0, .0, .0 /
514: !-
515: DATA cm_zero_leaf_tab / 2.35E-3, 2.62E-3, 1.01E-3, 2.35E-3, 2.62E-3, 1.01E-3, &
516: 2.62E-3, 2.05E-3, 2.62E-3, 2.62E-3, 2.62E-3, 2.62E-3 /
517: !-
518: DATA cm_zero_sapabove_tab / 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, &
519: 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4 /
520: !-
521: DATA cm_zero_sapbelow_tab / 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, &
522: 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4 /
523: !-
524: DATA cm_zero_heartabove_tab / 0., 0., 0., 0., 0., 0., &
525: 0., 0., 0., 0., 0., 0. /
526: !-
527: DATA cm_zero_heartbelow_tab / 0., 0., 0., 0., 0., 0., &
528: 0., 0., 0., 0., 0., 0. /
529: !-
530: DATA cm_zero_root_tab / 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, &
531: 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3 /
532: !-
533: DATA cm_zero_fruit_tab / 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, &
534: 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4 /
535: !-
536: DATA cm_zero_carbres_tab / 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, &
537: 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4 /
538: !-
539: DATA tphoto_min_c_tab / 2., 2., -4., -3., -2., -4., &
540: -4., -4., -3.25, 13., -5., 13. /
541: DATA tphoto_min_b_tab / 0., 0., 0., 0., 0., 0., &
542: 0., 0., 0.1, 0., 0., 0. /
543: DATA tphoto_min_a_tab / 0., 0., 0., 0., 0., 0., &
544: 0., 0., 0.0025, 0., 0., 0. /
545: DATA tphoto_opt_c_tab / 37., 37., 25., 32., 26., 25., &
546: 25., 25., 27.25, 36., 30., 36. /
547: DATA tphoto_opt_b_tab / 0., 0., 0., 0., 0., 0., &
548: 0., 0., 0.25, 0., 0., 0. /
549: DATA tphoto_opt_a_tab / 0., 0., 0., 0., 0., 0., &
550: 0., 0., 0.0025, 0., 0., 0. /
551: DATA tphoto_max_c_tab / 55., 55., 38., 48., 38., 38., &
552: 38., 38., 41.125, 55., 45., 55. /
553: DATA tphoto_max_b_tab / 0., 0., 0., 0., 0., 0., &
554: 0., 0., 0.35, 0., 0., 0. /
555: DATA tphoto_max_a_tab / 0., 0., 0., 0., 0., 0., &
556: 0., 0., 0.00375, 0., 0., 0. /
557: !---------------------------
558: END MODULE stomate_constants
ORCHIDEE/src_stomate/i.stomate_natagritot.L 0000754 0103600 0005670 00000012252 11164403473 020526 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:44 2008
FILE NAME: i.stomate_natagritot.f90
PROGRAM NAME: stomate_natagritot
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
57 vec ( 3): Unvectorized loop.
57 vec ( 13): Overhead of loop division is too large.
61 opt (1082): Backward transfers inhibit loop optimization.
61 vec ( 4): Vectorized array expression.
69 opt (1082): Backward transfers inhibit loop optimization.
69 vec ( 4): Vectorized array expression.
85 vec ( 3): Unvectorized loop.
85 vec ( 13): Overhead of loop division is too large.
89 vec ( 4): Vectorized array expression.
93 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:44 2008
FILE NAME: i.stomate_natagritot.f90
PROGRAM NAME: stomate_natagritot
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! Transform from (X per m**2 of total ground) to (X per m**2 of nat/agri ground)
2: ! and inverse operation
3: !
4: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_natagritot.f90,v 1.6 2007/05/28 14:49:02 ssipsl Exp $
5: ! IPSL (2006)
6: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
7: !
8: MODULE stomate_natagritot
9:
10: ! modules used:
11:
12: USE ioipsl
13: USE stomate_constants
14:
15: IMPLICIT NONE
16:
17: ! private & public routines
18:
19: PRIVATE
20: PUBLIC natagritot
21:
22: CONTAINS
23:
24: SUBROUTINE natagritot (npts, direction, space_nat, field)
25:
26: !
27: ! 0 declarations
28: !
29:
30: ! 0.1 input
31:
32: ! Domain size
33: INTEGER(i_std), INTENT(in) :: npts
34: ! total -> nat/agri or nat/agri -> total ?
35: INTEGER(i_std), INTENT(in) :: direction
36: ! total natural space
37: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
38:
39: ! 0.2 modified 2-dimensional field
40:
41: ! characteristic to be transformed
42: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: field
43:
44: ! 0.3 local
45:
46: ! index
47: INTEGER(i_std) :: j
48:
49: ! =========================================================================
50:
51: IF ( direction .EQ. ito_natagri ) THEN
52:
53: !
54: ! 1 Transform from (X per m**2 of total ground) to (X per m**2 of nat/agri ground)
55: !
56:
57: +------> DO j = 1, npft
58: |
59: | IF ( natural(j) ) THEN
60: |
61: |V-----> WHERE ( space_nat(:) .GT. 0.0 )
62: || field(:,j) = field(:,j) / space_nat(:)
63: || ELSEWHERE
64: |V----- field(:,j) = 0.0
65: | ENDWHERE
66: |
67: | ELSE
68: |
69: |V-----> WHERE ( space_nat(:) .LT. 1.0 )
70: || field(:,j) = field(:,j) / ( 1. - space_nat(:) )
71: || ELSEWHERE
72: |V----- field(:,j) = 0.0
73: | ENDWHERE
74: |
75: | ENDIF
76: |
77: +------ ENDDO
78:
79: ELSEIF ( direction .EQ. ito_total ) THEN
80:
81: !
82: ! 2 Transform from (X per m**2 of nat/agri ground) to (X per m**2 of total ground)
83: !
84:
85: +------> DO j = 1, npft
86: |
87: | IF ( natural(j) ) THEN
88: |
89: |V===== field(:,j) = field(:,j) * space_nat(:)
90: |
91: | ELSE
92: |
93: |V===== field(:,j) = field(:,j) * ( 1. - space_nat(:) )
94: |
95: | ENDIF
96: |
97: +------ ENDDO
98:
99:
100: ELSE
101:
102: STOP 'natagritot: wrong direction'
103:
104: ENDIF
105:
106: END SUBROUTINE natagritot
107:
108: END MODULE stomate_natagritot
ORCHIDEE/src_stomate/i.lpj_constraints.L 0000754 0103600 0005670 00000024352 11164403473 020036 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:45 2008
FILE NAME: i.lpj_constraints.f90
PROGRAM NAME: lpj_constraints
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
109 vec ( 3): Unvectorized loop.
109 vec ( 13): Overhead of loop division is too large.
124 vec ( 4): Vectorized array expression.
130 vec ( 4): Vectorized array expression.
137 vec ( 4): Vectorized array expression.
146 vec ( 18): Unvectorizable data type.
148 vec ( 4): Vectorized array expression.
162 vec ( 4): Vectorized array expression.
168 vec ( 4): Vectorized array expression.
175 vec ( 4): Vectorized array expression.
182 vec ( 4): Vectorized array expression.
192 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:45 2008
FILE NAME: i.lpj_constraints.f90
PROGRAM NAME: lpj_constraints
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! determine whether a PFT is adapted and can regenerate
2: !
3: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_constraints.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
4: ! IPSL (2006)
5: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
6: !
7: MODULE lpj_constraints
8:
9: ! modules used:
10:
11: USE ioipsl
12: USE stomate_constants
13:
14: IMPLICIT NONE
15:
16: ! private & public routines
17:
18: PRIVATE
19: PUBLIC constraints,constraints_clear
20:
21: ! first call
22: LOGICAL, SAVE :: firstcall = .TRUE.
23: CONTAINS
24:
25:
26: SUBROUTINE constraints_clear
27: firstcall = .TRUE.
28: END SUBROUTINE constraints_clear
29:
30: SUBROUTINE constraints (npts, dt, &
31: t2m_month, t2m_min_daily, when_growthinit, &
32: adapted, regenerate)
33:
34: !
35: ! 0 declarations
36: !
37:
38: ! 0.1 input
39:
40: ! Domain size
41: INTEGER(i_std), INTENT(in) :: npts
42: ! time step (in days)
43: REAL(r_std), INTENT(in) :: dt
44: ! "monthly" 2-meter temperature (K)
45: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
46: ! Daily minimum 2-meter temperature (K)
47: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_min_daily
48: ! how many days ago was the beginning of the growing season
49: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: when_growthinit
50:
51: ! 0.2 output fields
52:
53: ! Winter too cold? between 0 and 1
54: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: adapted
55: ! Winter sufficiently cold? between 0 and 1
56: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: regenerate
57:
58: ! 0.3 local
59:
60: ! Memory length for adaption (d)
61: REAL(r_std) :: tau_adapt
62: ! Memory length for regeneration (d)
63: REAL(r_std) :: tau_regenerate
64: ! longest sustainable time without regeneration (vernalization)
65: REAL(r_std), PARAMETER :: too_long = 5.
66: ! critical value of "regenerate" below which plant dies
67: REAL(r_std) :: regenerate_min
68: ! index
69: INTEGER(i_std) :: j
70:
71: ! =========================================================================
72:
73: IF (bavard.GE.3) WRITE(numout,*) 'Entering constraints'
74:
75: !
76: ! 1 Initializations
77: !
78: tau_adapt = one_year
79: tau_regenerate = one_year
80: !
81: ! 1.1 Messages
82: !
83:
84: IF ( firstcall ) THEN
85:
86: WRITE(numout,*) 'constraints:'
87:
88: WRITE(numout,*) ' > Memory length for adaption (d): ',tau_adapt
89: WRITE(numout,*) ' > Memory length for regeneration (d): ',tau_regenerate
90: WRITE(numout,*) ' > Longest sustainable time without vernalization (y):', too_long
91: WRITE(numout,*) ' > For trees, longest sustainable time without growth init (y):', &
92: too_long
93:
94: firstcall = .FALSE.
95:
96: ENDIF
97:
98: !
99: ! 1.2 critical value for "regenerate": below this value, the last vernalization
100: ! belong to a too distant past. PFT is then not adapted.
101: !
102:
103: regenerate_min = exp ( - too_long * one_year / tau_regenerate )
104:
105: !
106: ! 2 Loop over all PFTs
107: !
108:
109: +------> DO j = 1, npft
110: |
111: | IF ( natural(j) .OR. agriculture ) THEN
112: |
113: | !
114: | ! 2.1 climate criteria
115: | !
116: |
117: | ! 2.1.1 Test if PFT is adapted: check daily temperature.
118: | ! If too cold, PFT is not adapted.
119: |
120: | IF ( tmin_crit(j) .EQ. undef ) THEN
121: |
122: | ! 2.1.1.1 some PFTs always survive.
123: |
124: |V===== adapted(:,j) = 1.
125: |
126: | ELSE
127: |
128: | ! 2.1.1.2 frost-sensitive PFTs
129: |
130: |V-----> WHERE ( t2m_min_daily(:) .LT. tmin_crit(j) )
131: |V----- adapted(:,j) = 0.
132: | ENDWHERE
133: |
134: | ! limited memory: after some time, the cold shock is forgotten.
135: | ! ( adapted will approach 1)
136: |
137: |V===== adapted(:,j) = 1. - ( 1. - adapted(:,j) ) * (tau_adapt- dt)/tau_adapt
138: |
139: | ENDIF
140: |
141: | !
142: | ! 2.1.2 seasonal trees die if leafage does not show a clear seasonality.
143: | ! (i.e. if the start of the growing season is never detected).
144: | !
145: |
146: | IF ( tree(j) .AND. ( pheno_crit%pheno_model(j) .NE. 'none' ) ) THEN
147: |
148: |V-----> WHERE ( when_growthinit(:,j) .GT. too_long*one_year )
149: |V----- adapted(:,j) = 0.
150: | ENDWHERE
151: |
152: | ENDIF
153: |
154: | ! 2.1.3 Test if PFT is regenerative
155: | ! check monthly temperature. If sufficiently cold, PFT will be able to
156: | ! regenerate for some time.
157: |
158: | IF ( tcm_crit(j) .EQ. undef ) THEN
159: |
160: | ! 2.1.3.1 several PFTs (ex: evergreen) don't need vernalization
161: |
162: |V===== regenerate(:,j) = 1.
163: |
164: | ELSE
165: |
166: | ! 2.1.3.2 PFT needs vernaliztion
167: |
168: |V-----> WHERE ( t2m_month(:) .LE. tcm_crit(j) )
169: |V----- regenerate(:,j) = 1.
170: | ENDWHERE
171: |
172: | ! limited memory: after some time, the winter is forgotten.
173: | ! (regenerate will approach 0)
174: |
175: |V===== regenerate(:,j) = regenerate(:,j) * (tau_regenerate-dt)/tau_regenerate
176: |
177: | ENDIF
178: |
179: | ! 2.1.4 Plants that need vernalization die after a few years if they don't
180: | ! vernalize (even if they would not loose their leaves).
181: |
182: |V-----> WHERE ( regenerate(:,j) .LE. regenerate_min )
183: |V----- adapted(:,j) = 0.
184: | ENDWHERE
185: |
186: | ELSE
187: |
188: | !
189: | ! 2.2 PFT is not natural and agriculture is not allowed -> remove
190: | !
191: |
192: |V-----> adapted(:,j) = 0.
193: ||
194: |V----- regenerate(:,j) = 0.
195: |
196: | ENDIF
197: |
198: +------ ENDDO
199:
200: IF (bavard.GE.4) WRITE(numout,*) 'Leaving constraints'
201:
202: END SUBROUTINE constraints
203:
204: END MODULE lpj_constraints
ORCHIDEE/src_stomate/i.lpj_cover.L 0000754 0103600 0005670 00000011512 11164403473 016577 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:45 2008
FILE NAME: i.lpj_cover.f90
PROGRAM NAME: lpj_cover
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
68 vec ( 3): Unvectorized loop.
68 vec ( 13): Overhead of loop division is too large.
72 vec ( 4): Vectorized array expression.
91 vec ( 3): Unvectorized loop.
92 opt (1592): Outer loop unrolled inside inner loop.
92 vec ( 4): Vectorized array expression.
95 warn ( 83): Dummy argument "biomass" is not used.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:45 2008
FILE NAME: i.lpj_cover.f90
PROGRAM NAME: lpj_cover
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! recalculate vegetation cover and LAI
2: !
3: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_cover.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
4: ! IPSL (2006)
5: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
6: !
7: MODULE lpj_cover
8:
9: ! modules used:
10:
11: USE ioipsl
12: USE stomate_constants
13:
14: IMPLICIT NONE
15:
16: ! private & public routines
17:
18: PRIVATE
19: PUBLIC cover
20:
21: CONTAINS
22:
23: SUBROUTINE cover (npts, cn_ind, ind, biomass, &
24: veget_max, veget, lai)
25:
26: !
27: ! 0 declarations
28: !
29:
30: ! 0.1 input
31:
32: ! Domain size
33: INTEGER(i_std), INTENT(in) :: npts
34: ! crown area (m**2) per ind.
35: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: cn_ind
36: ! density of individuals (1/(m**2 of nat/agri ground))
37: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ind
38: ! biomass (gC/(m**2 of nat/agri ground))
39: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: biomass
40:
41: ! 0.2 modified fields
42:
43: ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
44: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
45:
46: ! 0.3 output
47:
48: ! fractional coverage on natural/agricultural ground, taking into
49: ! account LAI (=grid-scale fpc)
50: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
51: ! leaf area index OF AN INDIVIDUAL PLANT
52: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
53:
54: ! 0.4 local
55:
56: ! index
57: INTEGER(i_std) :: j
58:
59: ! =========================================================================
60:
61: !
62: ! 1 If the vegetation is dynamic, calculate new maximum vegetation cover for
63: ! natural plants
64: !
65:
66: IF ( control%ok_dgvm ) THEN
67:
68: +------> DO j = 1, npft
69: |
70: | IF ( natural(j) ) THEN
71: |
72: |V===== veget_max(:,j) = ind(:,j) * cn_ind(:,j)
73: |
74: | ENDIF
75: |
76: +------ ENDDO
77:
78: ENDIF
79:
80: !
81: ! 2 Calculate LAI
82: ! The LAI is defined on the space covered by the crown of the plant.
83: ! ( biomass / veget_max ) is in gC/(m**2 covered by the crown)
84: !
85:
86:
87: !
88: ! 3 calculate grid-scale fpc (foliage protected cover)
89: !
90:
91: +------> DO j = 1, npft
92: |V===== veget(:,j) = veget_max(:,j) * ( 1. - exp( - lai(:,j) * ext_coeff(j) ) )
93: +------ ENDDO
94:
95: END SUBROUTINE cover
96:
97: END MODULE lpj_cover
ORCHIDEE/src_stomate/i.lpj_crown.L 0000754 0103600 0005670 00000016033 11164403473 016614 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:46 2008
FILE NAME: i.lpj_crown.f90
PROGRAM NAME: lpj_crown
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
83 opt (1593): Loop nest collapsed into one loop.
83 vec ( 4): Vectorized array expression.
85 vec ( 4): Vectorized array expression.
89 vec ( 3): Unvectorized loop.
98 vec ( 4): Vectorized array expression.
106 vec ( 4): Vectorized array expression.
112 vec ( 4): Vectorized array expression.
122 vec ( 4): Vectorized array expression.
132 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:46 2008
FILE NAME: i.lpj_crown.f90
PROGRAM NAME: lpj_crown
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_crown.f90,v 1.11 2007/05/28 14:49:02 ssipsl Exp $
2: ! IPSL (2006)
3: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
4: !-
5: MODULE lpj_crown
6: !---------------------------------------------------------------------
7: !- calculate individual crown area from stem mass.
8: !---------------------------------------------------------------------
9: USE ioipsl
10: USE stomate_constants
11: USE constantes_veg
12: !-
13: IMPLICIT NONE
14: !-
15: ! private & public routines
16: !-
17: PRIVATE
18: PUBLIC crown
19: !-
20: CONTAINS
21: !-
22: !===
23: !-
24: SUBROUTINE crown &
25: & (npts, PFTpresent, ind, biomass, veget_max, cn_ind, height)
26: !---------------------------------------------------------------------
27: ! 0 declarations
28: !-
29: ! 0.1 input
30: !-
31: ! Domain size
32: INTEGER(i_std),INTENT(in) :: npts
33: ! Is pft there
34: LOGICAL,DIMENSION(npts,npft),INTENT(in) :: PFTpresent
35: ! density of individuals (1/(m**2 of nat/agri ground))
36: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: ind
37: ! biomass (gC/(m**2 of nat/agri ground))
38: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: biomass
39: !-
40: ! 0.2 modified fields
41: !-
42: ! "maximal" coverage fraction of a PFT (LAI -> infinity)
43: ! on nat/agri ground
44: !-
45: REAL(r_std),DIMENSION(npts,npft),INTENT(inout) :: veget_max
46: !-
47: ! 0.3 output
48: !-
49: ! crown area (m**2) per ind.
50: !-
51: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: cn_ind
52: !-
53: ! height of vegetation (m)
54: !-
55: REAL(r_std),DIMENSION(npts,npft),INTENT(inout) :: height
56: !-
57: ! 0.4 local
58: !-
59: ! wood mass of an individual
60: !-
61: REAL(r_std),DIMENSION(npts) :: woodmass
62: !-
63: ! index
64: !-
65: INTEGER(i_std) :: j
66: !-
67: ! stem diameter
68: !-
69: REAL(r_std),DIMENSION(npts) :: dia
70: REAL(r_std),DIMENSION(npft) :: height_presc_12
71: !---------------------------------------------------------------------
72: !-
73: ! 1 initializations
74: !-
75: ! 1.1 check if DGVM activated
76: !-
77: IF (.NOT.control%ok_dgvm) THEN
78: STOP 'crown: not to be called with static vegetation.'
79: ENDIF
80: !-
81: ! 1.2 initialize output to zero
82: !-
83: W+===== cn_ind(:,:) = 0.0
84: ! convert prescribed height from sechiba (nvm) to stomate (npft)
85: V====== height_presc_12(1:npft) = height_presc(2:nvm)
86: !-
87: ! 2 calculate (or prescribe) crown area
88: !-
89: +------> DO j = 1,npft
90: | IF (tree(j)) THEN
91: | !-----
92: | !---- 2.1 trees
93: | !-----
94: | IF (natural(j)) THEN
95: | !------ 2.1.1 natural
96: | WHERE (PFTpresent(:,j))
97: | !-------- 2.1.1.1 calculate individual wood mass
98: |V-----> woodmass(:) = &
99: || & (biomass(:,j,isapabove)+biomass(:,j,isapbelow) &
100: || & +biomass(:,j,iheartabove)+biomass(:,j,iheartbelow))/ind(:,j)
101: || !-------- 2.1.1.2 stem diameter (pipe model)
102: || dia(:) = (woodmass(:)/(pipe_density*pi/4.*pipe_tune2)) &
103: || & **(1./(2.+pipe_tune3))
104: || !-------- 2.1.1.3 height
105: |V----- height(:,j) = pipe_tune2*(dia(:)**pipe_tune3)
106: |V-----> WHERE (height(:,j) > height_presc_12(j))
107: || dia(:) = (height_presc_12(j)/pipe_tune2)**(1./pipe_tune3)
108: |V----- height(:,j) = height_presc_12(j)
109: | ENDWHERE
110: | !-------- 2.1.1.4 crown area: for large truncs, crown area cannot
111: | !-------- exceed a certain value, prescribed through maxdia.
112: |V===== cn_ind(:,j) = pipe_tune1*MIN(dia(:),maxdia(j))**1.6
113: | ENDWHERE
114: | ELSE
115: | !------ 2.1.2 tree is agricultural - stop
116: | STOP 'crown: cannot treat agricultural trees.'
117: | ENDIF
118: | ELSE
119: | !-----
120: | !---- 2.2 grasses
121: | !-----
122: |V-----> WHERE (PFTpresent(:,j))
123: || !------ 2.2.1 an "individual" is 1 m**2 of grass
124: |V----- cn_ind(:,j) = 1.
125: | ENDWHERE
126: | ENDIF
127: | !---
128: | !-- 2.3 recalculate vegetation cover if natural
129: | ! ind and cn_ind are 0 if not present
130: | !---
131: | IF (natural(j)) THEN
132: |V===== veget_max(:,j) = ind(:,j) * cn_ind(:,j)
133: | ENDIF
134: +------ ENDDO
135: !-------------------
136: END SUBROUTINE crown
137: !-
138: !===
139: !-
140: END MODULE lpj_crown
ORCHIDEE/src_stomate/i.lpj_establish.L 0000754 0103600 0005670 00000075100 11164403473 017442 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:47 2008
FILE NAME: i.lpj_establish.f90
PROGRAM NAME: lpj_establish
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
169 vec ( 3): Unvectorized loop.
169 vec ( 13): Overhead of loop division is too large.
173 vec ( 4): Vectorized array expression.
177 vec ( 4): Vectorized array expression.
187 opt (1408): Loop switched.
187 vec ( 4): Vectorized array expression.
187 vec ( 4): Vectorized array expression.
187 vec ( 4): Vectorized array expression.
187 vec ( 4): Vectorized array expression.
196 vec ( 3): Unvectorized loop.
196 vec ( 13): Overhead of loop division is too large.
202 vec ( 4): Vectorized array expression.
209 vec ( 4): Vectorized array expression.
221 vec ( 4): Vectorized array expression.
223 vec ( 2): Partially vectorized loop.
223 vec ( 25): Work vectors are used. Size=96byte
230 vec ( 4): Vectorized array expression.
246 vec ( 4): Vectorized array expression.
267 vec ( 4): Vectorized array expression.
291 opt (1592): Outer loop unrolled inside inner loop.
291 vec ( 4): Vectorized array expression.
308 vec ( 3): Unvectorized loop.
308 vec ( 13): Overhead of loop division is too large.
310 opt (1036): Potential feedback - use directive if OK.
335 vec ( 22): Dependency unknown. Unvectorizable dependency is assumed.:everywhere
344 vec ( 22): Dependency unknown. Unvectorizable dependency is assumed.:everywhere
350 vec ( 22): Dependency unknown. Unvectorizable dependency is assumed.:everywhere
370 vec ( 4): Vectorized array expression.
382 vec ( 4): Vectorized array expression.
399 vec ( 4): Vectorized array expression.
407 vec ( 4): Vectorized array expression.
427 vec ( 4): Vectorized array expression.
430 opt (1084): Branch out of the loop inhibits optimization.
430 vec ( 4): Vectorized array expression.
430 vec ( 26): Macro operation Search.
432 vec ( 3): Unvectorized loop.
432 vec ( 13): Overhead of loop division is too large.
434 vec ( 4): Vectorized array expression.
449 vec ( 4): Vectorized array expression.
456 vec ( 4): Vectorized array expression.
456 vec ( 4): Vectorized array expression.
456 vec ( 4): Vectorized array expression.
465 vec ( 4): Vectorized array expression.
483 vec ( 4): Vectorized array expression.
485 vec ( 4): Vectorized array expression.
507 vec ( 4): Vectorized array expression.
530 opt (1592): Outer loop unrolled inside inner loop.
530 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:47 2008
FILE NAME: i.lpj_establish.f90
PROGRAM NAME: lpj_establish
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! establishment routine
2: ! Suppose seed pool >> establishment rate.
3: !
4: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_establish.f90,v 1.8 2007/05/28 14:49:02 ssipsl Exp $
5: ! IPSL (2006)
6: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
7: !
8: MODULE lpj_establish
9:
10: ! modules used:
11:
12: USE ioipsl
13: USE stomate_constants
14:
15: IMPLICIT NONE
16:
17: ! private & public routines
18:
19: PRIVATE
20: PUBLIC establish,establish_clear
21:
22: ! first call
23: LOGICAL, SAVE :: firstcall = .TRUE.
24: CONTAINS
25:
26:
27: SUBROUTINE establish_clear
28: firstcall = .TRUE.
29: END SUBROUTINE establish_clear
30:
31: SUBROUTINE establish (npts, dt, PFTpresent, regenerate, &
32: neighbours, resolution, space_nat, need_adjacent, herbivores, &
33: precip_annual, gdd0, lm_lastyearmax, &
34: cn_ind, lai, avail_tree, avail_grass, &
35: leaf_age, leaf_frac, &
36: ind, biomass, age, everywhere, co2_to_bm)
37:
38: !
39: ! 0 declarations
40: !
41:
42: ! 0.1 input
43:
44: ! Domain size
45: INTEGER(i_std), INTENT(in) :: npts
46: ! Time step of vegetation dynamics (days)
47: REAL(r_std), INTENT(in) :: dt
48: ! Is pft there
49: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
50: ! Winter sufficiently cold
51: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: regenerate
52: ! indices of the 8 neighbours of each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
53: INTEGER(i_std), DIMENSION(npts,8), INTENT(in) :: neighbours
54: ! resolution at each grid point in m (1=E-W, 2=N-S)
55: REAL(r_std), DIMENSION(npts,2), INTENT(in) :: resolution
56: ! total natural space (fraction of total space)
57: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
58: ! in order for this PFT to be introduced, does it have to be present in an
59: ! adjacent grid box?
60: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: need_adjacent
61: ! time constant of probability of a leaf to be eaten by a herbivore (days)
62: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: herbivores
63: ! annual precipitation (mm/year)
64: REAL(r_std), DIMENSION(npts), INTENT(in) :: precip_annual
65: ! growing degree days (C)
66: REAL(r_std), DIMENSION(npts), INTENT(in) :: gdd0
67: ! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
68: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lm_lastyearmax
69: ! crown area of individuals (m**2)
70: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: cn_ind
71: ! leaf area index OF AN INDIVIDUAL PLANT
72: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
73: ! space availability for trees
74: REAL(r_std), DIMENSION(npts), INTENT(in) :: avail_tree
75: ! space availability for grasses
76: REAL(r_std), DIMENSION(npts), INTENT(in) :: avail_grass
77:
78: ! 0.2 modified fields
79:
80: ! leaf age (days)
81: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
82: ! fraction of leaves in leaf age class
83: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
84: ! Number of individuals / m2
85: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
86: ! biomass (gC/(m**2 of nat/agri ground))
87: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
88: ! mean age (years)
89: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
90: ! is the PFT everywhere in the grid box or very localized (after its introduction)
91: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
92: ! biomass uptaken (gC/(m**2 of total ground)/day)
93: REAL(r_std), DIMENSION(npts), INTENT(inout) :: co2_to_bm
94:
95: ! 0.3 local
96:
97: ! time during which a sapling can be entirely eaten by herbivores (d)
98: REAL(r_std) :: tau_eatup
99: ! new fpc ( foliage protected cover: fractional coverage )
100: REAL(r_std), DIMENSION(npts,npft) :: fpc_nat
101: ! maximum tree establishment rate, based on climate only
102: REAL(r_std), DIMENSION(npts) :: estab_rate_max_climate_tree
103: ! maximum grass establishment rate, based on climate only
104: REAL(r_std), DIMENSION(npts) :: estab_rate_max_climate_grass
105: ! maximum tree establishment rate, based on climate and fpc
106: REAL(r_std), DIMENSION(npts) :: estab_rate_max_tree
107: ! maximum grass establishment rate, based on climate and fpc
108: REAL(r_std), DIMENSION(npts) :: estab_rate_max_grass
109: ! total natural fpc
110: REAL(r_std), DIMENSION(npts) :: sumfpc
111: ! total woody fpc
112: REAL(r_std), DIMENSION(npts) :: sumfpc_wood
113: ! for trees, measures the total concurrence for available space
114: REAL(r_std), DIMENSION(npts) :: spacefight_tree
115: ! for grasses, measures the total concurrence for available space
116: REAL(r_std), DIMENSION(npts) :: spacefight_grass
117: ! change in number of individuals /m2 per time step (per day in history file)
118: REAL(r_std), DIMENSION(npts,npft) :: d_ind
119: ! biomass increase (gC/(m**2 of nat/agri ground))
120: REAL(r_std), DIMENSION(npts) :: bm_new
121: ! stem diameter (m)
122: REAL(r_std), DIMENSION(npts) :: dia
123: ! temporary variable
124: REAL(r_std), DIMENSION(npts) :: b1
125: ! new sap mass (gC/(m**2 of nat/agri ground))
126: REAL(r_std), DIMENSION(npts) :: sm2
127: ! woodmass of an individual
128: REAL(r_std), DIMENSION(npts) :: woodmass
129: ! ratio of hw(above) to total hw, sm(above) to total sm
130: REAL(r_std), DIMENSION(npts) :: sm_at
131: ! reduction factor for establishment if many trees or grasses are present
132: REAL(r_std), DIMENSION(npts) :: factor
133: ! from how many sides is the grid box invaded
134: INTEGER(i_std) :: nfrontx
135: INTEGER(i_std) :: nfronty
136: ! daily establishment rate is large compared to present number of individuals
137: LOGICAL, DIMENSION(npts) :: many_new
138: ! indices
139: INTEGER(i_std) :: i,j,k,m
140:
141: ! =========================================================================
142:
143: IF (bavard.GE.3) WRITE(numout,*) 'Entering establish'
144:
145: !
146: ! 1 messages and initialization
147: !
148: tau_eatup = one_year/2.
149:
150: IF ( firstcall ) THEN
151:
152: WRITE(numout,*) 'establish:'
153:
154: WRITE(numout,*) ' > time during which a sapling can be entirely eaten by herbivores (d): ', &
155: tau_eatup
156:
157: firstcall = .FALSE.
158:
159: ENDIF
160:
161: !
162: ! 2 recalculate fpc
163: !
164:
165: !
166: ! 2.1 Only natural part of the grid cell
167: !
168:
169: +------> DO j = 1, npft
170: |
171: | IF ( natural(j) ) THEN
172: |
173: |V===== fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) * ( 1. - exp( -lai(:,j) * ext_coeff(j) ) )
174: |
175: | ELSE
176: |
177: |V===== fpc_nat(:,j) = 0.0
178: |
179: | ENDIF
180: |
181: +------ ENDDO
182:
183: !
184: ! 2.2 total natural fpc on grid
185: !
186:
187: +V-----> sumfpc(:) = SUM( fpc_nat(:,:), DIM=2 )
188: |
189: | !
190: | ! 2.3 total woody fpc on grid and number of regenerative tree pfts
191: | !
192: |
193: | sumfpc_wood(:) = 0.0
194: +------ spacefight_tree(:) = 0.0
195:
196: +------> DO j = 1, npft
197: |
198: | IF ( tree(j) .AND. natural(j) ) THEN
199: |
200: | ! total woody fpc
201: |
202: |V-----> WHERE ( PFTpresent(:,j) )
203: |V----- sumfpc_wood(:) = sumfpc_wood(:) + fpc_nat(:,j)
204: | ENDWHERE
205: |
206: | ! how many trees are competing? Count a PFT fully only if it is present
207: | ! on the whole grid box.
208: |
209: |V-----> WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) )
210: |V----- spacefight_tree(:) = spacefight_tree(:) + everywhere(:,j)
211: | ENDWHERE
212: |
213: | ENDIF
214: |
215: +------ ENDDO
216:
217: !
218: ! 2.4 number of natural grasses
219: !
220:
221: V====== spacefight_grass(:) = 0.0
222:
223: V------> DO j = 1, npft
224: |
225: | S IF ( .NOT. tree(j) .AND. natural(j) ) THEN
226: |
227: | ! how many grasses are competing? Count a PFT fully only if it is present
228: | ! on the whole grid box.
229: |
230: |V-----> WHERE ( PFTpresent(:,j) )
231: |V----- spacefight_grass(:) = spacefight_grass(:) + everywhere(:,j)
232: | ENDWHERE
233: |
234: | ENDIF
235: |
236: V------ ENDDO
237:
238: !
239: ! 3 establishment rate
240: !
241:
242: !
243: ! 3.1 maximum establishment rate, based on climate only
244: !
245:
246: V------> WHERE ( ( precip_annual(:) .GE. precip_crit ) .AND. ( gdd0(:) .GE. gdd_crit ) )
247: |
248: | estab_rate_max_climate_tree(:) = estab_max_tree
249: | estab_rate_max_climate_grass(:) = estab_max_grass
250: |
251: | ELSEWHERE
252: |
253: | estab_rate_max_climate_tree(:) = 0.0
254: V------ estab_rate_max_climate_grass(:) = 0.0
255:
256: ENDWHERE
257:
258: !
259: ! 3.2 reduce maximum tree establishment rate if many trees present.
260: ! In the original DGVM, this is done using a step function which yields a
261: ! reduction by factor 4 if sumfpc_wood(i) .GT. fpc_crit - 0.05.
262: ! This can lead to small oscillations (without consequences however).
263: ! Here, a steady linear transition is used between fpc_crit-0.075 and
264: ! fpc_crit-0.025.
265: !
266:
267: V------> factor(:) = 1. - 15. * ( sumfpc_wood(:) - (fpc_crit-.075) )
268: | factor(:) = MAX( 0.25_r_std, MIN( 1._r_std, factor(:) ) )
269: |
270: | estab_rate_max_tree(:) = estab_rate_max_climate_tree(:) * factor(:)
271: |
272: | !
273: | ! 3.3 Modulate grass establishment rate.
274: | ! If canopy is not closed (fpc < fpc_crit-0.05), normal establishment.
275: | ! If canopy is closed, establishment is reduced by a factor 4.
276: | ! Factor is linear between these two bounds.
277: | ! This is different from the original DGVM where a step function is
278: | ! used at fpc_crit-0.05 (This can lead to small oscillations,
279: | ! without consequences however).
280: | !
281: |
282: | factor(:) = 1. - 15. * ( sumfpc(:) - (fpc_crit-.05) )
283: | factor(:) = MAX( 0.25_r_std, MIN( 1._r_std, factor(:) ) )
284: |
285: V------ estab_rate_max_grass(:) = estab_rate_max_climate_grass(:) * factor(:)
286:
287: !
288: ! 4 do establishment for natural PFTs
289: !
290:
291: +V===== d_ind(:,:) = 0.0
292:
293: +------> DO j = 1, npft
294: |
295: | ! only for natural PFTs
296: |
297: | IF ( natural(j) ) THEN
298: |
299: | !
300: | ! 4.1 PFT expansion across the grid box. Not to be confused with areal
301: | ! coverage.
302: | !
303: |
304: | IF ( treat_expansion ) THEN
305: |
306: | ! only treat plants that are regenerative and present and still can expand
307: |
308: |+-----> DO i = 1, npts
309: ||
310: || IF ( PFTpresent(i,j) .AND. &
311: || ( everywhere(i,j) .LT. 1. ) .AND. &
312: || ( regenerate(i,j) .GT. regenerate_crit ) ) THEN
313: ||
314: || ! from how many sides is the grid box invaded (separate x and y directions
315: || ! because resolution may be strongly anisotropic)
316: || !
317: || ! For the moment we only look into 4 direction but that can be extanded (JP)
318: || !
319: || nfrontx = 0
320: || IF ( neighbours(i,3) .GT. 0 ) THEN
321: || IF ( everywhere(neighbours(i,3),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1
322: || ENDIF
323: || IF ( neighbours(i,7) .GT. 0 ) THEN
324: || IF ( everywhere(neighbours(i,7),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1
325: || ENDIF
326: ||
327: || nfronty = 0
328: || IF ( neighbours(i,1) .GT. 0 ) THEN
329: || IF ( everywhere(neighbours(i,1),j) .GT. 1.-min_stomate ) nfronty = nfronty+1
330: || ENDIF
331: || IF ( neighbours(i,5) .GT. 0 ) THEN
332: || IF ( everywhere(neighbours(i,5),j) .GT. 1.-min_stomate ) nfronty = nfronty+1
333: || ENDIF
334: ||
335: || everywhere(i,j) = &
336: || everywhere(i,j) + migrate(j) * dt/one_year * &
337: || ( nfrontx / resolution(i,1) + nfronty / resolution(i,2) )
338: ||
339: || IF ( .NOT. need_adjacent(i,j) ) THEN
340: ||
341: || ! in that case, we also assume that the PFT expands from places within
342: || ! the grid box (e.g., oasis).
343: ||
344: || everywhere(i,j) = &
345: || everywhere(i,j) + migrate(j) * dt/one_year * &
346: || 2. * SQRT( pi*everywhere(i,j)/(resolution(i,1)*resolution(i,2)) )
347: ||
348: || ENDIF
349: ||
350: || everywhere(i,j) = MIN( everywhere(i,j), 1._r_std )
351: ||
352: || ENDIF
353: ||
354: |+----- ENDDO
355: |
356: | ENDIF ! treat expansion?
357: |
358: | !
359: | ! 4.2 establishment rate
360: | ! - Is lower if the PFT is only present in a small part of the grid box
361: | ! (after its introduction), therefore multiplied by "everywhere".
362: | ! - Is divided by the number of PFTs that compete ("spacefight").
363: | ! - Is modulated by space availability (avail_tree, avail_grass).
364: | !
365: |
366: | IF ( tree(j) ) THEN
367: |
368: | ! 4.2.1 present and regenerative trees
369: |
370: |V-----> WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) )
371: ||
372: ||
373: |V----- d_ind(:,j) = estab_rate_max_tree(:)*everywhere(:,j)/spacefight_tree(:) * &
374: | avail_tree(:) * dt/one_year
375: |
376: | ENDWHERE
377: |
378: | ELSE
379: |
380: | ! 4.2.2 present and regenerative grasses
381: |
382: |V-----> WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) )
383: ||
384: |V----- d_ind(:,j) = estab_rate_max_grass(:)*everywhere(:,j)/spacefight_grass(:) * &
385: | avail_grass(:) * dt/one_year
386: |
387: | ENDWHERE
388: |
389: | ENDIF ! tree/grass
390: |
391: | !
392: | ! 4.3 herbivores reduce establishment rate
393: | ! We suppose that saplings are vulnerable during a given time after establishment.
394: | ! This is taken into account by preventively reducing the establishment rate.
395: | !
396: |
397: | IF ( ok_herbivores ) THEN
398: |
399: |V===== d_ind(:,j) = d_ind(:,j) * EXP( - tau_eatup/herbivores(:,j) )
400: |
401: | ENDIF
402: |
403: | !
404: | ! 4.4 be sure that ind*cn_ind does not exceed 1
405: | !
406: |
407: |V-----> WHERE ( ( d_ind(:,j) .GT. 0.0 ) .AND. &
408: || ( (ind(:,j)+d_ind(:,j))*cn_ind(:,j) .GT. 1. ) )
409: ||
410: |V----- d_ind(:,j) = MAX( 1._r_std / cn_ind(:,j) - ind(:,j), 0._r_std )
411: |
412: | ENDWHERE
413: |
414: | !
415: | ! 4.5 new properties where there is establishment ( d_ind > 0 )
416: | !
417: |
418: | ! 4.5.1 biomass.
419: | ! Add biomass only if d_ind, over one year, is of the order of ind.
420: | ! (If we don't do this, the biomass density can become very low).
421: | ! In that case, take biomass from the atmosphere.
422: | ! As we are talking about a flux from the atmosphere, we transform
423: | ! space_nat from gC/(m**2 of natural ground) to
424: | ! gC/(m**2 of total ground).
425: |
426: | ! compare establishment rate and present number of inidivuals
427: |V===== many_new(:) = ( d_ind(:,j) .GT. 0.1 * ind(:,j) )
428: |
429: | ! gives a better vectorization of the VPP
430: |V===== IF ( ANY( many_new(:) ) ) THEN
431: |
432: |+-----> DO k = 1, nparts
433: ||
434: ||V----> WHERE ( many_new(:) )
435: |||
436: ||| bm_new(:) = d_ind(:,j) * bm_sapl(j,k)
437: |||
438: ||| biomass(:,j,k) = biomass(:,j,k) + bm_new(:)
439: |||
440: ||V---- co2_to_bm(:) = co2_to_bm(:) + bm_new(:) * space_nat(:) / dt
441: ||
442: || ENDWHERE
443: ||
444: |+----- ENDDO
445: |
446: | ! reset leaf ages. Should do a real calculation like in the npp routine,
447: | ! but this case is rare and not worth messing around.
448: |
449: |V-----> WHERE ( many_new(:) )
450: || leaf_age(:,j,1) = 0.0
451: |V----- leaf_frac(:,j,1) = 1.0
452: | ENDWHERE
453: |
454: |*-----> DO m = 2, nleafages
455: ||
456: ||V----> WHERE ( many_new(:) )
457: ||| leaf_age(:,j,m) = 0.0
458: ||V---- leaf_frac(:,j,m) = 0.0
459: || ENDWHERE
460: ||
461: |*----- ENDDO
462: |
463: | ENDIF ! establishment rate is large
464: |
465: |V-----> WHERE ( d_ind(:,j) .GT. 0.0 )
466: ||
467: || ! 4.5.2 age decreases
468: ||
469: || age(:,j) = age(:,j) * ind(:,j) / ( ind(:,j) + d_ind(:,j) )
470: ||
471: || ! 4.5.3 new number of individuals
472: ||
473: |V----- ind(:,j) = ind(:,j) + d_ind(:,j)
474: |
475: | ENDWHERE
476: |
477: | !
478: | ! 4.6 eventually convert excess sapwood to heartwood
479: | !
480: |
481: | IF ( tree(j) ) THEN
482: |
483: |V===== sm2(:) = 0.0
484: |
485: |V-----> WHERE ( d_ind(:,j) .GT. 0.0 )
486: ||
487: || ! ratio of above / total sap parts
488: || sm_at(:) = biomass(:,j,isapabove) / &
489: || ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) )
490: ||
491: || ! woodmass of an individual
492: ||
493: || woodmass(:) = &
494: || ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) + &
495: || biomass(:,j,iheartabove) + biomass(:,j,iheartbelow) ) / ind(:,j)
496: ||
497: || ! crown area (m**2) depends on stem diameter (pipe model)
498: || dia(:) = ( woodmass(:) / ( pipe_density * pi/4. * pipe_tune2 ) ) &
499: || ** ( 1. / ( 2. + pipe_tune3 ) )
500: ||
501: || b1(:) = pipe_k1 / ( sla(j) * pipe_density*pipe_tune2 * dia(:)**pipe_tune3 ) * &
502: || ind(:,j)
503: |V----- sm2(:) = lm_lastyearmax(:,j) / b1(:)
504: |
505: | ENDWHERE
506: |
507: |V-----> WHERE ( ( d_ind(:,j) .GT. 0.0 ) .AND. &
508: || ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) ) .GT. sm2(:) )
509: ||
510: || biomass(:,j,iheartabove) = biomass(:,j,iheartabove) + &
511: || ( biomass(:,j,isapabove) - sm2(:) * sm_at(:) )
512: || biomass(:,j,isapabove) = sm2(:) * sm_at(:)
513: ||
514: || biomass(:,j,iheartbelow) = biomass(:,j,iheartbelow) + &
515: || ( biomass(:,j,isapbelow) - sm2(:) * (1. - sm_at) )
516: |V----- biomass(:,j,isapbelow) = sm2(:) * (1. - sm_at(:))
517: |
518: | ENDWHERE
519: |
520: | ENDIF ! tree
521: |
522: | ENDIF ! natural
523: |
524: +------ ENDDO ! loop over pfts
525:
526: !
527: ! 5 history
528: !
529:
530: +V===== d_ind = d_ind / dt
531:
532: CALL histwrite (hist_id_stomate, 'IND_ESTAB', itime, d_ind, npts*npft, horipft_index)
533:
534: IF (bavard.GE.4) WRITE(numout,*) 'Leaving establish'
535:
536: END SUBROUTINE establish
537:
538: END MODULE lpj_establish
ORCHIDEE/src_stomate/i.lpj_fire.L 0000754 0103600 0005670 00000103576 11164403473 016422 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:48 2008
FILE NAME: i.lpj_fire.f90
PROGRAM NAME: lpj_fire
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
198 vec ( 4): Vectorized array expression.
199 opt (1592): Outer loop unrolled inside inner loop.
199 vec ( 4): Vectorized array expression.
205 vec ( 4): Vectorized array expression.
219 vec ( 4): Vectorized array expression.
235 vec ( 2): Partially vectorized loop.
235 vec ( 25): Work vectors are used. Size=96byte
247 opt (1082): Backward transfers inhibit loop optimization.
247 vec ( 4): Vectorized array expression.
265 vec ( 4): Vectorized array expression.
284 vec ( 4): Vectorized array expression.
315 vec ( 4): Vectorized array expression.
324 vec ( 4): Vectorized array expression.
332 vec ( 4): Vectorized array expression.
338 vec ( 4): Vectorized array expression.
341 vec ( 4): Vectorized array expression.
341 vec ( 4): Vectorized array expression.
346 vec ( 4): Vectorized array expression.
352 vec ( 2): Partially vectorized loop.
352 vec ( 25): Work vectors are used. Size=96byte
372 vec ( 4): Vectorized array expression.
378 vec ( 4): Vectorized array expression.
397 vec ( 2): Partially vectorized loop.
397 vec ( 25): Work vectors are used. Size=32byte
406 vec ( 4): Vectorized array expression.
411 opt (1059): Unable to determine last value of scalar temporary.
423 vec ( 4): Vectorized array expression.
425 vec ( 4): Vectorized array expression.
431 vec ( 4): Vectorized array expression.
449 vec ( 2): Partially vectorized loop.
449 vec ( 25): Work vectors are used. Size=32byte
453 vec ( 4): Vectorized array expression.
466 vec ( 4): Vectorized array expression.
487 vec ( 4): Vectorized array expression.
487 vec ( 4): Vectorized array expression.
541 vec ( 3): Unvectorized loop.
541 vec ( 13): Overhead of loop division is too large.
550 vec ( 4): Vectorized array expression.
550 vec ( 4): Vectorized array expression.
560 vec ( 4): Vectorized array expression.
560 vec ( 4): Vectorized array expression.
596 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:48 2008
FILE NAME: i.lpj_fire.f90
PROGRAM NAME: lpj_fire
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! calculate fire extent and impact on plants.
2: ! This is treated on a pseudo-daily basis (fireindex has a long-term memory).
3: ! We only take into account the natural litter, as agricultural and
4: ! natural PFTs are usually spatially separated.
5: ! Fire decreases the biomass per m**2 of natural ground.
6: ! Grasses are totally burned.
7: ! When the vegetation is dynamic, it also decreases the density of individuals.
8: ! Fire burns litter on the ground.
9: !
10: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_fire.f90,v 1.9 2007/06/13 07:44:34 ssipsl Exp $
11: ! IPSL (2006)
12: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
13: !
14: MODULE lpj_fire
15:
16: ! modules used:
17:
18: USE ioipsl
19: USE stomate_constants
20: USE parallel
21:
22: IMPLICIT NONE
23:
24: ! private & public routines
25:
26: PRIVATE
27: PUBLIC fire,fire_clear
28:
29: ! first call
30: LOGICAL, SAVE :: firstcall = .TRUE.
31: ! flag that disable fire
32: LOGICAL, SAVE :: disable_fire
33:
34: CONTAINS
35:
36:
37: SUBROUTINE fire_clear
38: firstcall = .TRUE.
39: END SUBROUTINE fire_clear
40:
41: SUBROUTINE fire (npts, dt, space_nat, litterpart, &
42: litterhum_daily, t2m_daily, lignin_struc, &
43: fireindex, firelitter, biomass, ind, &
44: litter, dead_leaves, bm_to_litter, black_carbon, &
45: co2_fire)
46:
47: !
48: ! 0 declarations
49: !
50:
51: ! 0.1 input
52:
53: ! Domain size
54: INTEGER(i_std), INTENT(in) :: npts
55: ! Time step in days
56: REAL(r_std), INTENT(in) :: dt
57: ! fraction of total space that is natural
58: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
59: ! fraction of litter above the ground belonging to different PFTs
60: REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(in) :: litterpart
61: ! Daily litter moisture (between 0 and 1)
62: REAL(r_std), DIMENSION(npts), INTENT(in) :: litterhum_daily
63: ! Daily 2 meter temperature (K)
64: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_daily
65: ! ratio Lignine/Carbon in structural litter, above and below ground,
66: ! natural and agricultural (gC/(m**2 of nat/agri ground))
67: REAL(r_std), DIMENSION(npts,nvegtypes,nlevs), INTENT(in) :: lignin_struc
68:
69: ! 0.2 modified fields
70:
71: ! Probability of fire
72: REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: fireindex
73: ! Longer term total natural litter above the ground, gC/m**2 of natural ground
74: REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: firelitter
75: ! biomass (gC/m**2)
76: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
77: ! density of individuals (1/m**2)
78: REAl(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
79: ! metabolic and structural litter, natural and agricultural,
80: ! above and below ground (gC/m**2)
81: REAL(r_std), DIMENSION(npts,nlitt,nvegtypes,nlevs), INTENT(inout):: litter
82: ! dead leaves on ground, per PFT, metabolic and structural,
83: ! in gC/(m**2 of nat/agri ground)
84: REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: dead_leaves
85: ! conversion of biomass to litter (gC/(m**2 of average nat/agri ground)) / day
86: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
87: ! black carbon on the ground (gC/(m**2 of total ground))
88: REAL(r_std), DIMENSION(npts), INTENT(inout) :: black_carbon
89:
90: ! 0.3 output
91:
92: ! carbon emitted into the atmosphere by fire (living and dead biomass)
93: ! (in gC/m**2/day)
94: REAL(r_std), DIMENSION(npts), INTENT(out) :: co2_fire
95:
96: ! 0.4 local
97:
98: ! Time scale for memory of the fire index (days). Validated for one year in the DGVM.
99: REAL(r_std), PARAMETER :: tau_fire = 30. ! GKtest
100: ! Critical litter quantity for fire
101: REAL(r_std), PARAMETER :: litter_crit = 200.
102: ! fire perturbation
103: REAL(r_std), DIMENSION(npts) :: fire_disturb
104: ! what fraction of the plants is burned each day?
105: REAL(r_std), DIMENSION(npts,npft) :: firedeath
106: ! What fraction of a burned plant compartment goes into the atmosphere
107: ! (rest into litter)
108: REAL(r_std), SAVE, DIMENSION(nparts) :: co2frac
109: ! Moisture limit (critical moisture limit)
110: REAL(r_std), DIMENSION(npts) :: moistlimit
111: ! total litter above the ground for a vegetation type (gC/m**2)
112: REAL(r_std), DIMENSION(npts) :: litter_above
113: ! daily fire index
114: REAL(r_std), DIMENSION(npts,nvegtypes) :: fireindex_daily
115: ! fire extent, on natural and agricultural ground
116: REAL(r_std), DIMENSION(npts, nvegtypes) :: firefrac
117: ! residual fraction of exposed structural litter, depending on lignin fraction
118: REAL(r_std), DIMENSION(npts) :: struc_residual
119: ! residue, i.e. exposed carbon - volatilized carbon ( gC/(m**2 of nat/agri ground))
120: REAL(r_std), DIMENSION(npts) :: residue
121: ! fraction of residue transformed into black carbon
122: REAL(r_std), DIMENSION(npts) :: bcfrac
123: ! fraction of total space that is natural/agricultural. Allows to transform from
124: ! 1/(m**2 of nat/agri ground) to 1/(m**2 of total ground)
125: REAL(r_std), DIMENSION(npts,nvegtypes) :: fracspace_vegtype
126: ! intermediate variable
127: REAL(r_std), DIMENSION(npts) :: x
128: ! annual fire fraction
129: REAL(r_std), DIMENSION(npts) :: aff
130: ! are we talking about natural or agricultural ground?
131: INTEGER(i_std) :: ivegtype
132: ! index
133: INTEGER(i_std) :: j,k,m
134:
135: ! =========================================================================
136:
137: IF (bavard.GE.3) WRITE(numout,*) 'Entering fire'
138:
139: !
140: ! 1 Initializations
141: !
142:
143: IF ( firstcall ) THEN
144:
145: !
146: ! 1.1 What fraction of the plant compartment, if burned, is transformed into CO2
147: !
148:
149: co2frac(ileaf) = .95
150: co2frac(isapabove) = .95
151: co2frac(isapbelow) = 0.
152: co2frac(iheartabove) = 0.3
153: co2frac(iheartbelow) = 0.
154: co2frac(iroot) = 0.
155: co2frac(ifruit) = .95
156: co2frac(icarbres) = 0.95
157:
158: !
159: ! 1.2 messages
160: !
161:
162: WRITE(numout,*) 'fire:'
163:
164: WRITE(numout,*) ' > temporal inertia of fire probability (d): ',tau_fire
165:
166: WRITE(numout,*) ' > fraction of burned biomass that becomes CO2:'
167: WRITE(numout,*) ' leaves: ', co2frac(ileaf)
168: WRITE(numout,*) ' sap above ground: ', co2frac(isapabove)
169: WRITE(numout,*) ' sap below ground: ', co2frac(isapbelow)
170: WRITE(numout,*) ' heartwood above ground: ', co2frac(iheartabove)
171: WRITE(numout,*) ' heartwood below ground: ', co2frac(iheartbelow)
172: WRITE(numout,*) ' roots: ', co2frac(iroot)
173: WRITE(numout,*) ' fruits: ', co2frac(ifruit)
174: WRITE(numout,*) ' carbohydrate reserve: ', co2frac(icarbres)
175:
176: WRITE(numout,*) ' > critical litter quantity (gC/m**2): ',litter_crit
177: WRITE(numout,*) ' > We calculate a fire probability on agricultural ground, but'
178: WRITE(numout,*) ' the effective fire fraction is zero.'
179:
180: firstcall = .FALSE.
181: !
182: ! 1.3 read the flag that disable fire
183: !
184: !Config Key = FIRE_DISABLE
185: !Config Desc = no fire allowed
186: !Config Def = n
187: !Config Help = With this variable, you can allow or not
188: !Config the estimation of CO2 lost by fire
189: !
190: disable_fire=.FALSE.
191: CALL getin_p('FIRE_DISABLE', disable_fire)
192: ENDIF
193:
194: !
195: ! 1.4 Initialize output
196: !
197:
198: V====== co2_fire(:) = 0.0
199: +V===== firedeath(:,:) = 0.0
200:
201: !
202: ! 1.5 fraction of total space reserved for vegetation type
203: !
204:
205: V------> fracspace_vegtype(:,inat) = space_nat(:)
206: V------ fracspace_vegtype(:,iagri) = 1. - space_nat(:)
207:
208: !
209: ! 2 Determine fire probability. We calculate this probability (and long-term litter)
210: ! also for agricultural ground, but the fire fraction on agricultural ground is set
211: ! to 0 for the moment.
212: !
213:
214:
215: +------> DO ivegtype = 1, nvegtypes
216: |
217: | ! total litter above the ground, for the vegetation type we are talking about
218: |
219: |V-----> litter_above(:) = litter(:,imetabolic,ivegtype,iabove) + &
220: || litter(:,istructural,ivegtype,iabove)
221: ||
222: || !
223: || ! 2.1 calculate moisture limit. If it stays 0, this means that there is no litter
224: || ! on the ground, and this means that there can be no fore.
225: || ! Sum over different litter parts from the various PFTs, taking into account the
226: || ! litter flamability which is a function of the PFT.
227: || ! Difference to Stephen Sitch's approach: Daily litter, not annual mean.
228: || ! Reason: 1. seems more reasonable.
229: || ! 2. easier to implement (otherwise, would need moisture limit
230: || ! from previous year)
231: || !
232: ||
233: |V----- moistlimit(:) = 0.
234: |
235: |V-----> DO j = 1, npft
236: ||
237: || ! If we are on natural ground, only take natural PFTs, and vice versa
238: ||
239: || S IF ( ( ( ivegtype .EQ. inat ) .AND. natural(j) ) .OR. &
240: || ( ( ivegtype .EQ. iagri ) .AND. .NOT. natural(j) ) ) THEN
241: ||
242: || ! fire only when above feezing point and when there is litter
243: || ! (structural or metabolic) above the ground.
244: || ! Loop over grid points is the innermost because of vectorization.
245: || ! (Makes the code unreadable.)
246: ||
247: ||V----> WHERE ( ( t2m_daily(:) .GT. ZeroCelsius ) .AND. &
248: ||| ( litter_above(:) .GT. min_stomate ) )
249: |||
250: ||V---- moistlimit(:) = moistlimit(:) + &
251: || ( litterpart(:,j,imetabolic)*litter(:,imetabolic,ivegtype,iabove) + &
252: || litterpart(:,j,istructural)*litter(:,istructural,ivegtype,iabove) ) / &
253: || litter_above(:) * flam(j)
254: ||
255: || ENDWHERE
256: ||
257: || ENDIF ! PFT and vegetation type coherent?
258: ||
259: |V----- ENDDO ! PFT
260: |
261: | !
262: | ! 2.2 daily fire index.
263: | !
264: |
265: |V-----> WHERE ( moistlimit(:) .GT. 0.0 )
266: ||
267: || ! is a function of litter humidity. Very sensible to STOMATE's time step as
268: || ! with larger dt, one misses dry days with very high fireindex ( strongly
269: || ! nonlinear: exp(-x^2)! )
270: ||
271: || x(:) = litterhum_daily(:)/moistlimit(:)
272: || fireindex_daily(:,ivegtype) = EXP( - pi * x(:) * x(:) )
273: ||
274: || ELSEWHERE
275: ||
276: |V----- fireindex_daily(:,ivegtype) = 0.0
277: |
278: | ENDWHERE
279: |
280: | !
281: | ! 2.3 increase long-term fire index (mean probability)
282: | !
283: |
284: |V-----> fireindex(:,ivegtype) = &
285: || ( ( tau_fire - dt ) * fireindex(:,ivegtype) + &
286: || ( dt ) * fireindex_daily(:,ivegtype) ) / tau_fire
287: ||
288: || !
289: || ! 2.4 litter influences fire intensity.
290: || ! We use longer-term litter to be consistent with the fire index.
291: || !
292: ||
293: |V----- firelitter(:,ivegtype) = &
294: | ( ( tau_fire-dt ) * firelitter(:,ivegtype) + dt * litter_above(:) ) / tau_fire
295: |
296: +------ ENDDO
297:
298: !
299: ! 3 Calculate fire fraction from litter and fireindex (i.e. basically drought)
300: ! We assume that agricultural space is separated from natural space so that
301: ! the fire occurence on natural ground does not depend on the litter
302: ! on agricultural ground.
303: !
304:
305: !
306: ! 3.1 natural ground
307: !
308:
309: ! This formulation has been developped for annual fire indices!
310: ! original form: firefrac(i) = fireindex(i) * EXP( f(fireindex(i)) )
311: ! Transform into daily fire fraction.
312:
313: ! annual fire fraction
314:
315: V====== aff(:) = firefrac_func (npts, fireindex(:,inat))
316:
317: ! transform from annual fraction to daily fraction.
318: ! annual fire fraction = 1. - (fraction of tree that survives each day) ** 365 =
319: ! = 1. - ( 1. - daily fire fraction )**365
320: ! Thus, daily fire fraction = 1. - ( 1. - annual fire fraction )**(1/365)
321: ! If annual firefrac<<1, then firefrac_daily = firefrac * dt/one_year
322: ! This approximation avoids numerical problems.
323:
324: V------> WHERE ( aff(:) .GT. 0.1 )
325: | firefrac(:,inat) = 1. - ( 1. - aff(:) ) ** (dt/one_year)
326: | ELSEWHERE
327: V------ firefrac(:,inat) = aff(:) * dt/one_year
328: ENDWHERE
329:
330: ! No fire if litter is below critical value
331:
332: V------> WHERE ( firelitter(:,inat) .LT. litter_crit )
333: V------ firefrac(:,inat) = 0.0
334: ENDWHERE
335:
336: ! However, there is a minimum fire extent
337:
338: V====== firefrac(:,inat) = MAX( 0.001_r_std * dt/one_year, firefrac(:,inat) )
339:
340: ! if FIRE_DISABLE flag is set no fire
341: +V===== IF (disable_fire) firefrac=0
342: !
343: ! 3.2 agricultural ground: no fire for the moment
344: !
345:
346: V====== firefrac(:,iagri) = 0.0
347:
348: !
349: ! 4 Determine fire impact: calculate fire disturbance for each PFT
350: !
351:
352: V------> DO j = 1, npft
353: |
354: | !
355: | ! 4.1 are we talking about a natural or an agricultural PFT?
356: | !
357: |
358: | IF ( natural(j) ) THEN
359: | ivegtype = inat
360: | ELSE
361: | ivegtype = iagri
362: | ENDIF
363: |
364: | !
365: | ! 4.2 fire disturbance
366: | !
367: |
368: | S IF ( tree(j) ) THEN
369: |
370: | ! 4.2.1 Trees: always disturbed
371: |
372: |V===== fire_disturb(:) = ( 1. - resist(j) ) * firefrac(:,ivegtype)
373: |
374: | ELSE
375: |
376: | ! 4.2.2 Grasses are not disturbed if they are not in their growing season
377: |
378: |V-----> WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
379: ||
380: || fire_disturb(:) = ( 1. - resist(j) ) * firefrac(:,ivegtype)
381: ||
382: || ELSEWHERE
383: ||
384: |V----- fire_disturb(:) = 0.0
385: |
386: | ENDWHERE
387: |
388: | ENDIF
389: |
390: | !
391: | ! 4.3 litter and co2 created through fire on living biomass
392: | !
393: |
394: | ! biomass can go into litter or atmosphere, depending on what plant compartment
395: | ! we are talking about.
396: |
397: |V-----> DO k = 1, nparts
398: ||
399: || ! grass roots and reserve survive.
400: ||
401: || S IF ( .NOT. ( ( .NOT. tree(j) ) .AND. ( ( k.EQ.iroot ) .OR. ( k.EQ.icarbres ) ) ) ) THEN
402: ||
403: || ! 4.3.1 A fraction goes directly into the atmosphere.
404: || ! CO2 flux in gC/m**2 of total ground/day.
405: ||
406: ||V----> co2_fire(:) = co2_fire(:) + biomass(:,j,k) * fire_disturb(:) * co2frac(k) * &
407: ||| fracspace_vegtype(:,ivegtype) / dt
408: |||
409: ||| ! 4.3.2 Determine the residue, in gC/m**2 of natural/agricultural ground.
410: |||
411: ||V---- residue(:) = biomass(:,j,k) * fire_disturb(:) * ( 1. - co2frac(k) )
412: ||
413: || ! 4.3.2.1 determine fraction of black carbon. Only for plant parts above the
414: || ! ground, i.e. when co2_frac > 0.
415: || ! A small part of the residue, which can be expressed as a function of
416: || ! the fraction of volatilized carbon (assimilated to co2frac here),
417: || ! becomes black carbon, and thus withdrawn from the soil carbon cycle (added
418: || ! to the "geologic carbon cycle we don't care about here).
419: || ! [Kuhlbusch et al. JGR 101, 23651-23665, 1996; Kuhlbusch & Crutzen, GBC 9,
420: || ! 491-501, 1995].
421: ||
422: || S IF ( co2frac(k) .GT. 0.0 ) THEN
423: ||V==== bcfrac(:) = .3 / ( 1.3 ** ( 88.2 - 100.*co2frac(k) ) + 1. )
424: || ELSE
425: ||V==== bcfrac(:) = 0.0
426: || ENDIF
427: ||
428: || ! 4.3.2.2 Add this fraction of the residue to the black carbon "reservoir", in
429: || ! gC/(m**2 of total ground).
430: ||
431: ||V----> black_carbon(:) = &
432: ||| black_carbon(:) + bcfrac(:) * residue(:) * fracspace_vegtype(:,ivegtype)
433: |||
434: ||| ! 4.3.2.3 The rest (largest part) of the residue becomes litter.
435: |||
436: ||V---- bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + residue(:) * ( 1 - bcfrac(:) )
437: ||
438: || ENDIF ! not for grass roots
439: ||
440: |V----- ENDDO
441: |
442: | !
443: | ! 4.4 new vegetation characteristics
444: | !
445: |
446: | ! 4.4.1 decrease biomass per m**2 of natural(/agricultural) ground
447: | ! except for grass roots.
448: |
449: |V-----> DO k = 1, nparts
450: ||
451: || S IF ( .NOT. ( ( .NOT. tree(j) ) .AND. ( ( k.EQ.iroot ) .OR. ( k.EQ.icarbres) ) ) ) THEN
452: ||
453: ||V==== biomass(:,j,k) = ( 1. - fire_disturb(:) ) * biomass(:,j,k)
454: ||
455: || ENDIF
456: ||
457: |V----- ENDDO
458: |
459: | ! 4.4.2 If vegetation is dynamic, then decrease the density of tree
460: | ! individuals.
461: |
462: | S IF ( control%ok_dgvm .AND. tree(j) ) THEN
463: |
464: | ! fraction of plants that dies each day.
465: | ! exact formulation: 1. - (1.-fire_disturb(:)) ** (1./dt)
466: |V-----> firedeath(:,j) = fire_disturb(:) / dt
467: ||
468: |V----- ind(:,j) = ( 1. - fire_disturb(:) ) * ind(:,j)
469: |
470: | ENDIF
471: |
472: V------ ENDDO ! loop over PFTs
473:
474: !
475: ! 5 A fraction of the (natural) litter is burned by the fire
476: !
477:
478: *------> DO ivegtype = 1,nvegtypes
479: |
480: | !
481: | ! 5.1 exposed metabolic litter burns totally and goes directly into the atmosphere as
482: | ! CO2.
483: | !
484: |
485: | ! 5.1.1 CO2 flux, in gC/(m**2 of total ground)/day.
486: |
487: |V-----> co2_fire(:) = co2_fire(:) + litter(:,imetabolic,ivegtype,iabove) * &
488: || firefrac(:,ivegtype) * fracspace_vegtype(:,ivegtype) / dt
489: ||
490: || ! 5.1.2 decrease metabolic litter
491: ||
492: || litter(:,imetabolic,ivegtype,iabove) = litter(:,imetabolic,ivegtype,iabove) * &
493: || ( 1. - firefrac(:,ivegtype) )
494: ||
495: || !
496: || ! 5.2 exposed structural litter is not totally transformed into CO2.
497: || !
498: ||
499: || ! 5.2.1 Fraction of exposed structural litter that does not
500: || ! burn totally should depend on lignin content (lignin_struc). VERY TENTATIVE!
501: ||
502: || struc_residual(:) = 0.5 * lignin_struc(:,ivegtype,iabove)
503: ||
504: || ! 5.2.2 CO2 flux, in gC/(m**2 of total ground)/day.
505: ||
506: || co2_fire(:) = co2_fire(:) + &
507: || litter(:,istructural,ivegtype,iabove) * firefrac(:,ivegtype) * &
508: || ( 1. - struc_residual(:) ) * fracspace_vegtype(:,ivegtype) / dt
509: ||
510: || ! 5.2.3 determine residue (litter that undergoes fire, but is not transformed
511: || ! into CO2)
512: ||
513: || residue(:) = litter(:,istructural,ivegtype,iabove) * firefrac(:,ivegtype) * &
514: || struc_residual(:)
515: ||
516: || ! 5.2.4 determine fraction of black carbon in the residue.
517: || ! depends on volatilized fraction of carbon (see 4.3.2.1)
518: ||
519: || bcfrac(:) = .3 / ( 1.3 ** ( 88.2 - 100.*(1.-struc_residual(:)) ) + 1. )
520: ||
521: || ! 5.2.5 Add this fraction of the residue to the black carbon "reservoir", in
522: || ! gC/(m**2 of total ground).
523: ||
524: || black_carbon(:) = &
525: || black_carbon(:) + bcfrac(:) * residue(:) * fracspace_vegtype(:,ivegtype)
526: ||
527: || ! 5.2.6 The rest (largest part) of the residue remains litter. Remaining litter
528: || ! is the sum of this and of the litter which has not undergone a fire.
529: ||
530: |V----- litter(:,istructural,ivegtype,iabove) = &
531: | litter(:,istructural,ivegtype,iabove) * ( 1. - firefrac(:,ivegtype) ) + &
532: | residue(:) * ( 1. - bcfrac(:) )
533: |
534: *------ ENDDO ! natural/agricultural ground
535:
536: !
537: ! 5.3 diagnose fraction of leaves burned.
538: ! exposed leaves are burned entirely, even their structural part
539: !
540:
541: +------> DO j = 1, npft
542: |
543: | IF ( natural(j) ) THEN
544: | m = inat
545: | ELSE
546: | m = iagri
547: | ENDIF
548: |
549: |+-----> DO k = 1, nlitt
550: ||V==== dead_leaves(:,j,k) = dead_leaves(:,j,k) * ( 1. - firefrac(:,m) )
551: |+----- ENDDO
552: |
553: +------ ENDDO
554:
555: !
556: ! 6 history
557: !
558:
559: ! output in 1/day
560: +V===== firefrac = firefrac / dt
561:
562: CALL histwrite (hist_id_stomate, 'FIREFRAC_NAT', itime, &
563: firefrac(:,inat), npts, hori_index)
564: CALL histwrite (hist_id_stomate, 'FIREFRAC_AGRI', itime, &
565: firefrac(:,iagri), npts, hori_index)
566: CALL histwrite (hist_id_stomate, 'FIREDEATH', itime, &
567: firedeath(:,:), npts*npft, horipft_index)
568:
569: IF (bavard.GE.4) WRITE(numout,*) 'Leaving fire'
570:
571: END SUBROUTINE fire
572:
573: FUNCTION firefrac_func (npts, x) RESULT (firefrac_result)
574:
575: !
576: ! 0 declarations
577: !
578:
579: ! 0.1 input
580:
581: ! Domain size
582: INTEGER(i_std), INTENT(in) :: npts
583: ! fire index
584: REAL(r_std), DIMENSION(npts), INTENT(in) :: x
585:
586: ! 0.2 result
587:
588: ! fire fraction
589: REAL(r_std), DIMENSION(npts) :: firefrac_result
590:
591: ! 0.3 local
592:
593: ! intermediate variable
594: REAL(r_std), DIMENSION(npts) :: xm1
595:
596: V------> xm1(:) = x(:) - 1.
597: |
598: V------ firefrac_result(:) = &
599: x(:) * EXP( xm1(:) / ( -.13*xm1(:)*xm1(:)*xm1(:) + .6*xm1(:)*xm1(:) + .8*xm1(:) + .45 ) )
600:
601: END FUNCTION firefrac_func
602:
603: END MODULE lpj_fire
ORCHIDEE/src_stomate/i.lpj_gap.L 0000754 0103600 0005670 00000030214 11164403473 016230 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:49 2008
FILE NAME: i.lpj_gap.f90
PROGRAM NAME: lpj_gap
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
107 vec ( 4): Vectorized array expression.
123 opt (1082): Backward transfers inhibit loop optimization.
123 vec ( 4): Vectorized array expression.
134 opt (1082): Backward transfers inhibit loop optimization.
142 vec ( 4): Vectorized array expression.
168 vec ( 4): Vectorized array expression.
183 vec ( 4): Vectorized array expression.
195 vec ( 3): Unvectorized loop.
197 vec ( 4): Vectorized array expression.
201 opt (1592): Outer loop unrolled inside inner loop.
213 vec ( 4): Vectorized array expression.
231 opt (1592): Outer loop unrolled inside inner loop.
231 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:49 2008
FILE NAME: i.lpj_gap.f90
PROGRAM NAME: lpj_gap
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! gap routine - place for new plants
2: !
3: ! Death rate of trees is estimated by evaluating their vigour (based on npp).
4: ! For large availabilities, lifetime is 50 years (!?).
5: ! Age of stands is not considered, although availability death rate should probably
6: ! depend on age.
7: !
8: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_gap.f90,v 1.8 2007/06/13 07:44:34 ssipsl Exp $
9: ! IPSL (2006)
10: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
11: !
12: MODULE lpj_gap
13:
14: ! modules used:
15:
16: USE ioipsl
17: USE stomate_constants
18: USE parallel
19:
20: IMPLICIT NONE
21:
22: ! private & public routines
23:
24: PRIVATE
25: PUBLIC gap,gap_clear
26:
27: ! first call
28: LOGICAL, SAVE :: firstcall = .TRUE.
29:
30: CONTAINS
31:
32:
33: SUBROUTINE gap_clear
34: firstcall = .TRUE.
35: END SUBROUTINE gap_clear
36:
37: SUBROUTINE gap (npts, dt, &
38: npp_longterm, turnover_longterm, lm_lastyearmax, &
39: PFTpresent, biomass, ind, bm_to_litter)
40:
41: !
42: ! 0 declarations
43: !
44:
45: ! 0.1 input
46:
47: ! Domain size
48: INTEGER(i_std), INTENT(in) :: npts
49: ! Time step (days)
50: REAL(r_std), INTENT(in) :: dt
51: ! "long term" net primary productivity (gC/(m**2 of nat/agri ground)/year)
52: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: npp_longterm
53: ! "long term" turnover rate (gC/(m**2 of nat/agri ground)/year)
54: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: turnover_longterm
55: ! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
56: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lm_lastyearmax
57:
58: ! 0.2 modified fields
59:
60: ! Is pft there
61: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
62: ! biomass (gC/(m**2 of nat/agri ground))
63: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
64: ! Number of individuals / (m**2 of nat/agri ground)
65: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
66: ! biomass taken away (gC/(m**2 of nat/agri ground))
67: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
68:
69: ! 0.3 local
70:
71: ! which kind of mortality
72: LOGICAL, SAVE :: constant_mortality
73: ! biomass increase
74: REAL(r_std), DIMENSION(npts) :: delta_biomass
75: ! vigour
76: REAL(r_std), DIMENSION(npts) :: vigour
77: ! natural availability, based on vigour
78: REAL(r_std), DIMENSION(npts) :: availability
79: ! mortality (fraction of trees that is dying per time step), per day in history file
80: REAL(r_std), DIMENSION(npts,npft) :: mortality
81: ! indices
82: INTEGER(i_std) :: j,k
83:
84: ! =========================================================================
85:
86: IF ( firstcall ) THEN
87:
88: firstcall = .FALSE.
89:
90: !Config Key = LPJ_GAP_CONST_MORT
91: !Config Desc = constant tree mortality
92: !Config Def = y
93: !Config Help = If yes, then a constant mortality is applied to trees.
94: !Config Otherwise, mortality is a function of the trees'
95: !Config vigour (as in LPJ).
96:
97: constant_mortality = .TRUE.
98: CALL getin_p('LPJ_GAP_CONST_MORT', constant_mortality)
99: WRITE(numout,*) 'gap: constant mortality:', constant_mortality
100:
101: ENDIF
102:
103: IF (bavard.GE.3) WRITE(numout,*) 'Entering gap'
104:
105: +------> DO j = 1, npft
106: |
107: |V===== mortality(:,j) = 0.0
108: |
109: | ! only trees
110: |
111: | IF ( tree(j) ) THEN
112: |
113: | !
114: | ! 1 determine availability
115: | !
116: |
117: | IF ( .NOT. constant_mortality ) THEN
118: |
119: | !
120: | ! 1.1 original formulation: mortality depends on vigour
121: | !
122: |
123: |V-----> WHERE ( PFTpresent(:,j) .AND. ( lm_lastyearmax(:,j) .GT. min_stomate ) )
124: ||
125: || ! how much did the tree grow per year?
126: ||
127: || delta_biomass(:) = &
128: || MAX( npp_longterm(:,j) - ( turnover_longterm(:,j,ileaf) + &
129: || turnover_longterm(:,j,iroot) + turnover_longterm(:,j,ifruit) ), &
130: || 0._r_std )
131: ||
132: || ! scale this to the leaf surface of the tree
133: ||
134: || vigour(:) = delta_biomass(:) / (lm_lastyearmax(:,j)*sla(j)) / 70.
135: ||
136: || ELSEWHERE
137: ||
138: |V----- vigour(:) = 0.0
139: |
140: | ENDWHERE
141: |
142: |V-----> WHERE ( PFTpresent(:,j) )
143: ||
144: || ! note that availability is never above 0.02, i.e. lifetime of 50 years when very
145: || ! low vigour.
146: ||
147: || availability(:) = 0.02 / ( 1.+vigour(:)/0.17 )
148: ||
149: || ! Mortality (fraction per time step).
150: || ! In the original DGVM, mortality was set to zero if there was strong fire
151: || ! perturbation.
152: || ! This has been de-activated since the npp is not influenced by fire,
153: || ! as opposed to the original DGVM. Instead, mortality is simply
154: || ! equal to the availability, modulated by the time step.
155: || ! Exact formulation: mor = 1. - ( 1. - availability ) ** (dt/one_year)
156: || ! approximation ok as availability < 0.02 << 1
157: ||
158: |V----- mortality(:,j) = availability(:) * dt/one_year
159: |
160: | ENDWHERE
161: |
162: | ELSE
163: |
164: | !
165: | ! 1.2 Alternative version: Constant mortality
166: | !
167: |
168: |V-----> WHERE ( PFTpresent(:,j) )
169: ||
170: |V----- mortality(:,j) = dt/(residence_time(j)*one_year)
171: |
172: | ENDWHERE
173: |
174: | ENDIF
175: |
176: | !
177: | ! 2 Special for the DGVM:
178: | ! mortality is one if npp is zero or negative.
179: | !
180: |
181: | IF ( control%ok_dgvm ) THEN
182: |
183: |V-----> WHERE ( PFTpresent(:,j) .AND. ( npp_longterm(:,j) .LE. min_stomate ) )
184: ||
185: |V----- mortality(:,j) = 1.
186: |
187: | ENDWHERE
188: |
189: | ENDIF
190: |
191: | !
192: | ! 3 update biomass, create litter
193: | !
194: |
195: |+-----> DO k = 1, nparts
196: ||
197: ||V----> WHERE ( PFTpresent(:,j) )
198: |||
199: ||| bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + mortality(:,j) * biomass(:,j,k)
200: |||
201: ||V---- biomass(:,j,k) = biomass(:,j,k) * ( 1. - mortality(:,j) )
202: ||
203: || ENDWHERE
204: ||
205: |+----- ENDDO
206: |
207: | !
208: | ! 4 update number of individuals
209: | !
210: |
211: | IF ( control%ok_dgvm ) THEN
212: |
213: |V-----> WHERE ( PFTpresent(:,j) )
214: ||
215: |V----- ind(:,j) = ind(:,j) * ( 1. - mortality(:,j) )
216: |
217: | ENDWHERE
218: |
219: | ENDIF
220: |
221: | ENDIF ! only trees
222: |
223: +------ ENDDO ! loop over pfts
224:
225: !
226: ! 5 history
227: !
228:
229: ! output in fraction of trees that dies/day.
230: ! exact formulation: 1. - ( 1. - mortality ) ** (1./dt)
231: +V===== mortality = mortality / dt
232:
233: CALL histwrite (hist_id_stomate, 'MORTALITY', itime, &
234: mortality, npts*npft, horipft_index)
235:
236: IF (bavard.GE.4) WRITE(numout,*) 'Leaving gap'
237:
238: END SUBROUTINE gap
239:
240: END MODULE lpj_gap
ORCHIDEE/src_stomate/i.lpj_kill.L 0000754 0103600 0005670 00000025247 11164403473 016426 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:49 2008
FILE NAME: i.lpj_kill.f90
PROGRAM NAME: lpj_kill
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
37 obsol( 18): CHARACTER* form of character declaration is used.
86 vec ( 3): Unvectorized loop.
86 vec ( 13): Overhead of loop division is too large.
88 vec ( 4): Vectorized array expression.
98 vec ( 4): Vectorized array expression.
106 opt (1084): Branch out of the loop inhibits optimization.
106 vec ( 4): Vectorized array expression.
106 vec ( 26): Macro operation Search.
108 vec ( 4): Vectorized array expression.
155 vec ( 4): Vectorized array expression.
155 vec ( 4): Vectorized array expression.
155 vec ( 4): Vectorized array expression.
155 vec ( 4): Vectorized array expression.
166 vec ( 17): Unvectorizable statement.
167 vec ( 17): Unvectorizable statement.
167 vec ( 18): Unvectorizable data type.
167 vec ( 4): Vectorized array expression.
179 warn ( 83): Dummy argument "lai" is not used.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:49 2008
FILE NAME: i.lpj_kill.f90
PROGRAM NAME: lpj_kill
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! kills pfts that obviously fare badly
2: !
3: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_kill.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
4: ! IPSL (2006)
5: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
6: !
7: MODULE lpj_kill
8:
9: ! modules used:
10:
11: USE ioipsl
12: USE stomate_constants
13:
14: IMPLICIT NONE
15:
16: ! private & public routines
17:
18: PRIVATE
19: PUBLIC kill
20:
21: CONTAINS
22:
23: SUBROUTINE kill (npts, whichroutine, lm_lastyearmax, &
24: ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
25: lai, age, leaf_age, leaf_frac, &
26: when_growthinit, everywhere, veget, veget_max, bm_to_litter)
27:
28: !
29: ! 0 declarations
30: !
31:
32: ! 0.1 input
33:
34: ! Domain size
35: INTEGER(i_std), INTENT(in) :: npts
36: ! message
37: CHARACTER*10, INTENT(in) :: whichroutine
38: ! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
39: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lm_lastyearmax
40:
41: ! 0.2 modified fields
42:
43: ! Number of individuals / m**2
44: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
45: ! Is pft there
46: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
47: ! crown area of individuals (m**2)
48: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: cn_ind
49: ! biomass (gC/(m**2 of nat/agri ground))
50: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
51: ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
52: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: senescence
53: ! How much time ago was the PFT eliminated for the last time (y)
54: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: RIP_time
55: ! leaf area index OF AN INDIVIDUAL PLANT
56: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
57: ! mean age (years)
58: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
59: ! leaf age (days)
60: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
61: ! fraction of leaves in leaf age class
62: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
63: ! how many days ago was the beginning of the growing season
64: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
65: ! is the PFT everywhere in the grid box or very localized (after its introduction)
66: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
67: ! fractional coverage on natural/agricultural ground, taking into
68: ! account LAI (=grid-scale fpc)
69: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
70: ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
71: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
72: ! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
73: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
74:
75: ! 0.3 local
76:
77: ! indices
78: INTEGER(i_std) :: j,m
79: ! bookkeeping
80: LOGICAL, DIMENSION(npts) :: was_killed
81:
82: ! =========================================================================
83:
84: IF (bavard.GE.3) WRITE(numout,*) 'Entering kill'
85:
86: +------> DO j = 1, npft
87: |
88: |V===== was_killed(:) = .FALSE.
89: |
90: | ! only kill natural PFTs
91: |
92: | IF ( natural(j) ) THEN
93: |
94: | ! kill present plants if number of individuals or last year's leaf
95: | ! mass is close to zero.
96: | ! the "was_killed" business is necessary for a more efficient code on the VPP
97: |
98: |V-----> WHERE ( PFTpresent(:,j) .AND. &
99: || ( ( ind(:,j) .LT. min_stomate ) .OR. &
100: || ( lm_lastyearmax(:,j) .LT. min_stomate ) ) )
101: ||
102: |V----- was_killed(:) = .TRUE.
103: |
104: | ENDWHERE
105: |
106: |V===== IF ( ANY( was_killed(:) ) ) THEN
107: |
108: |V-----> WHERE ( was_killed(:) )
109: ||
110: || ind(:,j) = 0.0
111: ||
112: || bm_to_litter(:,j,ileaf) = bm_to_litter(:,j,ileaf) + biomass(:,j,ileaf)
113: || bm_to_litter(:,j,isapabove) = bm_to_litter(:,j,isapabove) + biomass(:,j,isapabove)
114: || bm_to_litter(:,j,isapbelow) = bm_to_litter(:,j,isapbelow) + biomass(:,j,isapbelow)
115: || bm_to_litter(:,j,iheartabove) = bm_to_litter(:,j,iheartabove) + &
116: || biomass(:,j,iheartabove)
117: || bm_to_litter(:,j,iheartbelow) = bm_to_litter(:,j,iheartbelow) + &
118: || biomass(:,j,iheartbelow)
119: || bm_to_litter(:,j,iroot) = bm_to_litter(:,j,iroot) + biomass(:,j,iroot)
120: || bm_to_litter(:,j,ifruit) = bm_to_litter(:,j,ifruit) + biomass(:,j,ifruit)
121: || bm_to_litter(:,j,icarbres) = bm_to_litter(:,j,icarbres) + biomass(:,j,icarbres)
122: ||
123: || biomass(:,j,ileaf) = 0.0
124: || biomass(:,j,isapabove) = 0.0
125: || biomass(:,j,isapbelow) = 0.0
126: || biomass(:,j,iheartabove) = 0.0
127: || biomass(:,j,iheartbelow) = 0.0
128: || biomass(:,j,iroot) = 0.0
129: || biomass(:,j,ifruit) = 0.0
130: || biomass(:,j,icarbres) = 0.0
131: ||
132: || PFTpresent(:,j) = .FALSE.
133: ||
134: || cn_ind(:,j) = 0.0
135: ||
136: || senescence(:,j) = .FALSE.
137: ||
138: ||
139: || age(:,j) = 0.0
140: ||
141: || when_growthinit(:,j) = undef
142: ||
143: || everywhere(:,j) = 0.0
144: ||
145: || veget(:,j) = 0.0
146: ||
147: || veget_max(:,j) = 0.0
148: ||
149: |V----- RIP_time(:,j) = 0.0
150: |
151: | ENDWHERE ! number of individuals very low
152: |
153: |*-----> DO m = 1, nleafages
154: ||
155: ||V----> WHERE ( was_killed(:) )
156: |||
157: ||| leaf_age(:,j,m) = 0.0
158: ||V---- leaf_frac(:,j,m) = 0.0
159: ||
160: || ENDWHERE
161: ||
162: |*----- ENDDO
163: |
164: | IF ( bavard .GE. 2 ) THEN
165: |
166: | WRITE(numout,*) 'kill: eliminated ',PFT_name(j)
167: |V===== WRITE(numout,*) ' at ',COUNT( was_killed(:) ),' points after '//whichroutine
168: |
169: | ENDIF
170: |
171: | ENDIF ! PFT must be killed at at least one place
172: |
173: | ENDIF ! PFT is natural
174: |
175: +------ ENDDO ! loop over PFTs
176:
177: IF (bavard.GE.4) WRITE(numout,*) 'Leaving kill'
178:
179: END SUBROUTINE kill
180:
181: END MODULE lpj_kill
ORCHIDEE/src_stomate/i.lpj_light.L 0000754 0103600 0005670 00000062243 11164403473 016577 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:50 2008
FILE NAME: i.lpj_light.f90
PROGRAM NAME: lpj_light
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
165 vec ( 1): Vectorized loop.
177 vec ( 4): Vectorized array expression.
186 vec ( 4): Vectorized array expression.
196 vec ( 4): Vectorized array expression.
197 vec ( 3): Unvectorized loop.
198 vec ( 4): Vectorized array expression.
199 opt (1592): Outer loop unrolled inside inner loop.
205 opt (1592): Outer loop unrolled inside inner loop.
205 vec ( 4): Vectorized array expression.
222 vec ( 4): Vectorized array expression.
229 vec ( 4): Vectorized array expression.
242 vec ( 1): Vectorized loop.
254 vec ( 26): Macro operation Sum/InnerProd.
258 vec ( 26): Macro operation Sum/InnerProd.
262 opt (1019): Feedback of scalar value from one loop pass to another.
262 vec ( 26): Macro operation Max/Min.
276 vec ( 26): Macro operation Sum/InnerProd.
288 opt (1059): Unable to determine last value of scalar temporary.
303 vec ( 1): Vectorized loop.
387 vec ( 1): Vectorized loop.
421 vec ( 3): Unvectorized loop.
421 vec ( 13): Overhead of loop division is too large.
425 vec ( 4): Vectorized array expression.
462 vec ( 1): Vectorized loop.
474 vec ( 4): Vectorized array expression.
485 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:50 2008
FILE NAME: i.lpj_light.f90
PROGRAM NAME: lpj_light
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! Light competition
2: !
3: ! If canopy is almost closed (fpc > fpc_crit), then trees outcompete grasses.
4: ! fpc_crit is normally fpc_crit.
5: ! Here, fpc ("foilage protected cover") also takes into account the minimum fraction
6: ! of space covered by trees through branches etc. This is done to prevent strong relative
7: ! changes of fpc from one day to another for deciduous trees at the beginning of their
8: ! growing season, which would yield to strong cutbacks (see 3.2.1.1.2)
9: ! No competition between woody pfts (height of individuals is not considered) !
10: ! Exception: when one woody pft is overwhelming (i.e. fpc > fpc_crit). In that
11: ! case, eliminate all other woody pfts and reduce dominant pft to fpc_crit.
12: ! Age of individuals is not considered. In reality, light competition would more
13: ! easily kill young individuals, thus increasing the mean age of the stand.
14: ! Exclude agricultural pfts from competition
15: !
16: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_light.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
17: ! IPSL (2006)
18: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
19: !
20: MODULE lpj_light
21:
22: ! modules used:
23:
24: USE ioipsl
25: USE stomate_constants
26:
27: IMPLICIT NONE
28:
29: ! private & public routines
30:
31: PRIVATE
32: PUBLIC light, light_clear
33:
34: ! first call
35: LOGICAL, SAVE :: firstcall = .TRUE.
36:
37: CONTAINS
38:
39: SUBROUTINE light_clear
40: firstcall=.TRUE.
41: END SUBROUTINE light_clear
42:
43: SUBROUTINE light (npts, dt, &
44: PFTpresent, cn_ind, lai, maxfpc_lastyear, &
45: ind, biomass, veget_lastlight, bm_to_litter)
46:
47: !
48: ! 0 declarations
49: !
50:
51: ! 0.1 input
52:
53: ! Domain size
54: INTEGER(i_std), INTENT(in) :: npts
55: ! Time step (days)
56: REAL(r_std), INTENT(in) :: dt
57: ! Is pft there
58: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
59: ! crown area of individuals (m**2)
60: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: cn_ind
61: ! leaf area index OF AN INDIVIDUAL PLANT
62: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
63: ! last year's maximum fpc for each natural PFT, on *natural* ground
64: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxfpc_lastyear
65:
66: ! 0.2 modified fields
67:
68: ! Number of individuals / m2
69: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
70: ! biomass (gC/(m**2 of nat/agri ground))
71: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
72: ! Vegetation cover after last light competition
73: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_lastlight
74: ! biomass taken away (gC/m**2)
75: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
76:
77: ! 0.3 local
78:
79: ! maximum total number of grass individuals in a closed canopy
80: REAL(r_std), PARAMETER :: grass_mercy = 0.01
81: ! minimum fraction of trees that survive even in a closed canopy
82: REAL(r_std), PARAMETER :: tree_mercy = 0.01
83: ! for diagnosis of fpc increase, compare today's fpc to last year's maximum (T) or
84: ! to fpc of last time step (F)?
85: LOGICAL, PARAMETER :: annual_increase = .TRUE.
86: ! index
87: INTEGER(i_std) :: i,j
88: ! total natural fpc
89: REAL(r_std), DIMENSION(npts) :: sumfpc
90: ! total natural woody fpc
91: REAL(r_std) :: sumfpc_wood
92: ! change in total woody fpc
93: REAL(r_std) :: sumdelta_fpc_wood
94: ! maximum wood fpc
95: REAL(r_std) :: maxfpc_wood
96: ! which woody pft is maximum
97: INTEGER(i_std) :: optpft_wood
98: ! total natural grass fpc
99: REAL(r_std) :: sumfpc_grass
100: ! this year's foliage protected cover on natural part of the grid cell
101: REAL(r_std), DIMENSION(npts,npft) :: fpc_nat
102: ! fpc change within last year
103: REAL(r_std), DIMENSION(npft) :: deltafpc
104: ! Relative change of number of individuals for trees
105: REAL(r_std) :: reduct
106: ! Fraction of plants that survive
107: REAL(r_std), DIMENSION(npft) :: survive
108: ! number of grass PFTs present in the grid box
109: INTEGER(i_std) :: num_grass
110: ! New total grass fpc
111: REAL(r_std) :: sumfpc_grass2
112: ! fraction of plants that dies each day (1/day)
113: REAL(r_std), DIMENSION(npts,npft) :: light_death
114:
115: ! =========================================================================
116:
117: IF (bavard.GE.3) WRITE(numout,*) 'Entering light'
118:
119: !
120: ! 1 first call
121: !
122:
123: IF ( firstcall ) THEN
124:
125: WRITE(numout,*) 'light:'
126:
127: WRITE(numout,*) ' > Maximum total number of grass individuals in'
128: WRITE(numout,*) ' a closed canopy: ', grass_mercy
129:
130: WRITE(numout,*) ' > Minimum fraction of trees that survive even in'
131: WRITE(numout,*) ' a closed canopy: ', tree_mercy
132:
133: WRITE(numout,*) ' > For trees, minimum fraction of crown area covered'
134: WRITE(numout,*) ' (due to its branches etc.)', min_cover
135:
136: WRITE(numout,*) ' > for diagnosis of fpc increase, compare today''s fpc'
137: IF ( annual_increase ) THEN
138: WRITE(numout,*) ' to last year''s maximum.'
139: ELSE
140: WRITE(numout,*) ' to fpc of the last time step.'
141: ENDIF
142:
143: firstcall = .FALSE.
144:
145: ENDIF
146:
147: !
148: ! 2 fpc characteristics
149: !
150:
151: !
152: ! 2.1 calculate fpc on natural part of grid cell.
153: !
154:
155: +------> DO j = 1, npft
156: |
157: | IF ( natural(j) ) THEN
158: |
159: | ! 2.1.1 natural PFTs
160: |
161: | IF ( tree(j) ) THEN
162: |
163: | ! 2.1.1.1 trees: minimum cover due to stems, branches etc.
164: |
165: |V-----> DO i = 1, npts
166: ||
167: || fpc_nat(i,j) = &
168: || cn_ind(i,j) * ind(i,j) * &
169: || MAX( ( 1._r_std - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover )
170: ||
171: |V----- ENDDO
172: |
173: | ELSE
174: |
175: | ! 2.1.1.2 grasses
176: |
177: |V===== fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) * &
178: | ( 1. - exp( -lai(:,j) * ext_coeff(j) ) )
179: |
180: | ENDIF ! tree/grass
181: |
182: | ELSE
183: |
184: | ! 2.1.2 agricultural PFTs: not present on natural part
185: |
186: |V===== fpc_nat(:,j) = 0.0
187: |
188: | ENDIF ! natural/agricultural
189: |
190: +------ ENDDO
191:
192: !
193: ! 2.2 sum natural fpc for every grid point
194: !
195:
196: V====== sumfpc(:) = zero
197: +------> DO j = 1, npft
198: |V===== sumfpc(:) = sumfpc(:) + fpc_nat(:,j)
199: +------ ENDDO
200:
201: !
202: ! 3 Light competition
203: !
204:
205: +V===== light_death(:,:) = 0.0
206:
207: +------> DO i = 1, npts
208: |
209: | ! Only if vegetation cover is dense
210: |
211: | IF ( sumfpc(i) .GT. fpc_crit ) THEN
212: |
213: | ! fpc change for each pft
214: | ! There are two possibilities: either we compare today's fpc with the fpc after the last
215: | ! time step, or we compare it to last year's maximum fpc of that PFT. In the first case,
216: | ! the fpc increase will be strong for seasonal PFTs at the beginning of the growing season.
217: | ! As for trees, the cutback is proportional to this increase, this means that seasonal trees
218: | ! will be disadvantaged compared to evergreen trees. In the original LPJ model, with its
219: | ! annual time step, the second method was used (this corresponds to annual_increase=.TRUE.)
220: |
221: | IF ( annual_increase ) THEN
222: |V===== deltafpc(:) = MAX( (fpc_nat(i,:)-maxfpc_lastyear(i,:)), 0._r_std )
223: | ELSE
224: |+===== deltafpc(:) = MAX( (fpc_nat(i,:)-veget_lastlight(i,:)), 0._r_std )
225: | ENDIF
226: |
227: | ! default: survive
228: |
229: |V===== survive(:) = 1.0
230: |
231: | !
232: | ! 3.1 determine some characteristics of the fpc distribution
233: | !
234: |
235: | sumfpc_wood = 0.0
236: | sumdelta_fpc_wood = 0.0
237: | maxfpc_wood = 0.0
238: | optpft_wood = 0
239: | sumfpc_grass = 0.0
240: | num_grass = 0
241: |
242: |V-----> DO j = 1, npft
243: ||
244: || ! only natural pfts
245: ||
246: || IF ( natural(j) ) THEN
247: ||
248: || IF ( tree(j) ) THEN
249: ||
250: || ! trees
251: ||
252: || ! total woody fpc
253: ||
254: || sumfpc_wood = sumfpc_wood + fpc_nat(i,j)
255: ||
256: || ! how much did the woody fpc increase
257: ||
258: || sumdelta_fpc_wood = sumdelta_fpc_wood + deltafpc(j)
259: ||
260: || ! which woody pft is preponderant
261: ||
262: || IF ( fpc_nat(i,j) .GT. maxfpc_wood ) THEN
263: ||
264: || optpft_wood = j
265: ||
266: || maxfpc_wood = fpc_nat(i,j)
267: ||
268: || ENDIF
269: ||
270: || ELSE
271: ||
272: || ! grasses
273: ||
274: || ! total (natural) grass fpc
275: ||
276: || sumfpc_grass = sumfpc_grass + fpc_nat(i,j)
277: ||
278: || ! number of grass PFTs present in the grid box
279: ||
280: || IF ( PFTpresent(i,j) ) THEN
281: || num_grass = num_grass + 1
282: || ENDIF
283: ||
284: || ENDIF ! tree or grass
285: ||
286: || ENDIF ! natural
287: ||
288: |V----- ENDDO ! loop over pfts
289: |
290: | !
291: | ! 3.2 light competition: assume wood outcompetes grass
292: | !
293: |
294: | IF (sumfpc_wood .GE. fpc_crit ) THEN
295: |
296: | !
297: | ! 3.2.1 all allowed natural space is covered by wood:
298: | ! cut back trees to fpc_crit.
299: | ! Original DGVM: kill grasses. Modified: we let a very
300: | ! small fraction of grasses survive.
301: | !
302: |
303: |V-----> DO j = 1, npft
304: ||
305: || ! only present and natural pfts compete
306: ||
307: || IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
308: ||
309: || IF ( tree(j) ) THEN
310: ||
311: || !
312: || ! 3.2.1.1 tree
313: || !
314: ||
315: || IF ( maxfpc_wood .GE. fpc_crit ) THEN
316: ||
317: || ! 3.2.1.1.1 one single woody pft is overwhelming
318: ||
319: || IF ( j .eq. optpft_wood ) THEN
320: ||
321: || ! reduction for this dominant pft
322: ||
323: || reduct = 1. - fpc_crit / fpc_nat(i,j)
324: ||
325: || ELSE
326: ||
327: || ! strongly reduce all other woody pfts
328: || ! (original DGVM: tree_mercy = 0.0 )
329: ||
330: || reduct = 1. - tree_mercy
331: ||
332: || ENDIF ! pft = dominant woody pft
333: ||
334: || ELSE
335: ||
336: || ! 3.2.1.1.2 no single woody pft is overwhelming
337: || ! (original DGVM: tree_mercy = 0.0 )
338: || ! The reduction rate is proportional to the ratio deltafpc/fpc.
339: ||
340: || IF ( fpc_nat(i,j) .GE. min_stomate ) THEN
341: ||
342: || reduct = MIN( ( ( deltafpc(j)/sumdelta_fpc_wood * &
343: || (sumfpc_wood-fpc_crit) ) / fpc_nat(i,j) ), &
344: || ( 1._r_std - tree_mercy ) )
345: ||
346: || ELSE
347: ||
348: || ! tree fpc didn't icrease or it started from nothing
349: ||
350: || reduct = 0.
351: ||
352: || ENDIF
353: ||
354: || ENDIF ! maxfpc_wood > fpc_crit
355: ||
356: || survive(j) = 1. - reduct
357: ||
358: || ELSE
359: ||
360: || !
361: || ! 3.2.1.2 grass: let a very small fraction survive (the sum of all
362: || ! grass individuals may make up a maximum cover of
363: || ! grass_mercy [for lai -> infinity]).
364: || ! In the original DGVM, grasses were killed in that case,
365: || ! corresponding to grass_mercy = 0.
366: || !
367: ||
368: || survive(j) = ( grass_mercy / REAL( num_grass,r_std ) ) / ind(i,j)
369: ||
370: || survive(j) = MIN( 1._r_std, survive(j) )
371: ||
372: || ENDIF ! tree or grass
373: ||
374: || ENDIF ! pft there and natural
375: ||
376: |V----- ENDDO ! loop over pfts
377: |
378: | ELSE
379: |
380: | !
381: | ! 3.2.2 not too much wood so that grasses can subsist
382: | !
383: |
384: | ! new total grass fpc
385: | sumfpc_grass2 = fpc_crit - sumfpc_wood
386: |
387: |V-----> DO j = 1, npft
388: ||
389: || ! only present and natural PFTs compete
390: ||
391: || IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
392: ||
393: || IF ( tree(j) ) THEN
394: ||
395: || ! no change for trees
396: ||
397: || survive(j) = 1.0
398: ||
399: || ELSE
400: ||
401: || ! grass: fractional loss is the same for all grasses
402: ||
403: || IF ( sumfpc_grass .GT. min_stomate ) THEN
404: || survive(j) = sumfpc_grass2 / sumfpc_grass
405: || ELSE
406: || survive(j)= 0.0
407: || ENDIF
408: ||
409: || ENDIF
410: ||
411: || ENDIF ! pft there and natural
412: ||
413: |V----- ENDDO ! loop over pfts
414: |
415: | ENDIF ! sumfpc_wood > fpc_crit
416: |
417: | !
418: | ! 3.3 update output variables
419: | !
420: |
421: |+-----> DO j = 1, npft
422: ||
423: || IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
424: ||
425: ||V----> bm_to_litter(i,j,:) = bm_to_litter(i,j,:) + &
426: ||| biomass(i,j,:) * ( 1. - survive(j) )
427: |||
428: ||V---- biomass(i,j,:) = biomass(i,j,:) * survive(j)
429: ||
430: || IF ( control%ok_dgvm ) THEN
431: || ind(i,j) = ind(i,j) * survive(j)
432: || ENDIF
433: ||
434: || ! fraction of plants that dies each day.
435: || ! exact formulation: light_death(i,j) = 1. - survive(j) ** (1/dt)
436: || light_death(i,j) = ( 1. - survive(j) ) / dt
437: ||
438: || ENDIF ! pft there and natural
439: ||
440: |+----- ENDDO ! loop over pfts
441: |
442: | ENDIF ! sumfpc > fpc_crit
443: |
444: +------ ENDDO ! loop over grid points
445:
446: !
447: ! 4 recalculate fpc on natural part of grid cell (for next light competition)
448: !
449:
450: +------> DO j = 1, npft
451: |
452: | IF ( natural(j) ) THEN
453: |
454: | !
455: | ! 4.1 natural PFTs
456: | !
457: |
458: | IF ( tree(j) ) THEN
459: |
460: | ! 4.1.1 trees: minimum cover due to stems, branches etc.
461: |
462: |V-----> DO i = 1, npts
463: ||
464: || veget_lastlight(i,j) = &
465: || cn_ind(i,j) * ind(i,j) * &
466: || MAX( ( 1._r_std - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover )
467: ||
468: |V----- ENDDO
469: |
470: | ELSE
471: |
472: | ! 4.1.2 grasses
473: |
474: |V===== veget_lastlight(:,j) = &
475: | cn_ind(:,j) * ind(:,j) * ( 1. - exp( -lai(:,j) * ext_coeff(j) ) )
476: |
477: | ENDIF ! tree/grass
478: |
479: | ELSE
480: |
481: | !
482: | ! 4.2 agricultural PFTs: not present on natural part
483: | !
484: |
485: |V===== veget_lastlight(:,j) = 0.0
486: |
487: | ENDIF ! natural/agricultural
488: |
489: +------ ENDDO
490:
491: !
492: ! 5 history
493: !
494:
495: CALL histwrite (hist_id_stomate, 'LIGHT_DEATH', itime, &
496: light_death, npts*npft, horipft_index)
497:
498: IF (bavard.GE.4) WRITE(numout,*) 'Leaving light'
499:
500: END SUBROUTINE light
501:
502: END MODULE lpj_light
ORCHIDEE/src_stomate/i.lpj_pftinout.L 0000754 0103600 0005670 00000054616 11164403473 017345 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:51 2008
FILE NAME: i.lpj_pftinout.f90
PROGRAM NAME: lpj_pftinout
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
137 vec ( 4): Vectorized array expression.
139 vec ( 3): Unvectorized loop.
139 vec ( 13): Overhead of loop division is too large.
143 vec ( 4): Vectorized array expression.
149 vec ( 4): Vectorized array expression.
157 opt (1593): Loop nest collapsed into one loop.
157 vec ( 4): Vectorized array expression.
184 vec ( 3): Unvectorized loop.
184 vec ( 13): Overhead of loop division is too large.
192 vec ( 4): Vectorized array expression.
194 vec ( 4): Vectorized array expression.
194 vec ( 26): Macro operation Sum/InnerProd.
219 vec ( 3): Unvectorized loop.
219 vec ( 13): Overhead of loop division is too large.
225 vec ( 4): Vectorized array expression.
249 vec ( 4): Vectorized array expression.
251 vec ( 4): Vectorized array expression.
258 vec ( 4): Vectorized array expression.
260 vec ( 1): Vectorized loop.
324 vec ( 4): Vectorized array expression.
339 opt (1082): Backward transfers inhibit loop optimization.
339 vec ( 4): Vectorized array expression.
389 opt (1082): Backward transfers inhibit loop optimization.
389 vec ( 4): Vectorized array expression.
398 opt (1082): Backward transfers inhibit loop optimization.
398 vec ( 4): Vectorized array expression.
415 opt (1593): Loop nest collapsed into one loop.
415 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:51 2008
FILE NAME: i.lpj_pftinout.f90
PROGRAM NAME: lpj_pftinout
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! throw out respectively introduce some PFTS
2: !
3: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_pftinout.f90,v 1.7 2007/05/28 14:49:02 ssipsl Exp $
4: ! IPSL (2006)
5: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
6: !
7: MODULE lpj_pftinout
8:
9: ! modules used:
10:
11: USE ioipsl
12: USE stomate_constants
13:
14: IMPLICIT NONE
15:
16: ! private & public routines
17:
18: PRIVATE
19: PUBLIC pftinout,pftinout_clear
20:
21: ! first call
22: LOGICAL, SAVE :: firstcall = .TRUE.
23:
24: CONTAINS
25:
26:
27: SUBROUTINE pftinout_clear
28: firstcall = .TRUE.
29: END SUBROUTINE pftinout_clear
30:
31: SUBROUTINE pftinout (npts, dt, adapted, regenerate, &
32: neighbours, space_nat, veget, veget_max, &
33: biomass, ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, &
34: PFTpresent, everywhere, when_growthinit, need_adjacent, RIP_time, &
35: co2_to_bm, &
36: avail_tree, avail_grass)
37:
38: !
39: ! 0 declarations
40: !
41:
42: ! 0.1 input
43:
44: ! Domain size
45: INTEGER(i_std), INTENT(in) :: npts
46: ! Time step (days)
47: REAL(r_std), INTENT(in) :: dt
48: ! Winter not too cold
49: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: adapted
50: ! Winter sufficiently cold
51: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: regenerate
52: ! indices of the 8 neighbours of each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
53: INTEGER(i_std), DIMENSION(npts,8), INTENT(in) :: neighbours
54: ! total natural space (fraction of total space)
55: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
56: ! fractional coverage on natural/agricultural ground, taking into
57: ! account LAI (=grid-scale fpc)
58: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
59: ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
60: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
61:
62: ! 0.2 modified fields
63:
64: ! biomass (gC/(m**2 of nat/agri ground))
65: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
66: ! density of individuals 1/m**2
67: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
68: ! mean age (years)
69: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
70: ! fraction of leaves in leaf age class
71: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
72: ! "long term" net primary productivity (gC/(m**2 of nat/agri ground)/year)
73: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: npp_longterm
74: ! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
75: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_lastyearmax
76: ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
77: ! set to .FALSE. if PFT is introduced or killed
78: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: senescence
79: ! PFT exists
80: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
81: ! is the PFT everywhere in the grid box or very localized (after its introduction)
82: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
83: ! how many days ago was the beginning of the growing season
84: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
85: ! in order for this PFT to be introduced, does it have to be present in an
86: ! adjacent grid box?
87: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: need_adjacent
88: ! How much time ago was the PFT eliminated for the last time (y)
89: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: RIP_time
90: ! biomass uptaken (gC/(m**2 of total ground)/day)
91: REAL(r_std), DIMENSION(npts), INTENT(inout) :: co2_to_bm
92:
93: ! 0.3 output
94:
95: ! space availability for trees on natural ground
96: REAL(r_std), DIMENSION(npts), INTENT(out) :: avail_tree
97: ! space availability for grasses on natural ground
98: REAL(r_std), DIMENSION(npts), INTENT(out) :: avail_grass
99:
100: ! 0.4 local
101:
102: ! minimum availability
103: REAL(r_std), PARAMETER :: min_avail = 0.01
104: ! availability
105: REAL(r_std), DIMENSION(npts) :: avail
106: ! indices
107: INTEGER(i_std) :: i,j
108: ! total woody vegetation cover or natural ground
109: REAL(r_std), DIMENSION(npts) :: sumfrac_wood
110: ! number of adjacent grid cells where PFT is ubiquitious
111: INTEGER(i_std), DIMENSION(npts) :: n_present
112: ! we can introduce this PFT
113: LOGICAL, DIMENSION(npts) :: can_introduce
114:
115: ! =========================================================================
116:
117: IF (bavard.GE.3) WRITE(numout,*) 'Entering pftinout'
118:
119: !
120: ! 1 Messages
121: !
122:
123: IF ( firstcall ) THEN
124:
125: WRITE(numout,*) 'pftinout: Minimum space availability: ', min_avail
126:
127: firstcall = .FALSE.
128:
129: ENDIF
130:
131: !
132: ! 2 Space availability
133: !
134:
135: ! need to know total woody vegetation fraction
136:
137: V====== sumfrac_wood(:) = 0.0
138:
139: +------> DO j = 1, npft
140: |
141: | IF ( tree(j) ) THEN
142: |
143: |V===== sumfrac_wood(:) = sumfrac_wood(:) + veget(:,j)
144: |
145: | ENDIF
146: |
147: +------ ENDDO
148:
149: V------> avail_grass(:) = MAX( ( 1._r_std - sumfrac_wood(:) ), min_avail )
150: |
151: V------ avail_tree(:) = MAX( ( fpc_crit - sumfrac_wood(:) ), min_avail )
152:
153: !
154: ! 3 Time since last elimination (y)
155: !
156:
157: W*===== RIP_time = RIP_time + dt / one_year
158:
159: !
160: ! 4 Agicultural PFTs: present if they are prescribed
161: !
162:
163: +------> DO j = 1, npft
164: |
165: | IF ( .NOT. natural(j) ) THEN
166: |
167: | IF (bavard.GE.4) WRITE(numout,*) 'pftinout: Agricultural PFTs'
168: |
169: | IF ( tree(j) ) THEN
170: |
171: | !
172: | ! 4.1 don't treat agricultural trees for the moment
173: | !
174: |
175: | WRITE(numout,*) 'pftinout: Agricultural trees not treated. We stop.'
176: | STOP
177: |
178: | ELSE
179: |
180: | !
181: | ! 4.2 grasses
182: | !
183: |
184: |+-----> DO i = 1, npts
185: ||
186: || IF ( ( veget_max(i,j) .GT. 0.0 ) .AND. ( .NOT. PFTpresent(i,j) ) ) THEN
187: ||
188: || ! prescribed, but not yet there.
189: ||
190: || ind(i,j) = veget_max(i,j)
191: ||
192: ||V==== biomass(i,j,:) = bm_sapl(j,:) * ind(i,j)
193: ||
194: ||V==== co2_to_bm(i) = co2_to_bm(i) + &
195: || SUM( biomass(i,j,:) ) * ( 1. - space_nat(i) ) / dt
196: ||
197: || PFTpresent(i,j) = .TRUE.
198: ||
199: || everywhere(i,j) = 1.
200: ||
201: || senescence(i,j) = .FALSE.
202: ||
203: || age(i,j) = 0.
204: ||
205: || ENDIF ! prescribed, but PFT not yet present
206: ||
207: |+----- ENDDO ! loop over grid points
208: |
209: | ENDIF
210: |
211: | ENDIF ! not natural
212: |
213: +------ ENDDO ! loop over PFTs
214:
215: !
216: ! 5 Eliminate PFTs
217: !
218:
219: +------> DO j = 1, npft
220: |
221: | ! only for natural PFTs
222: |
223: | IF ( natural(j) ) THEN
224: |
225: |V-----> WHERE ( PFTpresent(:,j) .AND. ( adapted(:,j) .LT. adapted_crit ) )
226: ||
227: || ! PFT there, but not adapted any more (ex: winter too cold): kill
228: || ! set number of individuals to zero - rest will be done in lpj_kill
229: ||
230: |V----- ind(:,j) = 0.0
231: |
232: | ENDWHERE
233: |
234: | ENDIF ! natural
235: |
236: +------ ENDDO ! loop over PFTs
237:
238: !
239: ! 6 Introduce PFTs
240: !
241:
242: +------> DO j = 1, npft
243: |
244: | IF ( natural(j) ) THEN
245: |
246: | ! space availability for this PFT
247: |
248: | IF ( tree(j) ) THEN
249: |V===== avail(:) = avail_tree(:)
250: | ELSE
251: |V===== avail(:) = avail_grass(:)
252: | ENDIF
253: |
254: | !
255: | ! 6.1 Check if PFT not present but (adapted and regenerative)
256: | !
257: |
258: |V===== can_introduce(:) = .FALSE.
259: |
260: |V-----> DO i = 1, npts
261: ||
262: || IF ( .NOT. PFTpresent(i,j) .AND. &
263: || ( adapted(i,j) .GT. adapted_crit ) .AND. &
264: || ( regenerate(i,j) .GT. regenerate_crit ) ) THEN
265: ||
266: || ! climate allows introduction
267: ||
268: || IF ( need_adjacent(i,j) ) THEN
269: ||
270: || ! 6.1.1 climate allows introduction, but we need to look at the neighbours
271: || ! If the PFT has totally invaded at least one adjacent
272: || ! grid cell, it can be introduced.
273: ||
274: || ! count number of totally invaded neighbours
275: || ! no loop so that it can vectorize
276: ||
277: || n_present(i) = 0
278: ||
279: || IF ( neighbours(i,1) .GT. 0 ) THEN
280: || IF ( everywhere(neighbours(i,1),j) .GE. 1.-min_stomate ) THEN
281: || n_present(i) = n_present(i)+1
282: || ENDIF
283: || ENDIF
284: || IF ( neighbours(i,3) .GT. 0 ) THEN
285: || IF ( everywhere(neighbours(i,3),j) .GE. 1.-min_stomate ) THEN
286: || n_present(i) = n_present(i)+1
287: || ENDIF
288: || ENDIF
289: || IF ( neighbours(i,5) .GT. 0 ) THEN
290: || IF ( everywhere(neighbours(i,5),j) .GE. 1.-min_stomate ) THEN
291: || n_present(i) = n_present(i)+1
292: || ENDIF
293: || ENDIF
294: || IF ( neighbours(i,7) .GT. 0 ) THEN
295: || IF ( everywhere(neighbours(i,7),j) .GE. 1.-min_stomate ) THEN
296: || n_present(i) = n_present(i)+1
297: || ENDIF
298: || ENDIF
299: ||
300: || IF ( n_present(i) .GT. 0 ) THEN
301: ||
302: || ! PFT is ubiquitious in at least one adjacent grid box
303: || can_introduce(i) = .TRUE.
304: ||
305: || ENDIF
306: ||
307: || ELSE
308: ||
309: || ! 6.1.2 we don't have to look at neighbours
310: ||
311: || can_introduce(i) = .TRUE.
312: ||
313: || ENDIF ! do we have to look at the neighbours?
314: ||
315: || ENDIF ! we'd like to introduce the PFT
316: ||
317: |V----- ENDDO ! loop over grid points
318: |
319: | !
320: | ! 6.2 additionally test whether the PFT has been eliminated lately, i.e.
321: | ! less than 1.25 years ago. Do not take full years as success of
322: | ! introduction might depend on season.
323: |
324: |V-----> WHERE ( RIP_time(:,j) .LT. 1.25 )
325: ||
326: || ! PFT was eliminated lately - cannot reintroduce
327: ||
328: |V----- can_introduce(:) = .FALSE.
329: |
330: | ENDWHERE
331: |
332: | !
333: | ! 6.3 Introduce that PFT where possible
334: | ! "can_introduce" means that it either exists in neighbouring grid boxes
335: | ! or that we do not look at neighbours, that it has not been eliminated
336: | ! lately, and, of course, that the climate is good for that PFT.
337: | !
338: |
339: |V-----> WHERE ( can_introduce(:) )
340: ||
341: || PFTpresent(:,j) = .TRUE.
342: ||
343: || senescence(:,j) = .FALSE.
344: ||
345: || ! introduce at least a few saplings, even if canopy is closed
346: ||
347: || ind(:,j) = ind_0 * (dt/one_year) * avail(:)
348: ||
349: ||
350: || biomass(:,j,ileaf) = bm_sapl(j,ileaf) * ind(:,j)
351: || biomass(:,j,isapabove) = bm_sapl(j,isapabove) * ind(:,j)
352: || biomass(:,j,isapbelow) = bm_sapl(j,isapbelow) * ind(:,j)
353: || biomass(:,j,iheartabove) = bm_sapl(j,iheartabove) * ind(:,j)
354: || biomass(:,j,iheartbelow) = bm_sapl(j,iheartbelow) * ind(:,j)
355: || biomass(:,j,iroot) = bm_sapl(j,iroot) * ind(:,j)
356: || biomass(:,j,ifruit) = bm_sapl(j,ifruit) * ind(:,j)
357: || biomass(:,j,icarbres) = bm_sapl(j,icarbres) * ind(:,j)
358: ||
359: || co2_to_bm(:) = &
360: || co2_to_bm(:) + space_nat(:) / dt * &
361: || ( biomass(:,j,ileaf) + biomass(:,j,isapabove) + &
362: || biomass(:,j,isapbelow) + biomass(:,j,iheartabove) + &
363: || biomass(:,j,iheartbelow) + biomass(:,j,iroot) + &
364: || biomass(:,j,ifruit) + biomass(:,j,icarbres) )
365: ||
366: || when_growthinit(:,j) = large_value
367: ||
368: || age(:,j) = 0.0
369: ||
370: || ! all leaves are young
371: || leaf_frac(:,j,1) = 1.0
372: ||
373: || ! non-zero "long term" npp and last year's leaf mass for saplings -
374: || ! so they won't be killed off by gap or kill
375: ||
376: || npp_longterm(:,j) = 10.
377: ||
378: |V----- lm_lastyearmax(:,j) = bm_sapl(j,ileaf) * ind(:,j)
379: |
380: | ENDWHERE ! we can introduce the PFT
381: |
382: | !
383: | ! 6.4 expansion of the PFT within the grid box (not to be confused with areal
384: | ! coverage)
385: | !
386: |
387: | IF ( treat_expansion ) THEN
388: |
389: |V-----> WHERE ( can_introduce(:) )
390: || ! low value at the beginning
391: |V----- everywhere(:,j) = 0.05
392: | ENDWHERE
393: |
394: | ELSE
395: |
396: | ! expansion is not treated
397: |
398: |V-----> WHERE ( can_introduce(:) )
399: |V----- everywhere(:,j) = 1.
400: | ENDWHERE
401: |
402: | ENDIF ! treat expansion
403: |
404: | ENDIF ! only natural PFTs
405: |
406: +------ ENDDO ! loop over PFTs
407:
408: !
409: ! 7 If a PFT has been present once in a grid box, we suppose that it will survive
410: ! in isolated places (e.g., an oasis) within that grid box, even if it gets
411: ! officially eliminated from it later. That means that if climate becomes favorable
412: ! again, it will not need to get seeds from adjacent grid cells.
413: !
414:
415: *W-----> WHERE ( PFTpresent )
416: *W----- need_adjacent = .FALSE.
417: ENDWHERE
418:
419: IF (bavard.GE.4) WRITE(numout,*) 'Leaving pftinout'
420:
421: END SUBROUTINE pftinout
422:
423: END MODULE lpj_pftinout
ORCHIDEE/src_stomate/i.stomate_alloc.L 0000754 0103600 0005670 00000100516 11164403473 017445 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:52 2008
FILE NAME: i.stomate_alloc.f90
PROGRAM NAME: stomate_alloc
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
183 vec ( 4): Vectorized array expression.
189 ext ( 91): Format item that is not permitted by standard is used. (PT=20)
190 ext ( 91): Format item that is not permitted by standard is used. (PT=43)
222 opt (1593): Loop nest collapsed into one loop.
222 vec ( 4): Vectorized array expression.
223 opt (1593): Loop nest collapsed into one loop.
223 vec ( 4): Vectorized array expression.
232 vec ( 4): Vectorized array expression.
238 vec ( 3): Unvectorized loop.
238 vec ( 3): Unvectorized loop.
240 opt (1592): Outer loop unrolled inside inner loop.
240 vec ( 4): Vectorized array expression.
240 vec ( 4): Vectorized array expression.
249 vec ( 4): Vectorized array expression.
255 vec ( 3): Unvectorized loop.
255 vec ( 3): Unvectorized loop.
257 opt (1592): Outer loop unrolled inside inner loop.
257 vec ( 4): Vectorized array expression.
257 vec ( 4): Vectorized array expression.
271 vec ( 4): Vectorized array expression.
274 vec ( 3): Unvectorized loop.
274 vec ( 13): Overhead of loop division is too large.
277 vec ( 4): Vectorized array expression.
279 vec ( 4): Vectorized array expression.
283 vec ( 4): Vectorized array expression.
290 vec ( 3): Unvectorized loop.
290 vec ( 13): Overhead of loop division is too large.
293 vec ( 4): Vectorized array expression.
295 vec ( 4): Vectorized array expression.
304 vec ( 4): Vectorized array expression.
314 opt (1592): Outer loop unrolled inside inner loop.
314 vec ( 4): Vectorized array expression.
316 vec ( 2): Partially vectorized loop.
316 vec ( 25): Work vectors are used. Size=288byte
334 opt (1082): Backward transfers inhibit loop optimization.
334 vec ( 4): Vectorized array expression.
353 opt (1082): Backward transfers inhibit loop optimization.
367 vec ( 4): Vectorized array expression.
369 opt (1082): Backward transfers inhibit loop optimization.
369 vec ( 4): Vectorized array expression.
380 vec ( 4): Vectorized array expression.
390 vec ( 4): Vectorized array expression.
390 vec ( 4): Vectorized array expression.
390 vec ( 4): Vectorized array expression.
408 vec ( 4): Vectorized array expression.
421 vec ( 4): Vectorized array expression.
489 vec ( 4): Vectorized array expression.
501 vec ( 1): Vectorized loop.
557 warn ( 82): Name "zdiff_min" is not used.
557 warn ( 83): Dummy argument "rprof" is not used.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:52 2008
FILE NAME: i.stomate_alloc.f90
PROGRAM NAME: stomate_alloc
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! allocation to the roots, stems, leaves, "fruits" and carbohydrate reserve.
2: ! Reproduction: for the moment, this is simply a 10% "tax".
3: ! This should depend on the limitations that the plant experiences. If the
4: ! plant fares well, it will have fruits. However, this means that we should
5: ! also "reward" the plants for having grown fruits by making the
6: ! reproduction rate depend on the fruit growth of the past years. Otherwise,
7: ! the fruit allocation would be a punishment for plants that are doing well.
8: ! "calculates" root profiles (in fact, prescribes it for the moment).
9: !
10: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_alloc.f90,v 1.9 2007/05/28 14:49:02 ssipsl Exp $
11: ! IPSL (2006)
12: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
13: !
14: MODULE stomate_alloc
15:
16: ! modules used:
17:
18: USE ioipsl
19: USE stomate_constants
20:
21: IMPLICIT NONE
22:
23: ! private & public routines
24:
25: PRIVATE
26: PUBLIC alloc,alloc_clear
27:
28: ! first call
29: LOGICAL, SAVE :: firstcall = .TRUE.
30: CONTAINS
31: SUBROUTINE alloc_clear
32: firstcall = .TRUE.
33: END SUBROUTINE alloc_clear
34:
35: SUBROUTINE alloc (npts, dt, &
36: lai, veget_max, senescence, when_growthinit, &
37: moiavail_week, tsoil_month, soilhum_month, &
38: biomass, leaf_age, leaf_frac, rprof, f_alloc)
39:
40: !
41: ! 0 declarations
42: !
43:
44: ! 0.1 input
45:
46: ! Domain size
47: INTEGER(i_std), INTENT(in) :: npts
48: ! time step (days)
49: REAL(r_std), INTENT(in) :: dt
50: ! Leaf area index
51: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
52: ! "maximal" coverage fraction of a PFT ( = ind*cn_ind )
53: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
54: ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
55: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: senescence
56: ! how many days ago was the beginning of the growing season
57: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: when_growthinit
58: ! "weekly" moisture availability
59: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
60: ! "monthly" soil temperature (K)
61: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil_month
62: ! "monthly" soil humidity
63: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum_month
64:
65: ! 0.2 modified fields
66:
67: ! biomass (gC/m**2)
68: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
69: ! leaf age (days)
70: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
71: ! fraction of leaves in leaf age class
72: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
73:
74: ! 0.3 output
75:
76: ! root depth. This will, one day, be a prognostic variable. It will be calculated by
77: ! STOMATE (save in restart file & give to hydrology module!). For the moment, it
78: ! is prescribed.
79: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: rprof
80: ! fraction that goes into plant part
81: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: f_alloc
82:
83: ! 0.4 local
84:
85: ! Do we try to reach a minimum reservoir even if we are severely stressed?
86: LOGICAL, PARAMETER :: ok_minres = .TRUE.
87: ! time (d) to attain the initial foliage using the carbohydrate reserve
88: REAL(r_std), PARAMETER :: tau_leafinit = 30.
89: ! maximum time (d) during which reserve is used (trees)
90: REAL(r_std), PARAMETER :: reserve_time_tree = 60.
91: ! maximum time (d) during which reserve is used (grasses)
92: REAL(r_std), PARAMETER :: reserve_time_grass = 30.
93: ! Standard root allocation
94: REAL(r_std), PARAMETER :: R0 = 0.3
95: ! Standard sapwood allocation
96: REAL(r_std), PARAMETER :: S0 = 0.3
97: ! Standard leaf allocation
98: REAL(r_std), PARAMETER :: L0 = 1. - R0 - S0
99: ! Standard fruit allocation
100: REAL(r_std), PARAMETER :: f_fruit = 0.1
101: ! fraction of sapwood allocation above ground (SHOULD BE CALCULATED !!!!)
102: REAL(r_std), PARAMETER :: alloc_sap_above_tree = 0.5
103: REAL(r_std), PARAMETER :: alloc_sap_above_grass = 1.0
104: ! extrema of leaf allocation fraction
105: REAL(r_std), PARAMETER :: min_LtoLSR = 0.2
106: REAL(r_std), PARAMETER :: max_LtoLSR = 0.5
107: ! below this lai, the carbohydrate reserve is used
108: REAL(r_std), DIMENSION(npft) :: lai_happy
109: ! limiting factor light
110: REAL(r_std), DIMENSION(npts) :: limit_L
111: ! limiting factor nitrogen
112: REAL(r_std), DIMENSION(npts) :: limit_N
113: ! factors determining limit_N: 1/ temperature
114: REAL(r_std), DIMENSION(npts) :: limit_N_temp
115: ! factors determining limit_N: 2/ humidity
116: REAL(r_std), DIMENSION(npts) :: limit_N_hum
117: ! limiting factor water
118: REAL(r_std), DIMENSION(npts) :: limit_W
119: ! limiting factor in soil (nitrogen or water)
120: REAL(r_std), DIMENSION(npts) :: limit_WorN
121: ! limit: strongest limitation amongst limit_N, limit_W and limit_L
122: REAL(r_std), DIMENSION(npts) :: limit
123: ! scaling depth for nitrogen limitation (m)
124: REAL(r_std), PARAMETER :: z_nitrogen = 0.2
125: ! soil temperature used for N parameterization
126: REAL(r_std), DIMENSION(npts) :: t_nitrogen
127: ! soil humidity used for N parameterization
128: REAL(r_std), DIMENSION(npts) :: h_nitrogen
129: ! integration constant for vertical profiles
130: REAL(r_std), DIMENSION(npts) :: rpc
131: ! ratio between leaf-allocation and (leaf+sapwood+root)-allocation
132: REAL(r_std), DIMENSION(npts) :: LtoLSR
133: ! ratio between sapwood-allocation and (leaf+sapwood+root)-allocation
134: REAL(r_std), DIMENSION(npts) :: StoLSR
135: ! ratio between root-allocation and (leaf+sapwood+root)-allocation
136: REAL(r_std), DIMENSION(npts) :: RtoLSR
137: ! rescaling factor for carbohydrate reserve allocation
138: REAL(r_std), DIMENSION(npts) :: carb_rescale
139: ! mass taken from carbohydrate reserve (gC/m**2)
140: REAL(r_std), DIMENSION(npts) :: use_reserve
141: ! mass taken from carbohydrate reserve and put into leaves (gC/m**2)
142: REAL(r_std), DIMENSION(npts) :: transloc_leaf
143: ! mass in youngest leaf age class (gC/m**2)
144: REAL(r_std), DIMENSION(npts) :: leaf_mass_young
145: ! old leaf biomass (gC/m**2)
146: REAL(r_std), DIMENSION(npts,npft) :: lm_old
147: ! maximum time (d) during which reserve is used
148: REAL(r_std) :: reserve_time
149: ! lai on natural part of the grid cell, or of this agricultural PFT
150: REAL(r_std), DIMENSION(npts,npft) :: lai_around
151: ! vegetation cover of natural PFTs on the grid cell (agriculture masked)
152: REAL(r_std), DIMENSION(npts,npft) :: veget_max_nat
153: ! total natural vegetation cover on natural part of the grid cell
154: REAL(r_std), DIMENSION(npts) :: natveg_tot
155: ! average LAI on natural part of the grid cell
156: REAL(r_std), DIMENSION(npts) :: lai_nat
157: ! intermediate array for looking for minimum
158: REAL(r_std), DIMENSION(npts) :: zdiff_min
159: ! fraction of sapwood allocation above ground (SHOULD BE CALCULATED !!!!)
160: REAL(r_std) :: alloc_sap_above
161: ! soil levels (m)
162: REAL(r_std), SAVE, DIMENSION(0:nbdl) :: z_soil
163: ! Index
164: INTEGER(i_std) :: i,j,l,m
165:
166: ! =========================================================================
167:
168: IF (bavard.GE.3) WRITE(numout,*) 'Entering alloc'
169:
170: !
171: ! 1 Initialization
172: !
173:
174: !
175: ! 1.1 first call
176: !
177:
178: IF ( firstcall ) THEN
179:
180: ! 1.1.1 soil levels
181:
182: z_soil(0) = 0.
183: V====== z_soil(1:nbdl) = diaglev(1:nbdl)
184:
185: ! 1.1.2 info about flags and parameters.
186:
187: WRITE(numout,*) 'alloc:'
188:
189: WRITE(numout,'(a,$)') ' > We'
190: IF ( .NOT. ok_minres ) WRITE(numout,'(a,$)') ' do NOT'
191: WRITE(numout,*) 'try to reach a minumum reservoir when severely stressed.'
192:
193: WRITE(numout,*) ' > Time to put initial leaf mass on (d): ',tau_leafinit
194:
195: WRITE(numout,*) ' > scaling depth for nitrogen limitation (m): ', &
196: z_nitrogen
197:
198: WRITE(numout,*) ' > sap allocation above the ground / total sap allocation: '
199: WRITE(numout,*) ' trees:', alloc_sap_above_tree
200: WRITE(numout,*) ' grasses:', alloc_sap_above_grass
201:
202: WRITE(numout,*) ' > standard root alloc fraction: ', R0
203:
204: WRITE(numout,*) ' > standard sapwood alloc fraction: ', S0
205:
206: WRITE(numout,*) ' > standard fruit allocation: ', f_fruit
207:
208: WRITE(numout,*) ' > minimum/maximum leaf alloc fraction: ', min_LtoLSR,max_LtoLSR
209:
210: WRITE(numout,*) ' > maximum time (d) during which reserve is used:'
211: WRITE(numout,*) ' trees:',reserve_time_tree
212: WRITE(numout,*) ' grasses:',reserve_time_grass
213:
214: firstcall = .FALSE.
215:
216: ENDIF
217:
218: !
219: ! 1.2 initialize output
220: !
221:
222: WW*==== f_alloc(:,:,:) = 0.0
223: **===== f_alloc(:,:,icarbres) = 1.0
224: !
225: ! 1.3 Convolution of the temperature and humidity profiles with some kind of profile
226: ! of microbial density gives us a representative temperature and humidity
227: !
228:
229: ! 1.3.1 temperature
230:
231: ! 1.3.1.1 rpc is an integration constant such that the integral of the root profile is 1.
232: V------> rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_nitrogen ) )
233: |
234: | ! 1.3.1.2 integrate over the nbdl levels
235: |
236: V------ t_nitrogen(:) = 0.
237:
238: +------> DO l = 1, nbdl
239: |
240: |V===== t_nitrogen(:) = &
241: | t_nitrogen(:) + tsoil_month(:,l) * rpc(:) * &
242: | ( EXP( -z_soil(l-1)/z_nitrogen ) - EXP( -z_soil(l)/z_nitrogen ) )
243: |
244: +------ ENDDO
245:
246: ! 1.3.2 moisture
247:
248: ! 1.3.2.1 rpc is an integration constant such that the integral of the root profile is 1.
249: V------> rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_nitrogen ) )
250: |
251: | ! 1.3.2.2 integrate over the nbdl levels
252: |
253: V------ h_nitrogen(:) = 0.0
254:
255: +------> DO l = 1, nbdl
256: |
257: |V===== h_nitrogen(:) = &
258: | h_nitrogen(:) + soilhum_month(:,l) * rpc(:) * &
259: | ( EXP( -z_soil(l-1)/z_nitrogen ) - EXP( -z_soil(l)/z_nitrogen ) )
260: |
261: +------ ENDDO
262:
263: !
264: ! 1.4 for light limitation: lai on natural part of the grid cell or lai of this
265: ! agricultural PFT
266: !
267:
268: ! mask agricultural vegetation
269: ! mean LAI on natural part
270:
271: V------> natveg_tot(:) = 0.0
272: V------ lai_nat(:) = 0.0
273:
274: +------> DO j = 1, npft
275: |
276: | IF ( natural(j) ) THEN
277: |V===== veget_max_nat(:,j) = veget_max(:,j)
278: | ELSE
279: |V===== veget_max_nat(:,j) = 0.0
280: | ENDIF
281: |
282: | ! sum up fraction of natural space covered by vegetation
283: |V-----> natveg_tot(:) = natveg_tot(:) + veget_max_nat(:,j)
284: ||
285: || ! sum up lai
286: |V----- lai_nat(:) = lai_nat(:) + veget_max_nat(:,j) * lai(:,j)
287: |
288: +------ ENDDO
289:
290: +------> DO j = 1, npft
291: |
292: | IF ( natural(j) ) THEN
293: |V===== lai_around(:,j) = lai_nat(:)
294: | ELSE
295: |V===== lai_around(:,j) = lai(:,j)
296: | ENDIF
297: |
298: +------ ENDDO
299:
300: !
301: ! 1.5 LAI below which carbohydrate reserve is used
302: !
303:
304: V====== lai_happy(:) = lai_max(:) * 0.5
305:
306: !
307: ! 2 Use carbohydrate reserve
308: ! This time constant implicitly takes into account the dispersion of the budburst
309: ! data. Therefore, it might be decreased at lower resolution.
310: !
311:
312: ! save old leaf mass
313:
314: +V===== lm_old(:,:) = biomass(:,:,ileaf)
315:
316: V------> DO j = 1, npft
317: |
318: | !
319: | ! 2.1 determine mass to be translocated to leaves and roots
320: | !
321: |
322: | ! determine maximum time during which reserve is used
323: |
324: | IF ( tree(j) ) THEN
325: | reserve_time = reserve_time_tree
326: | ELSE
327: | reserve_time = reserve_time_grass
328: | ENDIF
329: |
330: | ! conditions: 1/ plant must not be senescent
331: | ! 2/ lai must be relatively low
332: | ! 3/ must be at the beginning of the growing season
333: |
334: |V-----> WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. &
335: || ( .NOT. senescence(:,j) ) .AND. &
336: || ( lai(:,j) .LT. lai_happy(j) ) .AND. &
337: || ( when_growthinit(:,j) .LT. reserve_time ) )
338: ||
339: || ! determine mass to put on
340: || use_reserve(:) = &
341: || MIN( biomass(:,j,icarbres), &
342: || 2._r_std * dt/tau_leafinit * lai_happy(j) * veget_max(:,j) / sla(j) )
343: ||
344: || ! grow leaves and fine roots
345: ||
346: || transloc_leaf(:) = L0/(L0+R0) * use_reserve(:)
347: ||
348: || biomass(:,j,ileaf) = biomass(:,j,ileaf) + transloc_leaf(:)
349: || biomass(:,j,iroot) = biomass(:,j,iroot) + ( use_reserve(:) - transloc_leaf(:) )
350: ||
351: || ! decrease reserve mass
352: ||
353: || biomass(:,j,icarbres) = biomass(:,j,icarbres) - use_reserve(:)
354: ||
355: || ELSEWHERE
356: ||
357: |V----- transloc_leaf(:) = 0.0
358: |
359: | ENDWHERE
360: |
361: | !
362: | ! 2.2 update leaf age
363: | !
364: |
365: | ! 2.2.1 Decrease leaf age in youngest class.
366: |
367: |V===== leaf_mass_young(:) = leaf_frac(:,j,1) * lm_old(:,j) + transloc_leaf(:)
368: |
369: |V-----> WHERE ( ( transloc_leaf(:) .GT. 0.0 ) .AND. ( leaf_mass_young(:) .GT. 0.0 ) )
370: ||
371: |V----- leaf_age(:,j,1) = leaf_age(:,j,1) * ( leaf_mass_young(:) - transloc_leaf(:) ) / &
372: | leaf_mass_young(:)
373: |
374: | ENDWHERE
375: |
376: | ! 2.2.2 new age class fractions (fraction in youngest class increases)
377: |
378: | ! 2.2.2.1 youngest class: new mass in youngest class divided by total new mass
379: |
380: |V-----> WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
381: ||
382: |V----- leaf_frac(:,j,1) = leaf_mass_young(:) / biomass(:,j,ileaf)
383: |
384: | ENDWHERE
385: |
386: | ! 2.2.2.2 other classes: old mass in leaf age class divided by new mass
387: |
388: |*-----> DO m = 2, nleafages
389: ||
390: ||V----> WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
391: |||
392: ||V---- leaf_frac(:,j,m) = leaf_frac(:,j,m) * lm_old(:,j) / biomass(:,j,ileaf)
393: ||
394: || ENDWHERE
395: ||
396: |*----- ENDDO
397: |
398: V------ ENDDO ! loop over PFTs
399:
400: !
401: ! 3 Calculate fractional allocation.
402: ! The fractions of NPP allocated to the different compartments depend on the
403: ! availability of light, water, and nitrogen.
404: !
405:
406: +------> DO j = 1, npft
407: |
408: |V-----> RtoLSR(:)=0
409: || LtoLSR(:)=0
410: |V----- StoLSR(:)=0
411: | ! for the moment, fixed partitioning between above and below the ground
412: |
413: | IF ( tree(j) ) THEN
414: | alloc_sap_above = alloc_sap_above_tree
415: | ELSE
416: | alloc_sap_above = alloc_sap_above_grass
417: | ENDIF
418: |
419: | ! only where leaves are on
420: |
421: |V-----> WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
422: ||
423: || !
424: || ! 3.1 Limiting factors: weak value = strong limitation
425: || !
426: ||
427: || ! 3.1.1 Light: depends on mean lai on the natural part of the
428: || ! grid box (light competition).
429: || ! For agricultural PFTs, take its own lai for both parts.
430: ||
431: || limit_L(:) = MAX( 0.1_r_std, exp( -0.5_r_std * lai_around(:,j) ) )
432: ||
433: || ! 3.1.2 Water
434: ||
435: || limit_W(:) = MAX( 0.1_r_std, MIN( 1._r_std, moiavail_week(:,j) ) )
436: ||
437: || ! 3.1.3 Nitrogen supply: depends on water and temperature
438: || ! Agricultural PFTs can be limited by Nitrogen for the moment ...
439: || ! Replace this once there is a nitrogen cycle in STOMATE !
440: ||
441: || ! 3.1.3.1 water
442: ||
443: || limit_N_hum(:) = MAX( 0.5_r_std, MIN( 1._r_std, h_nitrogen(:) ) )
444: ||
445: || ! 3.1.3.2 temperature
446: ||
447: || limit_N_temp(:) = 2.**((t_nitrogen(:)-ZeroCelsius-25.)/10.)
448: || limit_N_temp(:) = MAX( 0.1_r_std, MIN( 1._r_std, limit_N_temp(:) ) )
449: ||
450: || ! 3.1.3.3 combine water and temperature factors to get nitrogen limitation
451: ||
452: || limit_N(:) = MAX( 0.1_r_std, MIN( 1._r_std, limit_N_hum(:) * limit_N_temp(:) ) )
453: ||
454: || ! 3.1.4 Among water and nitrogen, take the one that is more limited
455: ||
456: || limit_WorN(:) = MIN( limit_W(:), limit_N(:) )
457: ||
458: || ! 3.1.5 strongest limitation
459: ||
460: || limit(:) = MIN( limit_WorN(:), limit_L(:) )
461: ||
462: || !
463: || ! 3.2 Ratio between allocation to leaves, sapwood and roots
464: || !
465: ||
466: || ! preliminary root allocation
467: ||
468: || RtoLSR(:) = &
469: || MAX( .15_r_std, &
470: || R0 * 3._r_std * limit_L(:) / ( limit_L(:) + 2._r_std * limit_WorN(:) ) )
471: ||
472: || ! sapwood allocation
473: ||
474: || StoLSR(:) = S0 * 3. * limit_WorN(:) / ( 2. * limit_L(:) + limit_WorN(:) )
475: ||
476: || ! leaf allocation
477: ||
478: || LtoLSR(:) = 1. - RtoLSR(:) - StoLSR(:)
479: || LtoLSR(:) = MAX( min_LtoLSR, MIN( max_LtoLSR, LtoLSR(:) ) )
480: ||
481: || ! roots: the rest
482: ||
483: |V----- RtoLSR(:) = 1. - LtoLSR(:) - StoLSR(:)
484: |
485: | ENDWHERE
486: |
487: | ! no leaf allocation if LAI beyond maximum LAI. Biomass then goes into sapwood
488: |
489: |V-----> WHERE ( (biomass(:,j,ileaf) .GT. min_stomate) .AND. (lai(:,j) .GT. lai_max(j)) )
490: ||
491: || StoLSR(:) = StoLSR(:) + LtoLSR(:)
492: ||
493: |V----- LtoLSR(:) = 0.0
494: |
495: | ENDWHERE
496: |
497: | !
498: | ! 3.3 final allocation
499: | !
500: |
501: |V-----> DO i = 1, npts
502: ||
503: || IF ( biomass(i,j,ileaf) .GT. min_stomate ) THEN
504: ||
505: || IF ( senescence(i,j) ) THEN
506: ||
507: || ! 3.3.1 senescent: everything goes into carbohydrate reserve
508: ||
509: || f_alloc(i,j,icarbres) = 1.0
510: ||
511: || ELSE
512: ||
513: || ! 3.3.2 in growing season
514: ||
515: || ! to fruits
516: || f_alloc(i,j,ifruit) = f_fruit
517: ||
518: || ! allocation to the reserve is proportional to the leaf and root allocation.
519: || ! Leaf, root, and sap allocation are rescaled.
520: || ! No allocation to reserve if there is much biomass in it
521: || ! (more than the maximum LAI: in that case, rescale=1)
522: ||
523: || IF ( ( biomass(i,j,icarbres)*sla(j)/veget_max(i,j) ) .LT. lai_max(j) ) THEN
524: || carb_rescale(i) = 1. / ( 1. + ecureuil(j) * ( LtoLSR(i) + RtoLSR(i) ) )
525: || ELSE
526: || carb_rescale(i) = 1.
527: || ENDIF
528: ||
529: || f_alloc(i,j,ileaf) = LtoLSR(i) * ( 1.-f_alloc(i,j,ifruit) ) * carb_rescale(i)
530: ||
531: || f_alloc(i,j,isapabove) = StoLSR(i) * alloc_sap_above * &
532: || ( 1. - f_alloc(i,j,ifruit) ) * carb_rescale(i)
533: || f_alloc(i,j,isapbelow) = StoLSR(i) * ( 1. - alloc_sap_above ) * &
534: || ( 1. - f_alloc(i,j,ifruit) ) * carb_rescale(i)
535: ||
536: || f_alloc(i,j,iroot) = RtoLSR(i) * ( 1.-f_alloc(i,j,ifruit) ) * carb_rescale(i)
537: ||
538: || ! this is equivalent to:
539: || ! reserve alloc = ecureuil*(LtoLSR+StoLSR)*(1-fruit_alloc)*carb_rescale
540: || f_alloc(i,j,icarbres) = ( 1. - carb_rescale(i) ) * ( 1.-f_alloc(i,j,ifruit) )
541: ||
542: || ENDIF ! senescent?
543: ||
544: || ENDIF ! there are leaves
545: ||
546: |V----- ENDDO ! Fortran95: double WHERE construct
547: |
548: +------ ENDDO ! loop over PFTs
549:
550: !
551: ! 4 root profile
552: !
553:
554:
555: IF (bavard.GE.4) WRITE(numout,*) 'Leaving alloc'
556:
557: END SUBROUTINE alloc
558:
559:
560: END MODULE stomate_alloc
ORCHIDEE/src_stomate/i.stomate_data.L 0000754 0103600 0005670 00000105011 11164403473 017257 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:54 2008
FILE NAME: i.stomate_data.f90
PROGRAM NAME: stomate_data
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
56 vec ( 3): Unvectorized loop.
272 vec ( 6): Unvectorized array expression.
272 vec ( 7): Iteration count is too small.
281 vec ( 6): Unvectorized array expression.
281 vec ( 7): Iteration count is too small.
340 vec ( 6): Unvectorized array expression.
340 vec ( 7): Iteration count is too small.
350 vec ( 6): Unvectorized array expression.
350 vec ( 7): Iteration count is too small.
647 vec ( 3): Unvectorized loop.
647 vec ( 13): Overhead of loop division is too large.
649 vec ( 22): Dependency unknown. Unvectorizable dependency is assumed.:npft_stomate
649 vec ( 4): Vectorized array expression.
651 opt (1017): Subroutine call prevents optimization.
651 vec ( 17): Unvectorizable statement.
655 vec ( 22): Dependency unknown. Unvectorizable dependency is assumed.:j
659 warn ( 83): Dummy argument "lalo" is not used.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:35:54 2008
FILE NAME: i.stomate_data.f90
PROGRAM NAME: stomate_data
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! defines PFT parameters
2: ! the geographical coordinates might be used for defining some additional parameters
3: ! (e.g. frequency of anthropogenic fires, irrigation of agricultural surfaces, etc.)
4: !
5: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_data.f90,v 1.10 2007/05/28 14:51:50 ssipsl Exp $
6: ! IPSL (2006)
7: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8: !
9: MODULE stomate_data
10:
11: ! modules used:
12:
13: USE constantes_veg
14: USE constantes_co2
15: USE stomate_constants
16:
17: IMPLICIT NONE
18:
19: ! private & public routines
20:
21: PRIVATE
22: PUBLIC data
23:
24: CONTAINS
25:
26: SUBROUTINE data (npts, lalo)
27:
28: !
29: ! 0 declarations
30: !
31:
32: ! 0.1 input
33:
34: ! Domain size
35: INTEGER(i_std), INTENT(in) :: npts
36: ! Geographical coordinates (latitude,longitude)
37: REAL(r_std),DIMENSION (npts,2), INTENT (in) :: lalo
38:
39: ! 0.2 local variables
40:
41: ! Index
42: INTEGER(i_std) :: j
43: ! alpha's : ?
44: REAL(r_std) :: alpha
45: ! stem diameter
46: REAL(r_std) :: dia
47: ! Sapling CSA
48: REAL(r_std) :: csa_sap
49: ! mass ratio (heartwood+sapwood)/sapwood
50: REAL(r_std), PARAMETER :: x = 3.
51:
52: ! =========================================================================
53:
54: IF ( bavard .GE. 1 ) WRITE(numout,*) 'data: PFT characteristics'
55:
56: +------> DO j = 1, npft
57: |
58: | IF ( bavard .GE. 1 ) WRITE(numout,'(a,i3,a,a)') ' > PFT#',j,': ', PFT_name(j)
59: |
60: | !
61: | ! 1 tree?
62: | !
63: |
64: | IF ( leaf_tab(j) .LE. 2 ) THEN
65: | tree(j) = .TRUE.
66: | ELSE
67: | tree(j) = .FALSE.
68: | ENDIF
69: |
70: | IF ( bavard .GE. 1 ) WRITE(numout,*) ' tree: ', tree(j)
71: |
72: | !
73: | ! 2 flamability
74: | !
75: |
76: | IF ( bavard .GE. 1 ) WRITE(numout,*) ' litter flamability:', flam(j)
77: |
78: | !
79: | ! 3 fire resistance
80: | !
81: |
82: | IF ( bavard .GE. 1 ) WRITE(numout,*) ' fire resistance:', resist(j)
83: |
84: | !
85: | ! 4 specific leaf area per mass carbon = 2 * sla / dry mass
86: | !
87: |
88: | !!$ IF ( leaf_tab(j) .EQ. 1 ) THEN
89: | !!$
90: | !!$ ! broad leaved tree
91: | !!$
92: | !!$ sla(j) = 2. * ( 10. ** ( 2.41 - 0.38 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
93: | !!$
94: | !!$ ELSE
95: | !!$
96: | !!$ ! needle leaved or grass (Reich et al 1992)
97: | !!$
98: | !!$ sla(j) = 2. * ( 10. ** ( 2.29 - 0.4 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
99: | !!$
100: | !!$ ENDIF
101: | !!$
102: | !!$ IF ( ( leaf_tab(j) .EQ. 2 ) .AND. ( pheno_type_tab(j) .EQ. 2 ) ) THEN
103: | !!$
104: | !!$ ! summergreen needle leaf
105: | !!$
106: | !!$ sla(j) = 1.25 * sla(j)
107: | !!$
108: | !!$ ENDIF
109: | IF ( leaf_tab(j) .EQ. 2 ) THEN
110: |
111: | ! needle leaved tree
112: | sla(j) = 2. * ( 10. ** ( 2.29 - 0.4 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
113: |
114: | ELSE
115: |
116: | ! broad leaved tree or grass (Reich et al 1992)
117: | sla(j) = 2. * ( 10. ** ( 2.41 - 0.38 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
118: |
119: | ENDIF
120: |
121: | IF ( bavard .GE. 1 ) WRITE(numout,*) ' specific leaf area (m**2/gC):', sla(j)
122: |
123: | !
124: | ! 5 sapling characteristics
125: | !
126: |
127: | IF ( tree(j) ) THEN
128: |
129: | ! 5.1 trees
130: |
131: | alpha = alpha_tree
132: |
133: | bm_sapl(j,ileaf) = &
134: | ( (4.*pipe_tune1 * ( x*4.*sla(j)/(pi*pipe_k1))**.8 ) / sla(j) ) ** 5.
135: |
136: | IF ( pheno_type_tab(j) .NE. 1 ) THEN
137: | ! not evergreen
138: | bm_sapl(j,icarbres) = 5. * bm_sapl(j,ileaf)
139: | ELSE
140: | bm_sapl(j,icarbres) = 0.0
141: | ENDIF
142: |
143: | csa_sap = bm_sapl(j,ileaf) / ( pipe_k1 / sla(j) )
144: |
145: | dia = ( x * csa_sap * 4. / pi ) ** 0.5
146: |
147: | bm_sapl(j,isapabove) = &
148: | .5 * pipe_density * csa_sap * pipe_tune2 * dia ** pipe_tune3
149: | bm_sapl(j,isapbelow) = bm_sapl(j,isapabove)
150: |
151: | bm_sapl(j,iheartabove) = 2. * bm_sapl(j,isapabove)
152: | bm_sapl(j,iheartbelow) = 2. * bm_sapl(j,isapbelow)
153: |
154: | ELSE
155: |
156: | ! 5.2 grasses
157: |
158: | alpha = alpha_grass
159: |
160: | IF ( natural(j) ) THEN
161: | bm_sapl(j,ileaf) = 0.1 / sla(j)
162: | ELSE
163: | bm_sapl(j,ileaf) = 1.0 / sla(j)
164: | ENDIF
165: |
166: | bm_sapl(j,icarbres) = 5.*bm_sapl(j,ileaf)
167: |
168: | bm_sapl(j,isapabove) = 0.
169: | bm_sapl(j,isapbelow) = 0.
170: |
171: | bm_sapl(j,iheartabove) = 0.
172: | bm_sapl(j,iheartbelow) = 0.
173: |
174: | ENDIF
175: |
176: | bm_sapl(j,iroot) = 0.1 * (1./alpha) * bm_sapl(j,ileaf)
177: |
178: | bm_sapl(j,ifruit) = 0.3 * bm_sapl(j,ileaf)
179: |
180: | IF ( bavard .GE. 1 ) THEN
181: | WRITE(numout,*) ' sapling biomass (gC):'
182: | WRITE(numout,*) ' leaves:',bm_sapl(j,ileaf)
183: | WRITE(numout,*) ' sap above ground:',bm_sapl(j,isapabove)
184: | WRITE(numout,*) ' sap below ground:',bm_sapl(j,isapbelow)
185: | WRITE(numout,*) ' heartwood above ground:',bm_sapl(j,iheartabove)
186: | WRITE(numout,*) ' heartwood below ground:',bm_sapl(j,iheartbelow)
187: | WRITE(numout,*) ' roots:',bm_sapl(j,iroot)
188: | WRITE(numout,*) ' fruits:',bm_sapl(j,ifruit)
189: | WRITE(numout,*) ' carbohydrate reserve:',bm_sapl(j,icarbres)
190: | ENDIF
191: |
192: | !
193: | ! 6 migration speed (m/year)
194: | !
195: |
196: | IF ( tree(j) ) THEN
197: |
198: | migrate(j) = 10.*1.E3
199: |
200: | ELSE
201: |
202: | ! can be any value as grasses are, per definitionem, everywhere (big leaf).
203: | migrate(j) = 10.*1.E3
204: |
205: | ENDIF
206: |
207: | IF ( bavard .GE. 1 ) WRITE(numout,*) ' migration speed (m/year):', migrate(j)
208: |
209: | !
210: | ! 7 critical stem diameter: beyond this diameter, the crown area no longer
211: | ! increases
212: | !
213: |
214: | IF ( tree(j) ) THEN
215: |
216: | maxdia(j) = ( ( pipe_tune4 / ((pipe_tune2*pipe_tune3)/(100.**pipe_tune3)) ) &
217: | ** ( 1. / ( pipe_tune3 - 1. ) ) ) * 0.01
218: |
219: | ELSE
220: |
221: | maxdia(j) = undef
222: |
223: | ENDIF
224: |
225: | IF ( bavard .GE. 1 ) WRITE(numout,*) ' critical stem diameter (m):', maxdia(j)
226: |
227: | !
228: | ! 8 Coldest tolerable temperature
229: | !
230: |
231: | IF ( ABS( tmin_crit_tab(j) - undef ) .GT. min_stomate ) THEN
232: | tmin_crit(j) = tmin_crit_tab(j) + ZeroCelsius
233: | ELSE
234: | tmin_crit(j) = undef
235: | ENDIF
236: |
237: | IF ( bavard .GE. 1 ) &
238: | WRITE(numout,*) ' coldest tolerable temperature (K):', tmin_crit(j)
239: |
240: | !
241: | ! 9 Maximum temperature of the coldest month: need to be below this temperature
242: | ! for a certain time to regrow leaves next spring
243: | !
244: |
245: | IF ( ABS ( tcm_crit_tab(j) - undef ) .GT. min_stomate ) THEN
246: | tcm_crit(j) = tcm_crit_tab(j) + ZeroCelsius
247: | ELSE
248: | tcm_crit(j) = undef
249: | ENDIF
250: |
251: | IF ( bavard .GE. 1 ) &
252: | WRITE(numout,*) ' vernalization temperature (K):', tcm_crit(j)
253: |
254: | !
255: | ! 10 critical values for phenology
256: | !
257: |
258: | ! 10.1 model used
259: |
260: | pheno_crit%pheno_model(j) = pheno_model_tab(j)
261: |
262: | IF ( bavard .GE. 1 ) &
263: | WRITE(numout,*) ' phenology model used: ',pheno_crit%pheno_model(j)
264: |
265: | ! 10.2 growing degree days. What kind of gdd is meant (i.e. threshold 0 or -5 deg C
266: | ! or whatever), depends on how this is used in stomate_phenology.
267: |
268: | pheno_crit%gdd(j,1) = gdd_crit1_tab(j)
269: | pheno_crit%gdd(j,2) = gdd_crit2_tab(j)
270: | pheno_crit%gdd(j,3) = gdd_crit3_tab(j)
271: |
272: |*===== IF ( ( bavard .GE. 1 ) .AND. ( ALL(pheno_crit%gdd(j,:) .NE. undef) ) ) THEN
273: | WRITE(numout,*) ' critical GDD is a function of long term T (C):'
274: | WRITE(numout,*) ' ',pheno_crit%gdd(j,1), &
275: | ' + T *',pheno_crit%gdd(j,2), &
276: | ' + T^2 *',pheno_crit%gdd(j,3)
277: | ENDIF
278: |
279: | ! consistency check
280: |
281: |*===== IF ( ( ( pheno_crit%pheno_model(j) .EQ. 'moigdd' ) .OR. &
282: | ( pheno_crit%pheno_model(j) .EQ. 'humgdd' ) ) .AND. &
283: | ( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) ) THEN
284: | STOP 'problem with phenology parameters, critical GDD.'
285: | ENDIF
286: |
287: | ! 10.3 number of growing days
288: |
289: | pheno_crit%ngd(j) = ngd_crit_tab(j)
290: |
291: | IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%ngd(j) .NE. undef ) ) &
292: | WRITE(numout,*) ' critical NGD:', pheno_crit%ngd(j)
293: |
294: | ! 10.4 critical temperature for ncd vs. gdd function in phenology
295: |
296: | pheno_crit%ncdgdd_temp(j) = ncdgdd_temp_tab(j)
297: |
298: | IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%ncdgdd_temp(j) .NE. undef ) ) &
299: | WRITE(numout,*) ' critical temperature for NCD vs. GDD (C):', &
300: | pheno_crit%ncdgdd_temp(j)
301: |
302: | ! 10.5 humidity fractions
303: |
304: | pheno_crit%hum_frac(j) = hum_frac_tab(j)
305: |
306: | IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%hum_frac(j) .NE. undef ) ) &
307: | WRITE(numout,*) ' critical humidity fraction:', pheno_crit%hum_frac(j)
308: |
309: | ! 10.6 minimum time during which there was no photosynthesis
310: |
311: | pheno_crit%lowgpp_time(j) = lowgpp_time_tab(j)
312: |
313: | IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%lowgpp_time(j) .NE. undef ) ) &
314: | WRITE(numout,*) ' minimum dormance duration (d):', pheno_crit%lowgpp_time(j)
315: |
316: | ! 10.7 minimum time elapsed since moisture minimum (d)
317: |
318: | pheno_crit%hum_min_time(j) = hum_min_time_tab(j)
319: |
320: | IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%hum_min_time(j) .NE. undef ) ) &
321: | WRITE(numout,*) ' time to wait after moisture min (d):', pheno_crit%hum_min_time(j)
322: |
323: | !
324: | ! 11 critical values for senescence
325: | !
326: |
327: | ! 11.1 type of senescence
328: |
329: | pheno_crit%senescence_type(j) = senescence_type_tab(j)
330: |
331: | IF ( bavard .GE. 1 ) &
332: | WRITE(numout,*) ' type of senescence: ',pheno_crit%senescence_type(j)
333: |
334: | ! 11.2 critical temperature for senescence
335: |
336: | pheno_crit%senescence_temp(j,1) = senescence_temp1_tab(j)
337: | pheno_crit%senescence_temp(j,2) = senescence_temp2_tab(j)
338: | pheno_crit%senescence_temp(j,3) = senescence_temp3_tab(j)
339: |
340: |*===== IF ( ( bavard .GE. 1 ) .AND. ( ALL(pheno_crit%senescence_temp(j,:) .NE. undef) ) ) THEN
341: | WRITE(numout,*) ' critical temperature for senescence (C) is'
342: | WRITE(numout,*) ' a function of long term T (C):'
343: | WRITE(numout,*) ' ',pheno_crit%senescence_temp(j,1), &
344: | ' + T *',pheno_crit%senescence_temp(j,2), &
345: | ' + T^2 *',pheno_crit%senescence_temp(j,3)
346: | ENDIF
347: |
348: | ! consistency check
349: |
350: |*===== IF ( ( ( pheno_crit%senescence_type(j) .EQ. 'cold' ) .OR. &
351: | ( pheno_crit%senescence_type(j) .EQ. 'mixed' ) ) .AND. &
352: | ( ANY(pheno_crit%senescence_temp(j,:) .EQ. undef ) ) ) THEN
353: | STOP 'problem with senescence parameters, temperature.'
354: | ENDIF
355: |
356: | ! 11.3 critical relative moisture availability for senescence
357: |
358: | pheno_crit%senescence_hum(j) = senescence_hum_tab(j)
359: |
360: | IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%senescence_hum(j) .NE. undef ) ) &
361: | WRITE(numout,*) ' max. critical relative moisture availability for senescence:', &
362: | pheno_crit%senescence_hum(j)
363: |
364: | ! consistency check
365: |
366: | IF ( ( ( pheno_crit%senescence_type(j) .EQ. 'dry' ) .OR. &
367: | ( pheno_crit%senescence_type(j) .EQ. 'mixed' ) ) .AND. &
368: | ( pheno_crit%senescence_hum(j) .EQ. undef ) ) THEN
369: | STOP 'problem with senescence parameters, humidity.'
370: | ENDIF
371: |
372: | ! 14.3 relative moisture availability above which there is no moisture-related
373: | ! senescence
374: |
375: | pheno_crit%nosenescence_hum(j) = nosenescence_hum_tab(j)
376: |
377: | IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%nosenescence_hum(j) .NE. undef ) ) &
378: | WRITE(numout,*) ' relative moisture availability above which there is'
379: | WRITE(numout,*) ' no moisture-related senescence:', &
380: | pheno_crit%nosenescence_hum(j)
381: |
382: | pheno_crit% max_turnover_time(j) = max_turnover_time_tab(j)
383: | pheno_crit% min_turnover_time(j) = min_turnover_time_tab(j)
384: | pheno_crit% min_leaf_age_for_senescence(j) = min_leaf_age_for_senescence_tab(j)
385: |
386: | ! consistency check
387: |
388: | IF ( ( ( pheno_crit%senescence_type(j) .EQ. 'dry' ) .OR. &
389: | ( pheno_crit%senescence_type(j) .EQ. 'mixed' ) ) .AND. &
390: | ( pheno_crit%nosenescence_hum(j) .EQ. undef ) ) THEN
391: | STOP 'problem with senescence parameters, humidity.'
392: | ENDIF
393: |
394: | !
395: | ! 12 sapwood -> heartwood conversion time
396: | !
397: |
398: | IF ( bavard .GE. 1 ) &
399: | WRITE(numout,*) ' sapwood -> heartwood conversion time (d):', tau_sap(j)
400: |
401: | !
402: | ! 13 fruit lifetime
403: | !
404: |
405: | IF ( bavard .GE. 1 ) WRITE(numout,*) ' fruit lifetime (d):', tau_fruit(j)
406: |
407: | !
408: | ! 14 length of leaf death
409: | ! For evergreen trees, this variable determines the lifetime of the leaves.
410: | ! Note that it is different from the value given in leaflife_tab.
411: | !
412: |
413: | pheno_crit%leaffall(j) = leaffall_tab(j)
414: |
415: | IF ( bavard .GE. 1 ) &
416: | WRITE(numout,*) ' length of leaf death (d):', pheno_crit%leaffall(j)
417: |
418: | !
419: | ! 15 maximum lifetime of leaves
420: | !
421: |
422: | pheno_crit%leafagecrit(j) = leafagecrit_tab(j)
423: |
424: | IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%leafagecrit(j) .NE. undef ) ) &
425: | WRITE(numout,*) ' critical leaf age (d):', pheno_crit%leafagecrit(j)
426: |
427: | !
428: | ! 16 time constant for leaf age discretisation (d)
429: | !
430: |
431: | leaf_timecst(j) = pheno_crit%leafagecrit(j) / REAL( nleafages,r_std )
432: |
433: | IF ( bavard .GE. 1 ) &
434: | WRITE(numout,*) ' time constant for leaf age discretisation (d):', &
435: | leaf_timecst(j)
436: |
437: | !
438: | ! 17 minimum lai, initial
439: | !
440: |
441: | IF ( tree(j) ) THEN
442: | pheno_crit%lai_initmin(j) = 0.3
443: | ELSE
444: | pheno_crit%lai_initmin(j) = 0.1
445: | ENDIF
446: |
447: | IF ( bavard .GE. 1 ) &
448: | WRITE(numout,*) ' initial LAI:', pheno_crit%lai_initmin(j)
449: |
450: | !
451: | ! 19 maximum LAI
452: | !
453: |
454: | IF ( bavard .GE. 1 ) &
455: | WRITE(numout,*) ' critical LAI above which no leaf allocation:', lai_max(j)
456: |
457: | !
458: | ! 20 fraction of primary leaf and root allocation put into reserve
459: | !
460: |
461: | IF ( bavard .GE. 1 ) &
462: | WRITE(numout,*) ' reserve allocation factor:', ecureuil(j)
463: |
464: | !
465: | ! 21 maintenance respiration coefficient (g/g/day) at 0 deg C
466: | !
467: |
468: | coeff_maint_zero(j,ileaf) = cm_zero_leaf_tab(j)
469: | coeff_maint_zero(j,isapabove) = cm_zero_sapabove_tab(j)
470: | coeff_maint_zero(j,isapbelow) = cm_zero_sapbelow_tab(j)
471: | coeff_maint_zero(j,iheartabove) = cm_zero_heartabove_tab(j)
472: | coeff_maint_zero(j,iheartbelow) = cm_zero_heartbelow_tab(j)
473: | coeff_maint_zero(j,iroot) = cm_zero_root_tab(j)
474: | coeff_maint_zero(j,ifruit) = cm_zero_fruit_tab(j)
475: | coeff_maint_zero(j,icarbres) = cm_zero_carbres_tab(j)
476: |
477: | IF ( bavard .GE. 1 ) THEN
478: |
479: | WRITE(numout,*) ' maintenance respiration coefficient (g/g/day) at 0 deg C:'
480: | WRITE(numout,*) ' . leaves: ',coeff_maint_zero(j,ileaf)
481: | WRITE(numout,*) ' . sapwood above ground: ',coeff_maint_zero(j,isapabove)
482: | WRITE(numout,*) ' . sapwood below ground: ',coeff_maint_zero(j,isapbelow)
483: | WRITE(numout,*) ' . heartwood above ground: ',coeff_maint_zero(j,iheartabove)
484: | WRITE(numout,*) ' . heartwood below ground: ',coeff_maint_zero(j,iheartbelow)
485: | WRITE(numout,*) ' . roots: ',coeff_maint_zero(j,iroot)
486: | WRITE(numout,*) ' . fruits: ',coeff_maint_zero(j,ifruit)
487: | WRITE(numout,*) ' . carbohydrate reserve: ',coeff_maint_zero(j,icarbres)
488: |
489: | ENDIF
490: |
491: | !
492: | ! 22 parameter for temperature sensitivity of maintenance respiration
493: | !
494: |
495: | maint_resp_slope(j,1) = maint_resp_slope1_tab(j)
496: | maint_resp_slope(j,2) = maint_resp_slope2_tab(j)
497: | maint_resp_slope(j,3) = maint_resp_slope3_tab(j)
498: |
499: | IF ( bavard .GE. 1 ) &
500: | WRITE(numout,*) ' temperature sensitivity of maintenance respiration (1/K) is'
501: | WRITE(numout,*) ' a function of long term T (C):'
502: | WRITE(numout,*) ' ',maint_resp_slope(j,1),' + T *',maint_resp_slope(j,2), &
503: | ' + T^2 *',maint_resp_slope(j,3)
504: |
505: | !
506: | ! 23 natural ?
507: | !
508: |
509: | IF ( bavard .GE. 1 ) &
510: | WRITE(numout,*) ' Natural:', natural(j)
511: |
512: | !
513: | ! 24 Vcmax et Vjmax
514: | !
515: |
516: | IF ( bavard .GE. 1 ) &
517: | WRITE(numout,*) ' Maximum rate of carboxylation:', vcmax_opt(j)
518: |
519: | IF ( bavard .GE. 1 ) &
520: | WRITE(numout,*) ' Maximum rate of RUbp regeneration:', vjmax_opt(j)
521: |
522: | !
523: | ! 25 constants for photosynthesis temperatures
524: | !
525: |
526: | t_photo%t_min_a(j) = tphoto_min_a_tab(j)
527: | t_photo%t_min_b(j) = tphoto_min_b_tab(j)
528: | t_photo%t_min_c(j) = tphoto_min_c_tab(j)
529: | t_photo%t_opt_a(j) = tphoto_opt_a_tab(j)
530: | t_photo%t_opt_b(j) = tphoto_opt_b_tab(j)
531: | t_photo%t_opt_c(j) = tphoto_opt_c_tab(j)
532: | t_photo%t_max_a(j) = tphoto_max_a_tab(j)
533: | t_photo%t_max_b(j) = tphoto_max_b_tab(j)
534: | t_photo%t_max_c(j) = tphoto_max_c_tab(j)
535: |
536: | IF ( bavard .GE. 1 ) THEN
537: | WRITE(numout,*) ' min. temperature for photosynthesis as a function of long term T (C):'
538: | WRITE(numout,*) ' ',t_photo%t_min_c(j), &
539: | ' + T*',t_photo%t_min_b(j), &
540: | ' + T^2*',t_photo%t_min_a(j)
541: | WRITE(numout,*) ' opt. temperature for photosynthesis as a function of long term T (C):'
542: | WRITE(numout,*) ' ',t_photo%t_opt_c(j), &
543: | ' + T*',t_photo%t_opt_b(j), &
544: | ' + T^2*',t_photo%t_opt_a(j)
545: | WRITE(numout,*) ' max. temperature for photosynthesis as a function of long term T (C):'
546: | WRITE(numout,*) ' ',t_photo%t_max_c(j), &
547: | ' + T*',t_photo%t_max_b(j), &
548: | ' + T^2*',t_photo%t_max_a(j)
549: | ENDIF
550: |
551: | !
552: | ! 26 corresponding PFT number in Sechiba
553: | !
554: |
555: | IF ( bavard .GE. 1 ) THEN
556: |
557: | WRITE(numout,*) ' corresponding PFT number in Sechiba:', ipft_sechiba(j)
558: |
559: | WRITE(numout,*) ' Slope of the gs/A relation:', &
560: | gsslope(ipft_sechiba(j))
561: | WRITE(numout,*) ' Intercept of the gs/A relation:', &
562: | gsoffset(ipft_sechiba(j))
563: | WRITE(numout,*) ' C4 photosynthesis:', is_c4(ipft_sechiba(j))
564: | WRITE(numout,*) ' Depth constant for root profile (m):', &
565: | 1./humcste(ipft_sechiba(j))
566: |
567: | ENDIF
568: |
569: | !
570: | ! 27 extinction coefficient of the Monsi&Seaki (53) relationship
571: | !
572: |
573: | ext_coeff(j) = ext_coef(ipft_sechiba(j))
574: |
575: | IF ( bavard .GE. 1 ) THEN
576: | WRITE(numout,*) ' extinction coefficient:', ext_coeff(j)
577: | ENDIF
578: |
579: | !
580: | ! 28 check coherence between tree definitions
581: | ! this is not absolutely necessary (just security)
582: | !
583: |
584: | IF ( tree(j) .NEQV. is_tree(ipft_sechiba(j)) ) THEN
585: | STOP 'Definition of tree/not tree not coherent'
586: | ENDIF
587: |
588: +------ ENDDO
589:
590: !
591: ! 29 time scales for phenology and other processes (in days)
592: !
593:
594: pheno_crit%tau_hum_month = 20. ! (!)
595:
596: pheno_crit%tau_hum_week = 7.
597:
598: pheno_crit%tau_t2m_month = 20. ! (!)
599:
600: pheno_crit%tau_t2m_week = 7.
601:
602: pheno_crit%tau_tsoil_month = 20. ! (!)
603:
604: pheno_crit%tau_soilhum_month = 20. ! (!)
605:
606: pheno_crit%tau_gpp_week = 7.
607:
608: pheno_crit%tau_gdd = 40.
609:
610: pheno_crit%tau_ngd = 50.
611:
612: pheno_crit%tau_longterm = 3. * one_year
613:
614: IF ( bavard .GE. 1 ) THEN
615:
616: WRITE(numout,*) ' > time scale for ''monthly'' moisture availability (d):', &
617: pheno_crit%tau_hum_month
618: WRITE(numout,*) ' > time scale for ''weekly'' moisture availability (d):', &
619: pheno_crit%tau_hum_week
620: WRITE(numout,*) ' > time scale for ''monthly'' 2 meter temperature (d):', &
621: pheno_crit%tau_t2m_month
622: WRITE(numout,*) ' > time scale for ''weekly'' 2 meter temperature (d):', &
623: pheno_crit%tau_t2m_week
624: WRITE(numout,*) ' > time scale for ''weekly'' GPP (d):', &
625: pheno_crit%tau_gpp_week
626: WRITE(numout,*) ' > time scale for ''monthly'' soil temperature (d):', &
627: pheno_crit%tau_tsoil_month
628: WRITE(numout,*) ' > time scale for ''monthly'' soil humidity (d):', &
629: pheno_crit%tau_soilhum_month
630: WRITE(numout,*) ' > time scale for vigour calculations (y):', &
631: pheno_crit%tau_longterm / one_year
632:
633: ENDIF
634:
635: !
636: ! 30 fraction of allocatable biomass which is lost as growth respiration
637: !
638:
639: IF ( bavard .GE. 1 ) &
640: WRITE(numout,*) ' > growth respiration fraction:', frac_growthresp
641:
642: !
643: ! 31 count number of Stomate-PFTs that correpond to each Sechiba-PFT. Normally result
644: ! is 1 for plants, except if we introduce age classes in Stomate and not in Sechiba.
645: !
646:
647: +------> DO j = 1, nvm
648: |
649: |V===== npft_stomate(j) = COUNT( ipft_sechiba(:) .EQ. j )
650: |
651: | IF ( bavard .GE. 1 ) &
652: | WRITE(numout,'(a,i2,a,i2,a)') ' > Sechiba-PFT #',j,' corresponds to ',&
653: | npft_stomate(j),' Stomate-PFTs.'
654: |
655: +------ ENDDO
656:
657: IF (bavard.GE.4) WRITE(numout,*) 'Leaving data'
658:
659: END SUBROUTINE data
660:
661: END MODULE stomate_data
ORCHIDEE/src_stomate/i.stomate_io.L 0000754 0103600 0005670 00000467707 11164403473 017004 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:30 2008
FILE NAME: i.stomate_io.f90
PROGRAM NAME: stomate_io
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
296 vec ( 3): Unvectorized loop.
302 vec ( 9): Vectorization obstructive statement.
306 vec ( 3): Unvectorized loop.
312 vec ( 9): Vectorization obstructive statement.
316 vec ( 3): Unvectorized loop.
322 vec ( 9): Vectorization obstructive statement.
364 opt (1592): Outer loop unrolled inside inner loop.
364 vec ( 4): Vectorized array expression.
368 opt (1592): Outer loop unrolled inside inner loop.
368 opt (1084): Branch out of the loop inhibits optimization.
368 opt (1592): Outer loop unrolled inside inner loop.
368 vec ( 4): Vectorized array expression.
368 vec ( 4): Vectorized array expression.
368 vec ( 26): Macro operation Search.
368 vec ( 4): Vectorized array expression.
370 vec ( 4): Vectorized array expression.
374 opt (1084): Branch out of the loop inhibits optimization.
374 vec ( 4): Vectorized array expression.
374 vec ( 4): Vectorized array expression.
374 vec ( 26): Macro operation Search.
374 vec ( 4): Vectorized array expression.
376 vec ( 4): Vectorized array expression.
380 opt (1084): Branch out of the loop inhibits optimization.
380 vec ( 4): Vectorized array expression.
380 vec ( 4): Vectorized array expression.
380 vec ( 26): Macro operation Search.
380 vec ( 4): Vectorized array expression.
382 vec ( 4): Vectorized array expression.
386 opt (1084): Branch out of the loop inhibits optimization.
386 vec ( 4): Vectorized array expression.
386 vec ( 4): Vectorized array expression.
386 vec ( 26): Macro operation Search.
386 vec ( 4): Vectorized array expression.
388 vec ( 4): Vectorized array expression.
392 opt (1084): Branch out of the loop inhibits optimization.
392 vec ( 4): Vectorized array expression.
392 vec ( 4): Vectorized array expression.
392 vec ( 26): Macro operation Search.
392 vec ( 4): Vectorized array expression.
394 opt (1592): Outer loop unrolled inside inner loop.
394 vec ( 4): Vectorized array expression.
394 vec ( 4): Vectorized array expression.
398 opt (1592): Outer loop unrolled inside inner loop.
398 opt (1084): Branch out of the loop inhibits optimization.
398 opt (1592): Outer loop unrolled inside inner loop.
398 vec ( 4): Vectorized array expression.
398 vec ( 4): Vectorized array expression.
398 vec ( 4): Vectorized array expression.
398 vec ( 26): Macro operation Search.
398 vec ( 4): Vectorized array expression.
398 vec ( 4): Vectorized array expression.
400 opt (1592): Outer loop unrolled inside inner loop.
400 vec ( 4): Vectorized array expression.
400 vec ( 4): Vectorized array expression.
404 opt (1592): Outer loop unrolled inside inner loop.
404 opt (1084): Branch out of the loop inhibits optimization.
404 opt (1592): Outer loop unrolled inside inner loop.
404 vec ( 4): Vectorized array expression.
404 vec ( 4): Vectorized array expression.
404 vec ( 4): Vectorized array expression.
404 vec ( 26): Macro operation Search.
404 vec ( 4): Vectorized array expression.
404 vec ( 4): Vectorized array expression.
406 vec ( 4): Vectorized array expression.
410 opt (1084): Branch out of the loop inhibits optimization.
410 vec ( 4): Vectorized array expression.
410 vec ( 4): Vectorized array expression.
410 vec ( 26): Macro operation Search.
410 vec ( 4): Vectorized array expression.
414 opt (1592): Outer loop unrolled inside inner loop.
414 vec ( 4): Vectorized array expression.
418 opt (1592): Outer loop unrolled inside inner loop.
418 opt (1084): Branch out of the loop inhibits optimization.
418 opt (1592): Outer loop unrolled inside inner loop.
418 vec ( 4): Vectorized array expression.
418 vec ( 4): Vectorized array expression.
418 vec ( 26): Macro operation Search.
418 vec ( 4): Vectorized array expression.
420 opt (1592): Outer loop unrolled inside inner loop.
420 vec ( 4): Vectorized array expression.
424 opt (1592): Outer loop unrolled inside inner loop.
424 opt (1084): Branch out of the loop inhibits optimization.
424 opt (1592): Outer loop unrolled inside inner loop.
424 vec ( 4): Vectorized array expression.
424 vec ( 4): Vectorized array expression.
424 vec ( 26): Macro operation Search.
424 vec ( 4): Vectorized array expression.
426 opt (1593): Loop nest collapsed into one loop.
426 vec ( 4): Vectorized array expression.
427 vec ( 3): Unvectorized loop.
433 opt (1084): Branch out of the loop inhibits optimization.
433 opt (1593): Loop nest collapsed into one loop.
433 opt (1592): Outer loop unrolled inside inner loop.
433 vec ( 4): Vectorized array expression.
433 vec ( 4): Vectorized array expression.
433 vec ( 26): Macro operation Search.
433 vec ( 4): Vectorized array expression.
439 opt (1592): Outer loop unrolled inside inner loop.
439 vec ( 4): Vectorized array expression.
443 opt (1592): Outer loop unrolled inside inner loop.
443 opt (1084): Branch out of the loop inhibits optimization.
443 opt (1592): Outer loop unrolled inside inner loop.
443 vec ( 4): Vectorized array expression.
443 vec ( 4): Vectorized array expression.
443 vec ( 26): Macro operation Search.
443 vec ( 4): Vectorized array expression.
445 opt (1592): Outer loop unrolled inside inner loop.
445 vec ( 4): Vectorized array expression.
449 opt (1592): Outer loop unrolled inside inner loop.
449 opt (1084): Branch out of the loop inhibits optimization.
449 opt (1592): Outer loop unrolled inside inner loop.
449 vec ( 4): Vectorized array expression.
449 vec ( 4): Vectorized array expression.
449 vec ( 26): Macro operation Search.
449 vec ( 4): Vectorized array expression.
451 vec ( 4): Vectorized array expression.
455 opt (1084): Branch out of the loop inhibits optimization.
455 vec ( 4): Vectorized array expression.
455 vec ( 4): Vectorized array expression.
455 vec ( 26): Macro operation Search.
455 vec ( 4): Vectorized array expression.
461 vec ( 4): Vectorized array expression.
465 opt (1084): Branch out of the loop inhibits optimization.
465 vec ( 4): Vectorized array expression.
465 vec ( 4): Vectorized array expression.
465 vec ( 26): Macro operation Search.
465 vec ( 4): Vectorized array expression.
468 vec ( 4): Vectorized array expression.
472 opt (1084): Branch out of the loop inhibits optimization.
472 vec ( 4): Vectorized array expression.
472 vec ( 4): Vectorized array expression.
472 vec ( 26): Macro operation Search.
472 vec ( 4): Vectorized array expression.
474 vec ( 4): Vectorized array expression.
478 opt (1084): Branch out of the loop inhibits optimization.
478 vec ( 4): Vectorized array expression.
478 vec ( 4): Vectorized array expression.
478 vec ( 26): Macro operation Search.
478 vec ( 4): Vectorized array expression.
480 opt (1592): Outer loop unrolled inside inner loop.
480 vec ( 4): Vectorized array expression.
480 vec ( 4): Vectorized array expression.
485 opt (1592): Outer loop unrolled inside inner loop.
485 opt (1084): Branch out of the loop inhibits optimization.
485 vec ( 4): Vectorized array expression.
485 vec ( 4): Vectorized array expression.
485 vec ( 4): Vectorized array expression.
485 vec ( 26): Macro operation Search.
486 vec ( 3): Unvectorized loop.
486 vec ( 13): Overhead of loop division is too large.
487 opt (1592): Outer loop unrolled inside inner loop.
487 vec ( 4): Vectorized array expression.
487 vec ( 4): Vectorized array expression.
491 opt (1592): Outer loop unrolled inside inner loop.
491 vec ( 4): Vectorized array expression.
491 vec ( 4): Vectorized array expression.
495 vec ( 4): Vectorized array expression.
495 vec ( 4): Vectorized array expression.
495 vec ( 4): Vectorized array expression.
495 vec ( 26): Macro operation Search.
495 vec ( 4): Vectorized array expression.
495 vec ( 4): Vectorized array expression.
499 vec ( 4): Vectorized array expression.
503 vec ( 4): Vectorized array expression.
503 vec ( 4): Vectorized array expression.
503 vec ( 26): Macro operation Search.
503 vec ( 4): Vectorized array expression.
505 vec ( 4): Vectorized array expression.
509 vec ( 4): Vectorized array expression.
509 vec ( 4): Vectorized array expression.
509 vec ( 26): Macro operation Search.
509 vec ( 4): Vectorized array expression.
513 vec ( 4): Vectorized array expression.
517 vec ( 4): Vectorized array expression.
517 vec ( 4): Vectorized array expression.
517 vec ( 26): Macro operation Search.
517 vec ( 4): Vectorized array expression.
520 vec ( 4): Vectorized array expression.
524 vec ( 4): Vectorized array expression.
524 vec ( 4): Vectorized array expression.
524 vec ( 26): Macro operation Search.
524 vec ( 4): Vectorized array expression.
527 vec ( 4): Vectorized array expression.
531 vec ( 4): Vectorized array expression.
531 vec ( 4): Vectorized array expression.
531 vec ( 26): Macro operation Search.
531 vec ( 4): Vectorized array expression.
534 vec ( 4): Vectorized array expression.
538 vec ( 4): Vectorized array expression.
538 vec ( 4): Vectorized array expression.
538 vec ( 26): Macro operation Search.
538 vec ( 4): Vectorized array expression.
543 vec ( 4): Vectorized array expression.
547 vec ( 4): Vectorized array expression.
547 vec ( 4): Vectorized array expression.
547 vec ( 26): Macro operation Search.
547 vec ( 4): Vectorized array expression.
550 vec ( 4): Vectorized array expression.
554 vec ( 4): Vectorized array expression.
554 vec ( 4): Vectorized array expression.
554 vec ( 26): Macro operation Search.
554 vec ( 4): Vectorized array expression.
559 vec ( 4): Vectorized array expression.
563 vec ( 4): Vectorized array expression.
563 vec ( 4): Vectorized array expression.
563 vec ( 26): Macro operation Search.
563 vec ( 4): Vectorized array expression.
565 vec ( 4): Vectorized array expression.
569 vec ( 4): Vectorized array expression.
569 vec ( 4): Vectorized array expression.
569 vec ( 26): Macro operation Search.
569 vec ( 4): Vectorized array expression.
573 vec ( 4): Vectorized array expression.
577 vec ( 4): Vectorized array expression.
577 vec ( 4): Vectorized array expression.
577 vec ( 26): Macro operation Search.
577 vec ( 4): Vectorized array expression.
579 vec ( 4): Vectorized array expression.
583 vec ( 4): Vectorized array expression.
583 vec ( 4): Vectorized array expression.
583 vec ( 26): Macro operation Search.
583 vec ( 4): Vectorized array expression.
588 vec ( 4): Vectorized array expression.
592 vec ( 4): Vectorized array expression.
592 vec ( 4): Vectorized array expression.
592 vec ( 26): Macro operation Search.
592 vec ( 4): Vectorized array expression.
595 vec ( 4): Vectorized array expression.
599 vec ( 4): Vectorized array expression.
599 vec ( 4): Vectorized array expression.
599 vec ( 26): Macro operation Search.
599 vec ( 4): Vectorized array expression.
601 vec ( 4): Vectorized array expression.
605 vec ( 4): Vectorized array expression.
605 vec ( 4): Vectorized array expression.
605 vec ( 26): Macro operation Search.
605 vec ( 4): Vectorized array expression.
607 vec ( 4): Vectorized array expression.
611 vec ( 4): Vectorized array expression.
611 vec ( 4): Vectorized array expression.
611 vec ( 26): Macro operation Search.
611 vec ( 4): Vectorized array expression.
613 vec ( 4): Vectorized array expression.
617 vec ( 4): Vectorized array expression.
617 vec ( 4): Vectorized array expression.
617 vec ( 26): Macro operation Search.
617 vec ( 4): Vectorized array expression.
619 vec ( 4): Vectorized array expression.
623 vec ( 4): Vectorized array expression.
623 vec ( 4): Vectorized array expression.
623 vec ( 26): Macro operation Search.
623 vec ( 4): Vectorized array expression.
625 vec ( 4): Vectorized array expression.
629 vec ( 4): Vectorized array expression.
629 vec ( 4): Vectorized array expression.
629 vec ( 26): Macro operation Search.
629 vec ( 4): Vectorized array expression.
634 vec ( 4): Vectorized array expression.
638 vec ( 4): Vectorized array expression.
638 vec ( 4): Vectorized array expression.
638 vec ( 26): Macro operation Search.
638 vec ( 4): Vectorized array expression.
639 vec ( 4): Vectorized array expression.
645 vec ( 4): Vectorized array expression.
649 vec ( 4): Vectorized array expression.
649 vec ( 4): Vectorized array expression.
649 vec ( 26): Macro operation Search.
649 vec ( 4): Vectorized array expression.
651 vec ( 4): Vectorized array expression.
655 vec ( 4): Vectorized array expression.
655 vec ( 4): Vectorized array expression.
655 vec ( 26): Macro operation Search.
655 vec ( 4): Vectorized array expression.
657 vec ( 4): Vectorized array expression.
661 vec ( 4): Vectorized array expression.
661 vec ( 4): Vectorized array expression.
661 vec ( 26): Macro operation Search.
661 vec ( 4): Vectorized array expression.
663 vec ( 4): Vectorized array expression.
667 vec ( 4): Vectorized array expression.
667 vec ( 4): Vectorized array expression.
667 vec ( 26): Macro operation Search.
667 vec ( 4): Vectorized array expression.
669 vec ( 4): Vectorized array expression.
673 vec ( 4): Vectorized array expression.
673 vec ( 4): Vectorized array expression.
673 vec ( 26): Macro operation Search.
673 vec ( 4): Vectorized array expression.
675 vec ( 4): Vectorized array expression.
679 vec ( 4): Vectorized array expression.
679 vec ( 4): Vectorized array expression.
679 vec ( 26): Macro operation Search.
679 vec ( 4): Vectorized array expression.
681 vec ( 4): Vectorized array expression.
685 vec ( 4): Vectorized array expression.
685 vec ( 4): Vectorized array expression.
685 vec ( 26): Macro operation Search.
685 vec ( 4): Vectorized array expression.
687 vec ( 4): Vectorized array expression.
691 vec ( 4): Vectorized array expression.
691 vec ( 4): Vectorized array expression.
691 vec ( 26): Macro operation Search.
691 vec ( 4): Vectorized array expression.
693 vec ( 4): Vectorized array expression.
697 vec ( 4): Vectorized array expression.
697 vec ( 4): Vectorized array expression.
697 vec ( 26): Macro operation Search.
697 vec ( 4): Vectorized array expression.
698 opt (1593): Loop nest collapsed into one loop.
698 vec ( 4): Vectorized array expression.
699 vec ( 3): Unvectorized loop.
705 opt (1593): Loop nest collapsed into one loop.
705 vec ( 4): Vectorized array expression.
705 vec ( 4): Vectorized array expression.
705 vec ( 26): Macro operation Search.
705 vec ( 4): Vectorized array expression.
709 vec ( 4): Vectorized array expression.
713 vec ( 4): Vectorized array expression.
713 vec ( 4): Vectorized array expression.
713 vec ( 26): Macro operation Search.
713 vec ( 4): Vectorized array expression.
715 opt (1593): Loop nest collapsed into one loop.
715 vec ( 4): Vectorized array expression.
716 vec ( 3): Unvectorized loop.
722 opt (1593): Loop nest collapsed into one loop.
722 vec ( 4): Vectorized array expression.
722 vec ( 4): Vectorized array expression.
722 vec ( 26): Macro operation Search.
722 vec ( 4): Vectorized array expression.
726 opt (1593): Loop nest collapsed into one loop.
726 vec ( 4): Vectorized array expression.
727 vec ( 3): Unvectorized loop.
733 opt (1593): Loop nest collapsed into one loop.
733 vec ( 4): Vectorized array expression.
733 vec ( 4): Vectorized array expression.
733 vec ( 26): Macro operation Search.
733 vec ( 4): Vectorized array expression.
736 vec ( 4): Vectorized array expression.
740 vec ( 4): Vectorized array expression.
740 vec ( 4): Vectorized array expression.
740 vec ( 26): Macro operation Search.
740 vec ( 4): Vectorized array expression.
742 vec ( 4): Vectorized array expression.
746 vec ( 4): Vectorized array expression.
746 vec ( 4): Vectorized array expression.
746 vec ( 26): Macro operation Search.
746 vec ( 4): Vectorized array expression.
748 opt (1593): Loop nest collapsed into one loop.
748 vec ( 4): Vectorized array expression.
748 vec ( 4): Vectorized array expression.
748 vec ( 4): Vectorized array expression.
748 vec ( 4): Vectorized array expression.
749 vec ( 3): Unvectorized loop.
755 opt (1593): Loop nest collapsed into one loop.
755 vec ( 4): Vectorized array expression.
755 vec ( 4): Vectorized array expression.
755 vec ( 26): Macro operation Search.
755 vec ( 4): Vectorized array expression.
758 opt (1593): Loop nest collapsed into one loop.
758 vec ( 4): Vectorized array expression.
758 vec ( 4): Vectorized array expression.
758 vec ( 4): Vectorized array expression.
758 vec ( 4): Vectorized array expression.
759 vec ( 3): Unvectorized loop.
765 opt (1593): Loop nest collapsed into one loop.
765 vec ( 4): Vectorized array expression.
765 vec ( 4): Vectorized array expression.
765 vec ( 26): Macro operation Search.
765 vec ( 4): Vectorized array expression.
768 vec ( 4): Vectorized array expression.
772 vec ( 4): Vectorized array expression.
772 vec ( 4): Vectorized array expression.
772 vec ( 26): Macro operation Search.
772 vec ( 4): Vectorized array expression.
773 vec ( 4): Vectorized array expression.
779 vec ( 4): Vectorized array expression.
783 vec ( 4): Vectorized array expression.
783 vec ( 4): Vectorized array expression.
783 vec ( 26): Macro operation Search.
783 vec ( 4): Vectorized array expression.
786 vec ( 4): Vectorized array expression.
790 vec ( 4): Vectorized array expression.
790 vec ( 4): Vectorized array expression.
790 vec ( 26): Macro operation Search.
790 vec ( 4): Vectorized array expression.
794 vec ( 4): Vectorized array expression.
794 vec ( 4): Vectorized array expression.
798 vec ( 4): Vectorized array expression.
798 vec ( 4): Vectorized array expression.
798 vec ( 4): Vectorized array expression.
798 vec ( 26): Macro operation Search.
798 vec ( 4): Vectorized array expression.
798 vec ( 26): Macro operation Search.
798 vec ( 4): Vectorized array expression.
798 vec ( 4): Vectorized array expression.
800 vec ( 4): Vectorized array expression.
804 vec ( 4): Vectorized array expression.
804 vec ( 4): Vectorized array expression.
804 vec ( 26): Macro operation Search.
804 vec ( 4): Vectorized array expression.
806 vec ( 4): Vectorized array expression.
810 vec ( 4): Vectorized array expression.
810 vec ( 4): Vectorized array expression.
810 vec ( 26): Macro operation Search.
810 vec ( 4): Vectorized array expression.
812 vec ( 4): Vectorized array expression.
816 vec ( 4): Vectorized array expression.
816 vec ( 4): Vectorized array expression.
816 vec ( 26): Macro operation Search.
816 vec ( 4): Vectorized array expression.
818 vec ( 4): Vectorized array expression.
822 vec ( 4): Vectorized array expression.
822 vec ( 4): Vectorized array expression.
822 vec ( 26): Macro operation Search.
822 vec ( 4): Vectorized array expression.
826 vec ( 4): Vectorized array expression.
830 vec ( 4): Vectorized array expression.
830 vec ( 4): Vectorized array expression.
830 vec ( 26): Macro operation Search.
830 vec ( 4): Vectorized array expression.
834 vec ( 4): Vectorized array expression.
838 vec ( 4): Vectorized array expression.
838 vec ( 4): Vectorized array expression.
838 vec ( 26): Macro operation Search.
838 vec ( 4): Vectorized array expression.
840 vec ( 4): Vectorized array expression.
844 vec ( 4): Vectorized array expression.
844 vec ( 4): Vectorized array expression.
844 vec ( 26): Macro operation Search.
844 vec ( 4): Vectorized array expression.
846 vec ( 4): Vectorized array expression.
852 vec ( 4): Vectorized array expression.
856 vec ( 4): Vectorized array expression.
856 vec ( 4): Vectorized array expression.
856 vec ( 26): Macro operation Search.
856 vec ( 4): Vectorized array expression.
860 vec ( 4): Vectorized array expression.
864 vec ( 4): Vectorized array expression.
864 vec ( 4): Vectorized array expression.
864 vec ( 26): Macro operation Search.
864 vec ( 4): Vectorized array expression.
868 opt (1593): Loop nest collapsed into one loop.
868 vec ( 4): Vectorized array expression.
868 vec ( 4): Vectorized array expression.
869 vec ( 3): Unvectorized loop.
873 opt (1593): Loop nest collapsed into one loop.
873 vec ( 4): Vectorized array expression.
873 vec ( 4): Vectorized array expression.
873 vec ( 26): Macro operation Search.
873 vec ( 4): Vectorized array expression.
876 vec ( 4): Vectorized array expression.
876 vec ( 4): Vectorized array expression.
876 vec ( 4): Vectorized array expression.
876 vec ( 4): Vectorized array expression.
876 vec ( 4): Vectorized array expression.
876 vec ( 4): Vectorized array expression.
876 vec ( 4): Vectorized array expression.
876 vec ( 4): Vectorized array expression.
878 vec ( 3): Unvectorized loop.
882 vec ( 4): Vectorized array expression.
882 vec ( 4): Vectorized array expression.
882 vec ( 4): Vectorized array expression.
882 vec ( 26): Macro operation Search.
882 vec ( 4): Vectorized array expression.
882 vec ( 26): Macro operation Search.
882 vec ( 4): Vectorized array expression.
882 vec ( 4): Vectorized array expression.
886 opt (1593): Loop nest collapsed into one loop.
886 vec ( 4): Vectorized array expression.
886 vec ( 4): Vectorized array expression.
887 vec ( 3): Unvectorized loop.
891 opt (1593): Loop nest collapsed into one loop.
891 vec ( 4): Vectorized array expression.
891 vec ( 4): Vectorized array expression.
891 vec ( 26): Macro operation Search.
891 vec ( 4): Vectorized array expression.
894 vec ( 4): Vectorized array expression.
894 vec ( 4): Vectorized array expression.
894 vec ( 4): Vectorized array expression.
894 vec ( 4): Vectorized array expression.
894 vec ( 4): Vectorized array expression.
894 vec ( 4): Vectorized array expression.
895 vec ( 3): Unvectorized loop.
899 vec ( 4): Vectorized array expression.
899 vec ( 4): Vectorized array expression.
899 vec ( 4): Vectorized array expression.
899 vec ( 4): Vectorized array expression.
899 vec ( 26): Macro operation Search.
899 vec ( 4): Vectorized array expression.
899 vec ( 26): Macro operation Search.
899 vec ( 4): Vectorized array expression.
899 vec ( 26): Macro operation Search.
899 vec ( 4): Vectorized array expression.
899 vec ( 4): Vectorized array expression.
899 vec ( 4): Vectorized array expression.
902 vec ( 4): Vectorized array expression.
902 vec ( 4): Vectorized array expression.
902 vec ( 4): Vectorized array expression.
902 vec ( 4): Vectorized array expression.
903 vec ( 3): Unvectorized loop.
908 vec ( 4): Vectorized array expression.
908 vec ( 4): Vectorized array expression.
908 vec ( 4): Vectorized array expression.
908 vec ( 26): Macro operation Search.
908 vec ( 4): Vectorized array expression.
908 vec ( 26): Macro operation Search.
908 vec ( 4): Vectorized array expression.
908 vec ( 4): Vectorized array expression.
913 vec ( 4): Vectorized array expression.
913 vec ( 4): Vectorized array expression.
917 vec ( 4): Vectorized array expression.
917 vec ( 4): Vectorized array expression.
917 vec ( 4): Vectorized array expression.
917 vec ( 26): Macro operation Search.
917 vec ( 4): Vectorized array expression.
917 vec ( 4): Vectorized array expression.
919 vec ( 4): Vectorized array expression.
919 vec ( 4): Vectorized array expression.
923 vec ( 4): Vectorized array expression.
923 vec ( 4): Vectorized array expression.
923 vec ( 4): Vectorized array expression.
923 vec ( 26): Macro operation Search.
923 vec ( 4): Vectorized array expression.
923 vec ( 4): Vectorized array expression.
926 vec ( 4): Vectorized array expression.
926 vec ( 4): Vectorized array expression.
930 vec ( 4): Vectorized array expression.
930 vec ( 4): Vectorized array expression.
930 vec ( 4): Vectorized array expression.
930 vec ( 26): Macro operation Search.
930 vec ( 4): Vectorized array expression.
930 vec ( 4): Vectorized array expression.
932 vec ( 4): Vectorized array expression.
936 vec ( 4): Vectorized array expression.
936 vec ( 4): Vectorized array expression.
936 vec ( 26): Macro operation Search.
936 vec ( 4): Vectorized array expression.
942 warn ( 83): Dummy argument "index" is not used.
1188 vec ( 3): Unvectorized loop.
1194 vec ( 9): Vectorization obstructive statement.
1198 vec ( 3): Unvectorized loop.
1204 vec ( 9): Vectorization obstructive statement.
1208 vec ( 3): Unvectorized loop.
1214 vec ( 9): Vectorization obstructive statement.
1294 vec ( 3): Unvectorized loop.
1295 opt (1017): Subroutine call prevents optimization.
1297 vec ( 9): Vectorization obstructive statement.
1298 vec ( 9): Vectorization obstructive statement.
1298 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1429 opt (1592): Outer loop unrolled inside inner loop.
1429 vec ( 4): Vectorized array expression.
1473 vec ( 3): Unvectorized loop.
1474 opt (1017): Subroutine call prevents optimization.
1476 vec ( 9): Vectorization obstructive statement.
1477 vec ( 9): Vectorization obstructive statement.
1477 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1485 vec ( 3): Unvectorized loop.
1486 opt (1017): Subroutine call prevents optimization.
1488 vec ( 9): Vectorization obstructive statement.
1489 vec ( 9): Vectorization obstructive statement.
1489 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1493 vec ( 3): Unvectorized loop.
1494 opt (1017): Subroutine call prevents optimization.
1496 vec ( 9): Vectorization obstructive statement.
1497 vec ( 9): Vectorization obstructive statement.
1497 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1509 vec ( 3): Unvectorized loop.
1512 vec ( 9): Vectorization obstructive statement.
1513 vec ( 9): Vectorization obstructive statement.
1513 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1517 vec ( 3): Unvectorized loop.
1520 vec ( 9): Vectorization obstructive statement.
1521 vec ( 9): Vectorization obstructive statement.
1521 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1526 opt (1592): Outer loop unrolled inside inner loop.
1526 vec ( 4): Vectorized array expression.
1577 opt (1592): Outer loop unrolled inside inner loop.
1577 vec ( 4): Vectorized array expression.
1597 vec ( 3): Unvectorized loop.
1599 vec ( 9): Vectorization obstructive statement.
1599 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1604 vec ( 3): Unvectorized loop.
1605 opt (1017): Subroutine call prevents optimization.
1606 vec ( 9): Vectorization obstructive statement.
1606 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1611 vec ( 3): Unvectorized loop.
1613 vec ( 9): Vectorization obstructive statement.
1613 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1617 vec ( 3): Unvectorized loop.
1619 vec ( 9): Vectorization obstructive statement.
1619 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1623 vec ( 3): Unvectorized loop.
1625 vec ( 9): Vectorization obstructive statement.
1625 vec ( 10): Vectorization obstructive procedure reference.:restput_p_opp_r2d
1649 warn ( 83): Dummy argument "index" is not used.
1807 vec ( 4): Vectorized array expression.
1807 vec ( 4): Vectorized array expression.
1808 opt (1592): Outer loop unrolled inside inner loop.
1811 vec ( 4): Vectorized array expression.
1814 vec ( 4): Vectorized array expression.
1819 vec ( 4): Vectorized array expression.
1822 vec ( 4): Vectorized array expression.
1827 vec ( 4): Vectorized array expression.
1829 vec ( 4): Vectorized array expression.
1837 vec ( 4): Vectorized array expression.
1842 vec ( 1): Vectorized loop.
1857 opt (1589): Outer loop moved inside inner loop(s).
1909 vec ( 3): Unvectorized loop.
1925 vec ( 9): Vectorization obstructive statement.
1964 vec ( 1): Vectorized loop.
1965 vec ( 26): Macro operation Sum/InnerProd.
1966 vec ( 26): Macro operation Sum/InnerProd.
1990 vec ( 4): Vectorized array expression.
2007 vec ( 4): Vectorized array expression.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1592): Outer loop unrolled inside inner loop.
2013 opt (1084): Branch out of the loop inhibits optimization.
2013 opt (1592): Outer loop unrolled inside inner loop.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:30 2008
FILE NAME: i.stomate_io.f90
PROGRAM NAME: stomate_io
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_io.f90,v 1.16 2007/06/13 07:53:08 ssipsl Exp $
2: ! IPSL (2006)
3: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
4: !
5: MODULE stomate_io
6: !---------------------------------------------------------------------
7: !- Not all variables saved in the start files are absolutely necessary.
8: !- Some variables may seem totally unnecessary (fvm and fv),
9: !- as the necessary information already exists in Sechiba.
10: !- However, Sechiba's and Stomate's PFTs are not necessarily identical,
11: !- and for that case this information needs to be saved.
12: !---------------------------------------------------------------------
13: USE ioipsl
14: USE stomate_constants
15: USE parallel
16: !-
17: IMPLICIT NONE
18: !-
19: PRIVATE
20: PUBLIC readstart, writerestart, readbc,get_reftemp_clear
21: !-
22: ! first call?
23: !-
24: LOGICAL,SAVE :: firstcall = .TRUE.
25: !-
26: ! reference temperature (K)
27: !-
28: REAL(r_std),ALLOCATABLE,DIMENSION(:),SAVE :: trefe
29: !-
30: CONTAINS
31: !-
32: !===
33: !-
34: SUBROUTINE readstart &
35: & (npts, index, lalo, resolution, day_counter, dt_days, date, &
36: & ind, adapted, regenerate, moiavail_daily, litterhum_daily, &
37: & t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
38: & soilhum_daily, precip_daily, &
39: & gpp_daily, npp_daily, turnover_daily, &
40: & moiavail_month, moiavail_week, t2m_longterm, tlong_ref, &
41: & t2m_month, t2m_week, tsoil_month, soilhum_month, &
42: & fireindex, firelitter, &
43: & maxmoiavail_lastyear, maxmoiavail_thisyear, &
44: & minmoiavail_lastyear, minmoiavail_thisyear, &
45: & maxgppweek_lastyear, maxgppweek_thisyear, &
46: & gdd0_lastyear, gdd0_thisyear, precip_lastyear, precip_thisyear, &
47: & gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
48: & PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
49: & maxfpc_lastyear, maxfpc_thisyear, &
50: & turnover_longterm, gpp_week, biomass, resp_maint_part, &
51: & fvm, fv, leaf_age, leaf_frac, senescence, when_growthinit, age, &
52: & resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
53: & veget_lastlight, everywhere, need_adjacent, RIP_time, &
54: & time_lowgpp, time_hum_min, hum_min_dormance, litterpart, litter, &
55: & dead_leaves, carbon, black_carbon, lignin_struc,turnover_time, &
56: & prod10,prod100,flux10, flux100)
57: ! deforestation variables added as arguments
58: !---------------------------------------------------------------------
59: !- read start file
60: !---------------------------------------------------------------------
61: !-
62: ! 0 declarations
63: !-
64: ! 0.1 input
65: !-
66: ! Domain size
67: INTEGER(i_std),INTENT(in) :: npts
68: ! Indices of the points on the map
69: INTEGER(i_std),DIMENSION(npts),INTENT(in) :: index
70: ! Geogr. coordinates (latitude,longitude) (degrees)
71: REAL(r_std),DIMENSION(npts,2),INTENT(in) :: lalo
72: ! size in x an y of the grid (m)
73: REAL(r_std),DIMENSION(npts,2),INTENT(in) :: resolution
74: !-
75: ! 0.2 output
76: !-
77: ! counts time until next STOMATE time step
78: REAL(r_std),INTENT(out) :: day_counter
79: ! time step of STOMATE in days
80: REAL(r_std),INTENT(out) :: dt_days
81: ! date (d)
82: INTEGER(i_std),INTENT(out) :: date
83: ! density of individuals (1/m**2)
84: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: ind
85: ! Winter too cold? between 0 and 1
86: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: adapted
87: ! Winter sufficiently cold? between 0 and 1
88: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: regenerate
89: ! daily moisture availability
90: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: moiavail_daily
91: ! daily litter humidity
92: REAL(r_std),DIMENSION(npts),INTENT(out) :: litterhum_daily
93: ! daily 2 meter temperatures (K)
94: REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_daily
95: ! daily minimum 2 meter temperatures (K)
96: REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_min_daily
97: ! daily surface temperatures (K)
98: REAL(r_std),DIMENSION(npts),INTENT(out) :: tsurf_daily
99: ! daily soil temperatures (K)
100: REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: tsoil_daily
101: ! daily soil humidity
102: REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: soilhum_daily
103: ! daily precipitations (mm/day) (for phenology)
104: REAL(r_std),DIMENSION(npts),INTENT(out) :: precip_daily
105: ! daily gross primary productivity (gC/m**2/day)
106: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: gpp_daily
107: ! daily net primary productivity (gC/m**2/day)
108: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: npp_daily
109: ! daily turnover rates (gC/m**2/day)
110: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(out) :: turnover_daily
111: ! "monthly" moisture availability
112: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: moiavail_month
113: ! "weekly" moisture availability
114: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: moiavail_week
115: ! "long term" 2 meter temperatures (K)
116: REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_longterm
117: ! "monthly" 2 meter temperatures (K)
118: REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_month
119: ! "weekly" 2 meter temperatures (K)
120: REAL(r_std),DIMENSION(npts),INTENT(out) :: t2m_week
121: ! "monthly" soil temperatures (K)
122: REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: tsoil_month
123: ! "monthly" soil humidity
124: REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: soilhum_month
125: ! Probability of fire
126: REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(out) :: fireindex
127: ! Longer term total litter above the ground, gC/m**2 of nat/agri ground
128: REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(out) :: firelitter
129: ! last year's maximum moisture availability
130: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxmoiavail_lastyear
131: ! this year's maximum moisture availability
132: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxmoiavail_thisyear
133: ! last year's minimum moisture availability
134: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: minmoiavail_lastyear
135: ! this year's minimum moisture availability
136: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: minmoiavail_thisyear
137: ! last year's maximum weekly GPP
138: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxgppweek_lastyear
139: ! this year's maximum weekly GPP
140: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxgppweek_thisyear
141: ! last year's annual GDD0
142: REAL(r_std),DIMENSION(npts),INTENT(out) :: gdd0_lastyear
143: ! this year's annual GDD0
144: REAL(r_std),DIMENSION(npts),INTENT(out) :: gdd0_thisyear
145: ! last year's annual precipitation (mm/year)
146: REAL(r_std),DIMENSION(npts),INTENT(out) :: precip_lastyear
147: ! this year's annual precipitation (mm/year)
148: REAL(r_std),DIMENSION(npts),INTENT(out) :: precip_thisyear
149: ! growing degree days, threshold -5 deg C (for phenology)
150: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: gdd_m5_dormance
151: ! growing degree days since midwinter (for phenology)
152: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: gdd_midwinter
153: ! number of chilling days since leaves were lost (for phenology)
154: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: ncd_dormance
155: ! number of growing days, threshold -5 deg C (for phenology)
156: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: ngd_minus5
157: ! PFT exists (equivalent to fpc_max > 0 for natural PFTs)
158: LOGICAL,DIMENSION(npts,npft),INTENT(out) :: PFTpresent
159: ! "long term" net primary productivity (gC/m**2/year)
160: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: npp_longterm
161: ! last year's maximum leaf mass, for each PFT (gC/m**2)
162: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: lm_lastyearmax
163: ! this year's maximum leaf mass, for each PFT (gC/m**2)
164: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: lm_thisyearmax
165: ! last year's maximum fpc for each natural PFT, on *natural* ground
166: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxfpc_lastyear
167: ! this year's maximum fpc for each PFT,
168: ! on *total* ground (see stomate_season)
169: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: maxfpc_thisyear
170: ! "long term" turnover rate (gC/m**2/year)
171: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(out) :: turnover_longterm
172: ! "weekly" GPP (gC/day/(m**2 covered)
173: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: gpp_week
174: ! biomass (gC/m**2)
175: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(out) :: biomass
176: ! maintenance resp (gC/m**2)
177: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(out) :: resp_maint_part
178: ! factor to convert veget_x into veget
179: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: fv
180: ! factor to convert veget_max_x into veget_max
181: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: fvm
182: ! leaf age (days)
183: REAL(r_std),DIMENSION(npts,npft,nleafages),INTENT(out) :: leaf_age
184: ! fraction of leaves in leaf age class
185: REAL(r_std),DIMENSION(npts,npft,nleafages),INTENT(out) :: leaf_frac
186: ! is the plant senescent ?
187: !(only for deciduous trees - carbohydrate reserve)
188: LOGICAL,DIMENSION(npts,npft),INTENT(out) :: senescence
189: ! how many days ago was the beginning of the growing season
190: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: when_growthinit
191: ! mean age (years)
192: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: age
193: ! heterotrophic respiration (gC/day/m**2)
194: REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(out) :: resp_hetero
195: ! maintenance respiration (gC/day/m**2)
196: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: resp_maint
197: ! growth respiration (gC/day/m**2)
198: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: resp_growth
199: ! carbon emitted into the atmosphere by fire (living and dead biomass)
200: ! (in gC/m**2/time step)
201: REAL(r_std),DIMENSION(npts),INTENT(out) :: co2_fire
202: ! biomass uptaken (gC/(m**2 of total ground)/day)
203: REAL(r_std),DIMENSION(npts),INTENT(out) :: co2_to_bm_dgvm
204: ! vegetation fractions
205: ! (on natural/agri ground) after last light competition
206: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: veget_lastlight
207: ! is the PFT everywhere in the grid box or very localized
208: ! (after its introduction)
209: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: everywhere
210: ! in order for this PFT to be introduced,
211: ! does it have to be present in an adjacent grid box?
212: LOGICAL,DIMENSION(npts,npft),INTENT(out) :: need_adjacent
213: ! How much time ago was the PFT eliminated for the last time (y)
214: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: RIP_time
215: ! duration of dormance (d)
216: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: time_lowgpp
217: ! time elapsed since strongest moisture availability (d)
218: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: time_hum_min
219: ! minimum moisture during dormance
220: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: hum_min_dormance
221: ! fraction of litter above the ground belonging to different PFTs
222: ! separated for natural and agricultural PFTs.
223: REAL(r_std),DIMENSION(npts,npft,nlitt),INTENT(out) :: litterpart
224: ! metabolic and structural litter, natural and agricultural,
225: ! above and below ground (gC/m**2)
226: REAL(r_std),DIMENSION(npts,nlitt,nvegtypes,nlevs),INTENT(out):: litter
227: ! dead leaves on ground, per PFT, metabolic and structural,
228: ! in gC/(m**2 of nat/agri ground)
229: REAL(r_std),DIMENSION(npts,npft,nlitt),INTENT(out) :: dead_leaves
230: ! carbon pool: active, slow, or passive, natural and agricultural
231: ! (gC/m**2)
232: REAL(r_std),DIMENSION(npts,ncarb,nvegtypes),INTENT(out) :: carbon
233: ! black carbon on the ground (gC/(m**2 of total ground))
234: REAL(r_std),DIMENSION(npts),INTENT(out) :: black_carbon
235: ! ratio Lignine/Carbon in structural litter, above and below ground,
236: ! natural and agricultural (gC/m**2)
237: REAL(r_std),DIMENSION(npts,nvegtypes,nlevs),INTENT(out) :: lignin_struc
238: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: turnover_time
239: !-
240: ! 0.3 not necessarily output
241: !-
242: ! "long term" reference 2 meter temperatures (K)
243: REAL(r_std),DIMENSION(npts),INTENT(inout) :: tlong_ref
244: !-
245: ! 0.4 local
246: !-
247: ! date, real
248: REAL(r_std) :: date_real
249: ! PFT exists (equivalent to fpc_max > 0 for natural PFTs), real
250: REAL(r_std),DIMENSION(npts,npft) :: PFTpresent_real
251: ! is the plant senescent ?
252: ! (only for deciduous trees - carbohydrate reserve), real
253: REAL(r_std),DIMENSION(npts,npft) :: senescence_real
254: ! in order for this PFT to be introduced,
255: ! does it have to be present in an adjacent grid box? - real
256: REAL(r_std),DIMENSION(npts,npft) :: need_adjacent_real
257: ! To store variables names for I/O
258: CHARACTER(LEN=80) :: var_name
259: ! string suffix indicating an index
260: CHARACTER(LEN=10) :: part_str
261: ! string suffix indicating litter type
262: CHARACTER(LEN=3),DIMENSION(nlitt) :: litter_str
263: ! string suffix indicating vegetation type
264: CHARACTER(LEN=3),DIMENSION(nvegtypes) :: vegtype_str
265: ! string suffix indicating level
266: CHARACTER(LEN=2),DIMENSION(nlevs) :: level_str
267: ! temporary storage
268: REAL(r_std),DIMENSION(1) :: xtmp
269: ! index
270: INTEGER(i_std) :: k,l,m
271: ! reference temperature (K)
272: REAL(r_std),DIMENSION(npts) :: tref
273:
274: ! deforestation variables
275: ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
276: ! (10 or 100 + 1 : input from year of deforestation)
277: REAL(r_std),DIMENSION(npts,0:10),INTENT(out) :: prod10
278: REAL(r_std),DIMENSION(npts,0:100),INTENT(out) :: prod100
279: ! annual release from the 10/100 year-turnover pool compartments
280: REAL(r_std),DIMENSION(npts,10),INTENT(out) :: flux10
281: REAL(r_std),DIMENSION(npts,100),INTENT(out) :: flux100
282:
283: !---------------------------------------------------------------------
284: IF (bavard >= 3) WRITE(numout,*) 'Entering readstart'
285: !-
286: ! 0 When the vegetation is dynamic,
287: ! the long-term reference temperature is prognostic.
288: ! In this case, it is read from the restart file.
289: ! If the corresponding field does not exist in the restart file,
290: ! read it from another file in order to initialize it correctly.
291: !-
292: CALL get_reftemp( npts, lalo, resolution, tref )
293: !-
294: ! 1 string definitions
295: !-
296: +------> DO m=1,nvegtypes
297: | IF (m == inat) THEN
298: | vegtype_str(m) = 'nat'
299: | ELSEIF (m == iagri) THEN
300: | vegtype_str(m) = 'agr'
301: | ELSE
302: | STOP 'Define vegtype_str'
303: | ENDIF
304: +------ ENDDO
305: !-
306: +------> DO l=1,nlitt
307: | IF (l == imetabolic) THEN
308: | litter_str(l) = 'met'
309: | ELSEIF (l == istructural) THEN
310: | litter_str(l) = 'str'
311: | ELSE
312: | STOP 'Define litter_str'
313: | ENDIF
314: +------ ENDDO
315: !-
316: +------> DO l=1,nlevs
317: | IF (l == iabove) THEN
318: | level_str(l) = 'ab'
319: | ELSEIF (l == ibelow) THEN
320: | level_str(l) = 'be'
321: | ELSE
322: | STOP 'Define level_str'
323: | ENDIF
324: +------ ENDDO
325: !-
326: ! 2 run control
327: !-
328: ! 2.1 day counter
329: !-
330: IF (is_root_prc) THEN
331: var_name = 'day_counter'
332: CALL restget (rest_id_stomate, var_name, 1 , 1 , 1, itime, &
333: & .TRUE., xtmp)
334: day_counter = xtmp(1)
335: IF (day_counter == val_exp) day_counter = 1.
336: ENDIF
337: CALL bcast(day_counter)
338: !-
339: ! 2.2 time step of STOMATE in days
340: !-
341: IF (is_root_prc) THEN
342: var_name = 'dt_days'
343: CALL restget (rest_id_stomate, var_name, 1 , 1 , 1, itime, &
344: & .TRUE., xtmp)
345: dt_days = xtmp(1)
346: IF (dt_days == val_exp) dt_days = 1.
347: ENDIF
348: CALL bcast(dt_days)
349: !-
350: ! 2.3 date
351: !-
352: IF (is_root_prc) THEN
353: var_name = 'date'
354: CALL restget (rest_id_stomate, var_name, 1 , 1 , 1, itime, &
355: & .TRUE., xtmp)
356: date_real = xtmp(1)
357: IF (date_real == val_exp) date_real = 0.
358: date = NINT(date_real)
359: ENDIF
360: CALL bcast(date_real)
361: !-
362: ! 3 daily meteorological variables
363: !-
364: +V===== moiavail_daily(:,:) = val_exp
365: var_name = 'moiavail_daily'
366: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
367: & .TRUE., moiavail_daily, 'gather', nbp_glo, index_g)
368: +V===== IF (ALL(moiavail_daily(:,:) == val_exp)) moiavail_daily(:,:) = 0.0
369: !-
370: V====== litterhum_daily(:) = val_exp
371: var_name = 'litterhum_daily'
372: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
373: & .TRUE., litterhum_daily, 'gather', nbp_glo, index_g)
374: V====== IF (ALL(litterhum_daily(:) == val_exp)) litterhum_daily(:) = 0.0
375: !-
376: V====== t2m_daily(:) = val_exp
377: var_name = 't2m_daily'
378: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
379: & .TRUE., t2m_daily, 'gather', nbp_glo, index_g)
380: V====== IF (ALL(t2m_daily(:) == val_exp)) t2m_daily(:) = 0.0
381: !-
382: V====== t2m_min_daily(:) = val_exp
383: var_name = 't2m_min_daily'
384: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
385: & .TRUE., t2m_min_daily, 'gather', nbp_glo, index_g)
386: V====== IF (ALL(t2m_min_daily(:) == val_exp)) t2m_min_daily(:) = large_value
387: !-
388: V====== tsurf_daily(:) = val_exp
389: var_name = 'tsurf_daily'
390: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
391: & .TRUE., tsurf_daily, 'gather', nbp_glo, index_g)
392: V====== IF (ALL(tsurf_daily(:) == val_exp)) tsurf_daily(:) = tref(:)
393: !-
394: +V===== tsoil_daily(:,:) = val_exp
395: var_name = 'tsoil_daily'
396: CALL restget_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
397: & .TRUE., tsoil_daily, 'gather', nbp_glo, index_g)
398: +V===== IF (ALL(tsoil_daily(:,:) == val_exp)) tsoil_daily(:,:) = 0.0
399: !-
400: +V===== soilhum_daily(:,:) = val_exp
401: var_name = 'soilhum_daily'
402: CALL restget_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
403: & .TRUE., soilhum_daily, 'gather', nbp_glo, index_g)
404: +V===== IF (ALL(soilhum_daily(:,:) == val_exp)) soilhum_daily(:,:) = 0.0
405: !-
406: V====== precip_daily(:) = val_exp
407: var_name = 'precip_daily'
408: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
409: & .TRUE., precip_daily, 'gather', nbp_glo, index_g)
410: V====== IF (ALL(precip_daily(:) == val_exp)) precip_daily(:) = 0.0
411: !-
412: ! 4 productivities
413: !-
414: +V===== gpp_daily(:,:) = val_exp
415: var_name = 'gpp_daily'
416: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
417: & .TRUE., gpp_daily, 'gather', nbp_glo, index_g)
418: +V===== IF (ALL(gpp_daily(:,:) == val_exp)) gpp_daily(:,:) = 0.0
419: !-
420: +V===== npp_daily(:,:) = val_exp
421: var_name = 'npp_daily'
422: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
423: & .TRUE., npp_daily, 'gather', nbp_glo, index_g)
424: +V===== IF (ALL(npp_daily(:,:) == val_exp)) npp_daily(:,:) = 0.0
425: !-
426: W**==== turnover_daily(:,:,:) = val_exp
427: +------> DO k=1,nparts
428: | WRITE(part_str,'(I2)') k
429: | IF (k < 10) part_str(1:1) = '0'
430: | var_name = 'turnover_daily_'//part_str(1:LEN_TRIM(part_str))
431: | CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
432: | & .TRUE., turnover_daily(:,:,k), 'gather', nbp_glo, index_g)
433: |+V==== IF (ALL(turnover_daily(:,:,k) == val_exp)) &
434: | & turnover_daily(:,:,k) = 0.0
435: +------ ENDDO
436: !-
437: ! 5 monthly meteorological variables
438: !-
439: +V===== moiavail_month(:,:) = val_exp
440: var_name = 'moiavail_month'
441: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
442: & .TRUE., moiavail_month, 'gather', nbp_glo, index_g)
443: +V===== IF (ALL(moiavail_month(:,:) == val_exp)) moiavail_month(:,:) = 0.0
444: !-
445: +V===== moiavail_week(:,:) = val_exp
446: var_name = 'moiavail_week'
447: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
448: & .TRUE., moiavail_week, 'gather', nbp_glo, index_g)
449: +V===== IF (ALL(moiavail_week(:,:) == val_exp)) moiavail_week(:,:) = 0.0
450: !-
451: V====== t2m_longterm(:) = val_exp
452: var_name = 't2m_longterm'
453: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
454: & .TRUE., t2m_longterm, 'gather', nbp_glo, index_g)
455: V====== IF (ALL(t2m_longterm(:) == val_exp)) t2m_longterm(:) = tref(:)
456: !-
457: ! the long-term reference temperature is a prognostic variable
458: ! only in case the vegetation is dynamic
459: !-
460: IF (control%ok_dgvm) THEN
461: V====== tlong_ref(:) = val_exp
462: var_name = 'tlong_ref'
463: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
464: & .TRUE., tlong_ref, 'gather', nbp_glo, index_g)
465: V====== IF (ALL(tlong_ref(:) == val_exp)) tlong_ref(:) = tref(:)
466: ENDIF
467: !-
468: V====== t2m_month(:) = val_exp
469: var_name = 't2m_month'
470: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
471: & .TRUE., t2m_month, 'gather', nbp_glo, index_g)
472: V====== IF (ALL(t2m_month(:) == val_exp)) t2m_month(:) = tref(:)
473: !-
474: V====== t2m_week(:) = val_exp
475: var_name = 't2m_week'
476: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
477: & .TRUE., t2m_week, 'gather', nbp_glo, index_g)
478: V====== IF (ALL(t2m_week(:) == val_exp)) t2m_week(:) = tref(:)
479: !-
480: +V===== tsoil_month(:,:) = val_exp
481: var_name = 'tsoil_month'
482: CALL restget_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
483: & .TRUE., tsoil_month, 'gather', nbp_glo, index_g)
484:
485: +V===== IF (ALL(tsoil_month(:,:) == val_exp)) THEN
486: +------> DO l=1,nbdl
487: |V===== tsoil_month(:,l) = tref(:)
488: +------ ENDDO
489: ENDIF
490: !-
491: +V===== soilhum_month(:,:) = val_exp
492: var_name = 'soilhum_month'
493: CALL restget_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
494: & .TRUE., soilhum_month, 'gather', nbp_glo, index_g)
495: +V===== IF (ALL(soilhum_month(:,:) == val_exp)) soilhum_month(:,:) = 0.0
496: !-
497: ! 6 fire probability
498: !-
499: +V===== fireindex(:,:) = val_exp
500: var_name = 'fireindex'
501: CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
502: & .TRUE., fireindex, 'gather', nbp_glo, index_g)
503: +V===== IF (ALL(fireindex(:,:) == val_exp)) fireindex(:,:) = 0.0
504: !-
505: +V===== firelitter(:,:) = val_exp
506: var_name = 'firelitter'
507: CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
508: & .TRUE., firelitter, 'gather', nbp_glo, index_g)
509: +V===== IF (ALL(firelitter(:,:) == val_exp)) firelitter(:,:) = 0.0
510: !-
511: ! 7 maximum and minimum moisture availabilities for tropic phenology
512: !-
513: +V===== maxmoiavail_lastyear(:,:) = val_exp
514: var_name = 'maxmoistr_last'
515: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
516: & .TRUE., maxmoiavail_lastyear, 'gather', nbp_glo, index_g)
517: +V===== IF (ALL(maxmoiavail_lastyear(:,:) == val_exp)) &
518: & maxmoiavail_lastyear(:,:) = 0.0
519: !-
520: +V===== maxmoiavail_thisyear(:,:) = val_exp
521: var_name = 'maxmoistr_this'
522: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
523: & .TRUE., maxmoiavail_thisyear, 'gather', nbp_glo, index_g)
524: +V===== IF (ALL(maxmoiavail_thisyear(:,:) == val_exp)) &
525: & maxmoiavail_thisyear(:,:) = 0.0
526: !-
527: +V===== minmoiavail_lastyear(:,:) = val_exp
528: var_name = 'minmoistr_last'
529: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
530: & .TRUE., minmoiavail_lastyear, 'gather', nbp_glo, index_g)
531: +V===== IF (ALL(minmoiavail_lastyear(:,:) == val_exp)) &
532: & minmoiavail_lastyear(:,:) = 1.0
533: !-
534: +V===== minmoiavail_thisyear(:,:) = val_exp
535: var_name = 'minmoistr_this'
536: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
537: & .TRUE., minmoiavail_thisyear, 'gather', nbp_glo, index_g)
538: +V===== IF (ALL( minmoiavail_thisyear(:,:) == val_exp)) &
539: & minmoiavail_thisyear(:,:) = 1.0
540: !-
541: ! 8 maximum "weekly" GPP
542: !-
543: +V===== maxgppweek_lastyear(:,:) = val_exp
544: var_name = 'maxgppweek_lastyear'
545: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
546: & .TRUE., maxgppweek_lastyear, 'gather', nbp_glo, index_g)
547: +V===== IF (ALL(maxgppweek_lastyear(:,:) == val_exp)) &
548: & maxgppweek_lastyear(:,:) = 0.0
549: !-
550: +V===== maxgppweek_thisyear(:,:) = val_exp
551: var_name = 'maxgppweek_thisyear'
552: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
553: & .TRUE., maxgppweek_thisyear, 'gather', nbp_glo, index_g)
554: +V===== IF (ALL(maxgppweek_thisyear(:,:) == val_exp)) &
555: & maxgppweek_thisyear(:,:) = 0.0
556: !-
557: ! 9 annual GDD0
558: !-
559: V====== gdd0_thisyear(:) = val_exp
560: var_name = 'gdd0_thisyear'
561: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
562: & .TRUE., gdd0_thisyear, 'gather', nbp_glo, index_g)
563: V====== IF (ALL(gdd0_thisyear(:) == val_exp)) gdd0_thisyear(:) = 0.0
564: !-
565: V====== gdd0_lastyear(:) = val_exp
566: var_name = 'gdd0_lastyear'
567: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
568: & .TRUE., gdd0_lastyear, 'gather', nbp_glo, index_g)
569: V====== IF (ALL(gdd0_lastyear(:) == val_exp)) gdd0_lastyear(:) = gdd_crit
570: !-
571: ! 10 annual precipitation
572: !-
573: V====== precip_thisyear(:) = val_exp
574: var_name = 'precip_thisyear'
575: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
576: & .TRUE., precip_thisyear, 'gather', nbp_glo, index_g)
577: V====== IF (ALL(precip_thisyear(:) == val_exp)) precip_thisyear(:) = 0.0
578: !-
579: V====== precip_lastyear(:) = val_exp
580: var_name = 'precip_lastyear'
581: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
582: & .TRUE., precip_lastyear, 'gather', nbp_glo, index_g)
583: V====== IF (ALL(precip_lastyear(:) == val_exp)) &
584: & precip_lastyear(:) = precip_crit
585: !-
586: ! 11 derived "biometeorological" variables
587: !-
588: +V===== gdd_m5_dormance(:,:) = val_exp
589: var_name = 'gdd_m5_dormance'
590: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
591: & .TRUE., gdd_m5_dormance, 'gather', nbp_glo, index_g)
592: +V===== IF (ALL(gdd_m5_dormance(:,:) == val_exp)) &
593: & gdd_m5_dormance(:,:) = undef
594: !-
595: +V===== gdd_midwinter(:,:) = val_exp
596: var_name = 'gdd_midwinter'
597: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
598: & .TRUE., gdd_midwinter, 'gather', nbp_glo, index_g)
599: +V===== IF (ALL(gdd_midwinter(:,:) == val_exp)) gdd_midwinter(:,:) = undef
600: !-
601: +V===== ncd_dormance(:,:) = val_exp
602: var_name = 'ncd_dormance'
603: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
604: & .TRUE., ncd_dormance, 'gather', nbp_glo, index_g)
605: +V===== IF (ALL(ncd_dormance(:,:) == val_exp)) ncd_dormance(:,:) = undef
606: !-
607: +V===== ngd_minus5(:,:) = val_exp
608: var_name = 'ngd_minus5'
609: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
610: & .TRUE., ngd_minus5, 'gather', nbp_glo, index_g)
611: +V===== IF (ALL(ngd_minus5(:,:) == val_exp)) ngd_minus5(:,:) = 0.0
612: !-
613: +V===== time_lowgpp(:,:) = val_exp
614: var_name = 'time_lowgpp'
615: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
616: & .TRUE., time_lowgpp, 'gather', nbp_glo, index_g)
617: +V===== IF (ALL(time_lowgpp(:,:) == val_exp)) time_lowgpp(:,:) = 0.0
618: !-
619: +V===== time_hum_min(:,:) = val_exp
620: var_name = 'time_hum_min'
621: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
622: & .TRUE., time_hum_min, 'gather', nbp_glo, index_g)
623: +V===== IF (ALL(time_hum_min(:,:) == val_exp)) time_hum_min(:,:) = undef
624: !-
625: +V===== hum_min_dormance(:,:) = val_exp
626: var_name = 'hum_min_dormance'
627: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
628: & .TRUE., hum_min_dormance, 'gather', nbp_glo, index_g)
629: +V===== IF (ALL(hum_min_dormance(:,:) == val_exp)) &
630: & hum_min_dormance(:,:) = undef
631: !-
632: ! 12 Plant status
633: !-
634: +V===== PFTpresent_real(:,:) = val_exp
635: var_name = 'PFTpresent'
636: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
637: & .TRUE., PFTpresent_real, 'gather', nbp_glo, index_g)
638: +V===== IF (ALL(PFTpresent_real(:,:) == val_exp)) PFTpresent_real(:,:) = 0.0
639: *V-----> WHERE (PFTpresent_real(:,:) >= .5)
640: || PFTpresent = .TRUE.
641: || ELSEWHERE
642: *V----- PFTpresent = .FALSE.
643: ENDWHERE
644: !-
645: +V===== ind(:,:) = val_exp
646: var_name = 'ind'
647: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
648: & .TRUE., ind, 'gather', nbp_glo, index_g)
649: +V===== IF (ALL(ind(:,:) == val_exp)) ind(:,:) = 0.0
650: !-
651: +V===== adapted(:,:) = val_exp
652: var_name = 'adapted'
653: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
654: & .TRUE., adapted, 'gather', nbp_glo, index_g)
655: +V===== IF (ALL(adapted(:,:) == val_exp)) adapted(:,:) = 0.0
656: !-
657: +V===== regenerate(:,:) = val_exp
658: var_name = 'regenerate'
659: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
660: & .TRUE., regenerate, 'gather', nbp_glo, index_g)
661: +V===== IF (ALL(regenerate(:,:) == val_exp)) regenerate(:,:) = 0.0
662: !-
663: +V===== npp_longterm(:,:) = val_exp
664: var_name = 'npp_longterm'
665: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
666: & .TRUE., npp_longterm, 'gather', nbp_glo, index_g)
667: +V===== IF (ALL(npp_longterm(:,:) == val_exp)) npp_longterm(:,:) = 0.0
668: !-
669: +V===== lm_lastyearmax(:,:) = val_exp
670: var_name = 'lm_lastyearmax'
671: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
672: & .TRUE., lm_lastyearmax, 'gather', nbp_glo, index_g)
673: +V===== IF (ALL(lm_lastyearmax(:,:) == val_exp)) lm_lastyearmax(:,:) = 0.0
674: !-
675: +V===== lm_thisyearmax(:,:) = val_exp
676: var_name = 'lm_thisyearmax'
677: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
678: & .TRUE., lm_thisyearmax, 'gather', nbp_glo, index_g)
679: +V===== IF (ALL(lm_thisyearmax(:,:) == val_exp)) lm_thisyearmax(:,:) = 0.0
680: !-
681: +V===== maxfpc_lastyear(:,:) = val_exp
682: var_name = 'maxfpc_lastyear'
683: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
684: & .TRUE., maxfpc_lastyear, 'gather', nbp_glo, index_g)
685: +V===== IF (ALL(maxfpc_lastyear(:,:) == val_exp)) maxfpc_lastyear(:,:) = 0.0
686: !-
687: +V===== maxfpc_thisyear(:,:) = val_exp
688: var_name = 'maxfpc_thisyear'
689: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
690: & .TRUE., maxfpc_thisyear, 'gather', nbp_glo, index_g)
691: +V===== IF (ALL(maxfpc_thisyear(:,:) == val_exp)) maxfpc_thisyear(:,:) = 0.0
692: !-
693: +V===== turnover_time(:,:) = val_exp
694: var_name = 'turnover_time'
695: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
696: & .TRUE., turnover_time, 'gather', nbp_glo, index_g)
697: +V===== IF ( ALL( turnover_time(:,:) == val_exp)) turnover_time(:,:) = 100.
698: W**==== turnover_longterm(:,:,:) = val_exp
699: +------> DO k=1,nparts
700: | WRITE(part_str,'(I2)') k
701: | IF ( k < 10 ) part_str(1:1) = '0'
702: | var_name = 'turnover_longterm_'//part_str(1:LEN_TRIM(part_str))
703: | CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
704: | & .TRUE., turnover_longterm(:,:,k), 'gather', nbp_glo, index_g)
705: |+V==== IF (ALL(turnover_longterm(:,:,k) == val_exp)) &
706: | & turnover_longterm(:,:,k) = 0.0
707: +------ ENDDO
708: !-
709: +V===== gpp_week(:,:) = val_exp
710: var_name = 'gpp_week'
711: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
712: & .TRUE., gpp_week, 'gather', nbp_glo, index_g)
713: +V===== IF (ALL(gpp_week(:,:) == val_exp)) gpp_week(:,:) = 0.0
714: !-
715: W**==== biomass(:,:,:) = val_exp
716: +------> DO k=1,nparts
717: | WRITE(part_str,'(I2)') k
718: | IF ( k < 10 ) part_str(1:1) = '0'
719: | var_name = 'biomass_'//part_str(1:LEN_TRIM(part_str))
720: | CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
721: | & .TRUE., biomass(:,:,k), 'gather', nbp_glo, index_g)
722: |+V==== IF (ALL(biomass(:,:,k) == val_exp)) biomass(:,:,k) = 0.0
723: +------ ENDDO
724: !-
725: !-
726: W**==== resp_maint_part(:,:,:) = val_exp
727: +------> DO k=1,nparts
728: | WRITE(part_str,'(I2)') k
729: | IF ( k < 10 ) part_str(1:1) = '0'
730: | var_name = 'maint_resp_'//part_str(1:LEN_TRIM(part_str))
731: | CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
732: | & .TRUE., resp_maint_part(:,:,k), 'gather', nbp_glo, index_g)
733: |+V==== IF (ALL(resp_maint_part(:,:,k) == val_exp)) resp_maint_part(:,:,k) = 0.0
734: +------ ENDDO
735: !-
736: +V===== fvm(:,:) = val_exp
737: var_name = 'fvm'
738: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
739: & .TRUE., fvm, 'gather', nbp_glo, index_g)
740: +V===== IF (ALL(fvm(:,:) == val_exp)) fvm(:,:) = 1.0
741: !-
742: +V===== fv(:,:) = val_exp
743: var_name = 'fv'
744: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
745: & .TRUE., fv, 'gather', nbp_glo, index_g)
746: +V===== IF (ALL(fv(:,:) == val_exp)) fv(:,:) = 1.0
747: !-
748: W**==== leaf_age(:,:,:) = val_exp
749: +------> DO m=1,nleafages
750: | WRITE (part_str,'(I2)') m
751: | IF ( m < 10 ) part_str(1:1) = '0'
752: | var_name = 'leaf_age_'//part_str(1:LEN_TRIM(part_str))
753: | CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
754: | & .TRUE., leaf_age(:,:,m), 'gather', nbp_glo, index_g)
755: |+V==== IF (ALL(leaf_age(:,:,m) == val_exp)) leaf_age(:,:,m) = 0.0
756: +------ ENDDO
757: !-
758: W**==== leaf_frac(:,:,:) = val_exp
759: +------> DO m=1,nleafages
760: | WRITE(part_str,'(I2)') m
761: | IF ( m < 10 ) part_str(1:1) = '0'
762: | var_name = 'leaf_frac_'//part_str(1:LEN_TRIM(part_str))
763: | CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
764: | & .TRUE., leaf_frac(:,:,m), 'gather', nbp_glo, index_g)
765: |+V==== IF (ALL(leaf_frac(:,:,m) == val_exp)) leaf_frac(:,:,m) = 0.0
766: +------ ENDDO
767: !-
768: +V===== senescence_real(:,:) = val_exp
769: var_name = 'senescence'
770: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
771: & .TRUE., senescence_real, 'gather', nbp_glo, index_g)
772: +V===== IF (ALL(senescence_real(:,:) == val_exp)) senescence_real(:,:) = 0.0
773: *V-----> WHERE ( senescence_real(:,:) >= .5 )
774: || senescence = .TRUE.
775: || ELSEWHERE
776: *V----- senescence = .FALSE.
777: ENDWHERE
778: !-
779: +V===== when_growthinit(:,:) = val_exp
780: var_name = 'when_growthinit'
781: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
782: & .TRUE., when_growthinit, 'gather', nbp_glo, index_g)
783: +V===== IF (ALL(when_growthinit(:,:) == val_exp)) &
784: & when_growthinit(:,:) = undef
785: !-
786: +V===== age(:,:) = val_exp
787: var_name = 'age'
788: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
789: & .TRUE., age, 'gather', nbp_glo, index_g)
790: +V===== IF (ALL(age(:,:) == val_exp)) age(:,:) = 0.0
791: !-
792: ! 13 CO2
793: !-
794: +V===== resp_hetero(:,:) = val_exp
795: var_name = 'resp_hetero'
796: CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
797: & .TRUE., resp_hetero, 'gather', nbp_glo, index_g)
798: +V===== IF (ALL(resp_hetero(:,:) == val_exp)) resp_hetero(:,:) = 0.0
799: !-
800: +V===== resp_maint(:,:) = val_exp
801: var_name = 'resp_maint'
802: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
803: & .TRUE., resp_maint, 'gather', nbp_glo, index_g)
804: +V===== IF (ALL(resp_maint(:,:) == val_exp)) resp_maint(:,:) = 0.0
805: !-
806: +V===== resp_growth(:,:) = val_exp
807: var_name = 'resp_growth'
808: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
809: & .TRUE., resp_growth, 'gather', nbp_glo, index_g)
810: +V===== IF (ALL(resp_growth(:,:) == val_exp)) resp_growth(:,:) = 0.0
811: !-
812: V====== co2_fire(:) = val_exp
813: var_name = 'co2_fire'
814: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
815: & .TRUE., co2_fire, 'gather', nbp_glo, index_g)
816: V====== IF (ALL(co2_fire(:) == val_exp)) co2_fire(:) = 0.0
817: !-
818: V====== co2_to_bm_dgvm(:) = val_exp
819: var_name = 'co2_to_bm_dgvm'
820: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
821: & .TRUE., co2_to_bm_dgvm, 'gather', nbp_glo, index_g)
822: V====== IF (ALL(co2_to_bm_dgvm(:) == val_exp)) co2_to_bm_dgvm(:) = 0.0
823: !-
824: ! 14 vegetation distribution after last light competition
825: !-
826: +V===== veget_lastlight(:,:) = val_exp
827: var_name = 'veget_lastlight'
828: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
829: & .TRUE., veget_lastlight, 'gather', nbp_glo, index_g)
830: +V===== IF (ALL(veget_lastlight(:,:) == val_exp)) veget_lastlight(:,:) = 0.0
831: !-
832: ! 15 establishment criteria
833: !-
834: +V===== everywhere(:,:) = val_exp
835: var_name = 'everywhere'
836: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
837: & .TRUE., everywhere, 'gather', nbp_glo, index_g)
838: +V===== IF (ALL(everywhere(:,:) == val_exp)) everywhere(:,:) = 0.0
839: !-
840: +V===== need_adjacent_real(:,:) = val_exp
841: var_name = 'need_adjacent'
842: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
843: & .TRUE., need_adjacent_real, 'gather', nbp_glo, index_g)
844: +V===== IF (ALL(need_adjacent_real(:,:) == val_exp)) &
845: & need_adjacent_real(:,:) = 0.0
846: *V-----> WHERE ( need_adjacent_real(:,:) >= .5 )
847: || need_adjacent = .TRUE.
848: || ELSEWHERE
849: *V----- need_adjacent = .FALSE.
850: ENDWHERE
851: !-
852: +V===== RIP_time(:,:) = val_exp
853: var_name = 'RIP_time'
854: CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
855: & .TRUE., RIP_time, 'gather', nbp_glo, index_g)
856: +V===== IF (ALL(RIP_time(:,:) == val_exp)) RIP_time(:,:) = large_value
857: !-
858: ! 16 black carbon
859: !-
860: V====== black_carbon(:) = val_exp
861: var_name = 'black_carbon'
862: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1 , 1, itime, &
863: & .TRUE., black_carbon, 'gather', nbp_glo, index_g)
864: V====== IF (ALL(black_carbon(:) == val_exp)) black_carbon(:) = 0.0
865: !-
866: ! 17 litter
867: !-
868: W**==== litterpart(:,:,:) = val_exp
869: +------> DO l=1,nlitt
870: | var_name = 'litterpart_'//litter_str(l)
871: | CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
872: | & .TRUE., litterpart(:,:,l), 'gather', nbp_glo, index_g)
873: |+V==== IF (ALL(litterpart(:,:,l) == val_exp)) litterpart(:,:,l) = 0.0
874: +------ ENDDO
875: !-
876: +++V=== litter(:,:,:,:) = val_exp
877: +------> DO l=1,nlevs
878: |+-----> DO m=1,nvegtypes
879: || var_name = 'litter_'//vegtype_str(m)//'_'//level_str(l)
880: || CALL restget_p (rest_id_stomate, var_name, nbp_glo, nlitt , 1, itime, &
881: || & .TRUE., litter(:,:,m,l), 'gather', nbp_glo, index_g)
882: ||+V=== IF (ALL(litter(:,:,m,l) == val_exp)) litter(:,:,m,l) = 0.0
883: |+----- ENDDO
884: +------ ENDDO
885: !-
886: W**==== dead_leaves(:,:,:) = val_exp
887: +------> DO l=1,nlitt
888: | var_name = 'dead_leaves_'//litter_str(l)
889: | CALL restget_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
890: | & .TRUE., dead_leaves(:,:,l), 'gather', nbp_glo, index_g)
891: |+V==== IF (ALL(dead_leaves(:,:,l) == val_exp)) dead_leaves(:,:,l) = 0.0
892: +------ ENDDO
893: !-
894: ++V==== carbon(:,:,:) = val_exp
895: +------> DO m=1,nvegtypes
896: | var_name = 'carbon_'//vegtype_str(m)
897: | CALL restget_p (rest_id_stomate, var_name, nbp_glo, ncarb , 1, itime, &
898: | & .TRUE., carbon(:,:,m), 'gather', nbp_glo, index_g)
899: |+V==== IF (ALL(carbon(:,:,m) == val_exp)) carbon(:,:,m) = 0.0
900: +------ ENDDO
901: !-
902: ++V==== lignin_struc(:,:,:) = val_exp
903: +------> DO l=1,nlevs
904: | var_name = 'lignin_struc_'//level_str(l)
905: | CALL restget_p &
906: | & (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
907: | & .TRUE., lignin_struc(:,:,l), 'gather', nbp_glo, index_g)
908: |+V==== IF (ALL(lignin_struc(:,:,l) == val_exp)) lignin_struc(:,:,l) = 0.0
909: +------ ENDDO
910: !-
911: ! 18 deforestation
912: !-
913: +V===== prod10(:,:) = val_exp
914: var_name = 'prod10'
915: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 11 , 1, itime, &
916: & .TRUE., prod10, 'gather', nbp_glo, index_g)
917: +V===== IF (ALL(prod10(:,:) == val_exp)) prod10(:,:) = 0.0
918:
919: +V===== prod100(:,:) = val_exp
920: var_name = 'prod100'
921: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 101 , 1, itime, &
922: & .TRUE., prod100, 'gather', nbp_glo, index_g)
923: +V===== IF (ALL(prod100(:,:) == val_exp)) prod100(:,:) = 0.0
924:
925:
926: +V===== flux10(:,:) = val_exp
927: var_name = 'flux10'
928: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 10 , 1, itime, &
929: & .TRUE., flux10, 'gather', nbp_glo, index_g)
930: +V===== IF (ALL(flux10(:,:) == val_exp)) flux10(:,:) = 0.0
931:
932: +V===== flux100(:,:) = val_exp
933: var_name = 'flux100'
934: CALL restget_p (rest_id_stomate, var_name, nbp_glo, 100 , 1, itime, &
935: & .TRUE., flux100, 'gather', nbp_glo, index_g)
936: +V===== IF (ALL(flux100(:,:) == val_exp)) flux100(:,:) = 0.0
937:
938: !-
939:
940: IF (bavard >= 4) WRITE(numout,*) 'Leaving readstart'
941: !-----------------------
942: END SUBROUTINE readstart
943: !-
944: !===
945: !-
946: SUBROUTINE writerestart &
947: & (npts, index, day_counter, dt_days, date, &
948: & ind, adapted, regenerate, moiavail_daily, litterhum_daily, &
949: & t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
950: & soilhum_daily, precip_daily, gpp_daily, npp_daily, &
951: & turnover_daily, moiavail_month, moiavail_week, &
952: & t2m_longterm, tlong_ref, t2m_month, t2m_week, &
953: & tsoil_month, soilhum_month, fireindex, firelitter, &
954: & maxmoiavail_lastyear, maxmoiavail_thisyear, &
955: & minmoiavail_lastyear, minmoiavail_thisyear, &
956: & maxgppweek_lastyear, maxgppweek_thisyear, &
957: & gdd0_lastyear, gdd0_thisyear, precip_lastyear, precip_thisyear, &
958: & gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
959: & PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
960: & maxfpc_lastyear, maxfpc_thisyear, &
961: & turnover_longterm, gpp_week, biomass, resp_maint_part, &
962: & fvm, fv, leaf_age, leaf_frac, senescence, when_growthinit, age, &
963: & resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
964: & veget_lastlight, everywhere, need_adjacent, RIP_time, &
965: & time_lowgpp, time_hum_min, hum_min_dormance, litterpart, litter, &
966: & dead_leaves, carbon, black_carbon, lignin_struc,turnover_time, &
967: & prod10,prod100 ,flux10, flux100)
968: ! deforestation variables added as arguments
969: !---------------------------------------------------------------------
970: !- write restart file
971: !---------------------------------------------------------------------
972: !-
973: ! 0 declarations
974: !-
975: ! 0.1 input
976: !-
977: ! Domain size
978: INTEGER(i_std),INTENT(in) :: npts
979: ! Indices of the points on the map
980: INTEGER(i_std),DIMENSION(npts),INTENT(in) :: index
981: ! counts time until next STOMATE time step
982: REAL(r_std),INTENT(in) :: day_counter
983: ! time step of STOMATE in days
984: REAL(r_std),INTENT(in) :: dt_days
985: ! date (d)
986: INTEGER(i_std),INTENT(in) :: date
987: ! density of individuals (1/m**2)
988: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: ind
989: ! Winter too cold? between 0 and 1
990: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: adapted
991: ! Winter sufficiently cold? between 0 and 1
992: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: regenerate
993: ! daily moisture availability
994: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: moiavail_daily
995: ! daily litter humidity
996: REAL(r_std),DIMENSION(npts),INTENT(in) :: litterhum_daily
997: ! daily 2 meter temperatures (K)
998: REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_daily
999: ! daily minimum 2 meter temperatures (K)
1000: REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_min_daily
1001: ! daily surface temperatures (K)
1002: REAL(r_std),DIMENSION(npts),INTENT(in) :: tsurf_daily
1003: ! daily soil temperatures (K)
1004: REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: tsoil_daily
1005: ! daily soil humidity
1006: REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: soilhum_daily
1007: ! daily precipitations (mm/day) (for phenology)
1008: REAL(r_std),DIMENSION(npts),INTENT(in) :: precip_daily
1009: ! daily gross primary productivity (gC/m**2/day)
1010: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: gpp_daily
1011: ! daily net primary productivity (gC/m**2/day)
1012: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: npp_daily
1013: ! daily turnover rates (gC/m**2/day)
1014: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: turnover_daily
1015: ! "monthly" moisture availability
1016: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: moiavail_month
1017: ! "weekly" moisture availability
1018: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: moiavail_week
1019: ! "long term" 2 meter temperatures (K)
1020: REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_longterm
1021: ! "long term" reference 2 meter temperatures (K)
1022: REAL(r_std),DIMENSION(npts),INTENT(in) :: tlong_ref
1023: ! "monthly" 2 meter temperatures (K)
1024: REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_month
1025: ! "weekly" 2 meter temperatures (K)
1026: REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_week
1027: ! "monthly" soil temperatures (K)
1028: REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: tsoil_month
1029: ! "monthly" soil humidity
1030: REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: soilhum_month
1031: ! Probability of fire
1032: REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(in) :: fireindex
1033: ! Longer term total litter above the ground, gC/m**2 of nat/agri ground
1034: REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(in) :: firelitter
1035: ! last year's maximum moisture availability
1036: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxmoiavail_lastyear
1037: ! this year's maximum moisture availability
1038: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxmoiavail_thisyear
1039: ! last year's minimum moisture availability
1040: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: minmoiavail_lastyear
1041: ! this year's minimum moisture availability
1042: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: minmoiavail_thisyear
1043: ! last year's maximum weekly GPP
1044: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxgppweek_lastyear
1045: ! this year's maximum weekly GPP
1046: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxgppweek_thisyear
1047: ! last year's annual GDD0
1048: REAL(r_std),DIMENSION(npts),INTENT(in) :: gdd0_lastyear
1049: ! this year's annual GDD0
1050: REAL(r_std),DIMENSION(npts),INTENT(in) :: gdd0_thisyear
1051: ! last year's annual precipitation (mm/year)
1052: REAL(r_std),DIMENSION(npts),INTENT(in) :: precip_lastyear
1053: ! this year's annual precipitation (mm/year)
1054: REAL(r_std),DIMENSION(npts),INTENT(in) :: precip_thisyear
1055: ! growing degree days, threshold -5 deg C (for phenology)
1056: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: gdd_m5_dormance
1057: ! growing degree days since midwinter (for phenology)
1058: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: gdd_midwinter
1059: ! number of chilling days since leaves were lost (for phenology)
1060: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: ncd_dormance
1061: ! number of growing days, threshold -5 deg C (for phenology)
1062: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: ngd_minus5
1063: ! PFT exists (equivalent to fpc_max > 0 for natural PFTs)
1064: LOGICAL,DIMENSION(npts,npft),INTENT(in) :: PFTpresent
1065: ! "long term" net primary productivity (gC/m**2/year)
1066: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: npp_longterm
1067: ! last year's maximum leaf mass, for each PFT (gC/m**2)
1068: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: lm_lastyearmax
1069: ! this year's maximum leaf mass, for each PFT (gC/m**2)
1070: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: lm_thisyearmax
1071: ! last year's maximum fpc for each natural PFT, on *natural* ground
1072: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxfpc_lastyear
1073: ! this year's maximum fpc for each PFT,
1074: ! on *total* ground (see stomate_season)
1075: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: maxfpc_thisyear
1076: ! "long term" turnover rate (gC/m**2/year)
1077: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: turnover_longterm
1078: ! "weekly" GPP (gC/day/(m**2 covered)
1079: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: gpp_week
1080: ! biomass (gC/m**2)
1081: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: biomass
1082: ! maintenance respiration (gC/m**2)
1083: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: resp_maint_part
1084: ! factor to convert veget_x into veget
1085: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: fv
1086: ! factor to convert veget_max_x into veget_max
1087: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: fvm
1088: ! leaf age (days)
1089: REAL(r_std),DIMENSION(npts,npft,nleafages),INTENT(in) :: leaf_age
1090: ! fraction of leaves in leaf age class
1091: REAL(r_std),DIMENSION(npts,npft,nleafages),INTENT(in) :: leaf_frac
1092: ! is the plant senescent ?
1093: ! (only for deciduous trees - carbohydrate reserve)
1094: LOGICAL,DIMENSION(npts,npft),INTENT(in) :: senescence
1095: ! how many days ago was the beginning of the growing season
1096: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: when_growthinit
1097: ! mean age (years)
1098: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: age
1099: ! heterotrophic respiration (gC/day/m**2)
1100: REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(in) :: resp_hetero
1101: ! maintenance respiration (gC/day/m**2)
1102: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: resp_maint
1103: ! growth respiration (gC/day/m**2)
1104: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: resp_growth
1105: ! carbon emitted into the atmosphere by fire (living and dead biomass)
1106: ! (in gC/m**2/time step)
1107: REAL(r_std),DIMENSION(npts),INTENT(in) :: co2_fire
1108: ! biomass uptaken (gC/(m**2 of total ground)/day)
1109: REAL(r_std),DIMENSION(npts),INTENT(in) :: co2_to_bm_dgvm
1110: ! vegetation fractions
1111: ! (on natural/agri ground) after last light competition
1112: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: veget_lastlight
1113: ! is the PFT everywhere in the grid box or very localized
1114: ! (after its introduction)
1115: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: everywhere
1116: ! in order for this PFT to be introduced,
1117: ! does it have to be present in an adjacent grid box?
1118: LOGICAL,DIMENSION(npts,npft),INTENT(in) :: need_adjacent
1119: ! How much time ago was the PFT eliminated for the last time (y)
1120: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: RIP_time
1121: ! duration of dormance (d)
1122: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: time_lowgpp
1123: ! time elapsed since strongest moisture availability (d)
1124: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: time_hum_min
1125: ! minimum moisture during dormance
1126: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: hum_min_dormance
1127: ! fraction of litter above the ground belonging to different PFTs
1128: ! separated for natural and agricultural PFTs.
1129: REAL(r_std),DIMENSION(npts,npft,nlitt),INTENT(in) :: litterpart
1130: ! metabolic and structural litter, natural and agricultural,
1131: ! above and below ground (gC/m**2)
1132: REAL(r_std),DIMENSION(npts,nlitt,nvegtypes,nlevs),INTENT(in) :: litter
1133: ! dead leaves on ground, per PFT, metabolic and structural,
1134: ! in gC/(m**2 of nat/agri ground)
1135: REAL(r_std),DIMENSION(npts,npft,nlitt),INTENT(in) :: dead_leaves
1136: ! carbon pool: active, slow, or passive, natural and agricultural
1137: ! (gC/m**2)
1138: REAL(r_std),DIMENSION(npts,ncarb,nvegtypes),INTENT(in) :: carbon
1139: ! black carbon on the ground (gC/(m**2 of total ground))
1140: REAL(r_std),DIMENSION(npts),INTENT(in) :: black_carbon
1141: ! ratio Lignine/Carbon in structural litter, above and below ground,
1142: ! natural and agricultural (gC/m**2)
1143: REAL(r_std),DIMENSION(npts,nvegtypes,nlevs),INTENT(in) :: lignin_struc
1144: ! turnover_time of leaves
1145: REAL(r_std),DIMENSION(npts,npft),INTENT(in) :: turnover_time
1146: !-
1147: ! 0.2 local
1148: !-
1149: ! date, real
1150: REAL(r_std) :: date_real
1151: ! PFT exists (equivalent to fpc_max > 0 for natural PFTs), real
1152: REAL(r_std),DIMENSION(npts,npft) :: PFTpresent_real
1153: ! is the plant senescent ?
1154: ! (only for deciduous trees - carbohydrate reserve), real
1155: REAL(r_std),DIMENSION(npts,npft) :: senescence_real
1156: ! in order for this PFT to be introduced,
1157: ! does it have to be present in an adjacent grid box? - real
1158: REAL(r_std),DIMENSION(npts,npft) :: need_adjacent_real
1159: ! To store variables names for I/O
1160: CHARACTER(LEN=80) :: var_name
1161: ! string suffix indicating an index
1162: CHARACTER(LEN=10) :: part_str
1163: ! string suffix indicating litter type
1164: CHARACTER(LEN=3),DIMENSION(nlitt) :: litter_str
1165: ! string suffix indicating vegetation type
1166: CHARACTER(LEN=3),DIMENSION(nvegtypes) :: vegtype_str
1167: ! string suffix indicating level
1168: CHARACTER(LEN=2),DIMENSION(nlevs) :: level_str
1169: ! temporary storage
1170: REAL(r_std),DIMENSION(1) :: xtmp
1171: ! index
1172: INTEGER(i_std) :: k,l,m
1173:
1174: ! deforestation variables
1175: ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
1176: ! (10 or 100 + 1 : input from year of deforestation)
1177: REAL(r_std),DIMENSION(npts,0:10),INTENT(in) :: prod10
1178: REAL(r_std),DIMENSION(npts,0:100),INTENT(in) :: prod100
1179: ! annual release from the 10/100 year-turnover pool compartments
1180: REAL(r_std),DIMENSION(npts,10),INTENT(in) :: flux10
1181: REAL(r_std),DIMENSION(npts,100),INTENT(in) :: flux100
1182: !---------------------------------------------------------------------
1183: IF (bavard >= 3) WRITE(numout,*) 'Entering writerestart'
1184: !-
1185: ! 1 string definitions
1186: !-
1187: print *,'--------------------> debut writestart',rest_id_stomate
1188: +------> DO m=1,nvegtypes
1189: | IF (m == inat) THEN
1190: | vegtype_str(m) = 'nat'
1191: | ELSEIF (m == iagri) THEN
1192: | vegtype_str(m) = 'agr'
1193: | ELSE
1194: | STOP 'Define vegtype_str'
1195: | ENDIF
1196: +------ ENDDO
1197: !-
1198: +------> DO l=1,nlitt
1199: | IF (l == imetabolic) THEN
1200: | litter_str(l) = 'met'
1201: | ELSEIF (l == istructural) THEN
1202: | litter_str(l) = 'str'
1203: | ELSE
1204: | STOP 'Define litter_str'
1205: | ENDIF
1206: +------ ENDDO
1207: !-
1208: +------> DO l=1,nlevs
1209: | IF (l == iabove) THEN
1210: | level_str(l) = 'ab'
1211: | ELSEIF (l == ibelow) THEN
1212: | level_str(l) = 'be'
1213: | ELSE
1214: | STOP 'Define level_str'
1215: | ENDIF
1216: +------ ENDDO
1217: !-
1218: IF (is_root_prc) THEN
1219: CALL ioconf_setatt ('UNITS','-')
1220: CALL ioconf_setatt ('LONG_NAME',' ')
1221: ENDIF
1222: !-
1223: ! 2 run control
1224: !-
1225: ! 2.1 day counter
1226: !-
1227: IF (is_root_prc) THEN
1228: var_name = 'day_counter'
1229: xtmp(1) = day_counter
1230: CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, xtmp)
1231: ENDIF
1232: !-
1233: ! 2.2 time step of STOMATE in days
1234: !-
1235: IF (is_root_prc) THEN
1236: var_name = 'dt_days'
1237: xtmp(1) = dt_days
1238: CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, xtmp)
1239: ENDIF
1240: !-
1241: ! 2.3 date
1242: !-
1243: IF (is_root_prc) THEN
1244: var_name = 'date'
1245: date_real = REAL(date,r_std)
1246: xtmp(1) = date_real
1247: CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, xtmp)
1248: ENDIF
1249: !-
1250: ! 3 daily meteorological variables
1251: !-
1252: var_name = 'moiavail_daily'
1253: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1254: & moiavail_daily, 'scatter', nbp_glo, index_g)
1255: !-
1256: var_name = 'litterhum_daily'
1257: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1258: & litterhum_daily, 'scatter', nbp_glo, index_g)
1259: !-
1260: var_name = 't2m_daily'
1261: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1262: & t2m_daily, 'scatter', nbp_glo, index_g)
1263: !-
1264: var_name = 't2m_min_daily'
1265: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1266: & t2m_min_daily, 'scatter', nbp_glo, index_g)
1267: !-
1268: var_name = 'tsurf_daily'
1269: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1270: & tsurf_daily, 'scatter', nbp_glo, index_g)
1271: !-
1272: var_name = 'tsoil_daily'
1273: CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
1274: & tsoil_daily, 'scatter', nbp_glo, index_g)
1275: !-
1276: var_name = 'soilhum_daily'
1277: CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
1278: & soilhum_daily, 'scatter', nbp_glo, index_g)
1279: !-
1280: var_name = 'precip_daily'
1281: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1282: & precip_daily, 'scatter', nbp_glo, index_g)
1283: !-
1284: ! 4 productivities
1285: !-
1286: var_name = 'gpp_daily'
1287: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1288: & gpp_daily, 'scatter', nbp_glo, index_g)
1289: !-
1290: var_name = 'npp_daily'
1291: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1292: & npp_daily, 'scatter', nbp_glo, index_g)
1293: !-
1294: +------> DO k=1,nparts
1295: | WRITE(part_str,'(I2)') k
1296: | IF (k < 10) part_str(1:1) = '0'
1297: | var_name = 'turnover_daily_'//part_str(1:LEN_TRIM(part_str))
1298: | CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1299: | & turnover_daily(:,:,k), 'scatter', nbp_glo, index_g)
1300: +------ ENDDO
1301: !-
1302: ! 5 monthly meteorological variables
1303: !-
1304: var_name = 'moiavail_month'
1305: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1306: & moiavail_month, 'scatter', nbp_glo, index_g)
1307: !-
1308: var_name = 'moiavail_week'
1309: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1310: & moiavail_week, 'scatter', nbp_glo, index_g)
1311: !-
1312: var_name = 't2m_longterm'
1313: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1314: & t2m_longterm, 'scatter', nbp_glo, index_g)
1315: !-
1316: IF (control%ok_dgvm) THEN
1317: var_name = 'tlong_ref'
1318: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1319: & tlong_ref, 'scatter', nbp_glo, index_g)
1320: ENDIF
1321: !-
1322: var_name = 't2m_month'
1323: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1324: & t2m_month, 'scatter', nbp_glo, index_g)
1325: !-
1326: var_name = 't2m_week'
1327: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1328: & t2m_week, 'scatter', nbp_glo, index_g)
1329: !-
1330: var_name = 'tsoil_month'
1331: CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
1332: & tsoil_month, 'scatter', nbp_glo, index_g)
1333: !-
1334: var_name = 'soilhum_month'
1335: CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
1336: & soilhum_month, 'scatter', nbp_glo, index_g)
1337: !-
1338: ! 6 fire probability
1339: !-
1340: var_name = 'fireindex'
1341: CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
1342: & fireindex, 'scatter', nbp_glo, index_g)
1343: !-
1344: var_name = 'firelitter'
1345: CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
1346: & firelitter, 'scatter', nbp_glo, index_g)
1347: !-
1348: ! 7 maximum and minimum moisture availabilities for tropic phenology
1349: !-
1350: var_name = 'maxmoistr_last'
1351: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1352: & maxmoiavail_lastyear, 'scatter', nbp_glo, index_g)
1353: !-
1354: var_name = 'maxmoistr_this'
1355: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1356: & maxmoiavail_thisyear, 'scatter', nbp_glo, index_g)
1357: !-
1358: var_name = 'minmoistr_last'
1359: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1360: & minmoiavail_lastyear, 'scatter', nbp_glo, index_g)
1361: !-
1362: var_name = 'minmoistr_this'
1363: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1364: & minmoiavail_thisyear, 'scatter', nbp_glo, index_g)
1365: !-
1366: ! 8 maximum "weekly" GPP
1367: !-
1368: var_name = 'maxgppweek_lastyear'
1369: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1370: & maxgppweek_lastyear, 'scatter', nbp_glo, index_g)
1371: !-
1372: var_name = 'maxgppweek_thisyear'
1373: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1374: & maxgppweek_thisyear, 'scatter', nbp_glo, index_g)
1375: !-
1376: ! 9 annual GDD0
1377: !-
1378: var_name = 'gdd0_thisyear'
1379: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1380: & gdd0_thisyear, 'scatter', nbp_glo, index_g)
1381: !-
1382: var_name = 'gdd0_lastyear'
1383: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1384: & gdd0_lastyear, 'scatter', nbp_glo, index_g)
1385: !-
1386: ! 10 annual precipitation
1387: !-
1388: var_name = 'precip_thisyear'
1389: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1390: & precip_thisyear, 'scatter', nbp_glo, index_g)
1391: !-
1392: var_name = 'precip_lastyear'
1393: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1394: & precip_lastyear, 'scatter', nbp_glo, index_g)
1395: !-
1396: ! 11 derived "biometeorological" variables
1397: !-
1398: var_name = 'gdd_m5_dormance'
1399: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1400: & gdd_m5_dormance, 'scatter', nbp_glo, index_g)
1401: !-
1402: var_name = 'gdd_midwinter'
1403: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1404: & gdd_midwinter, 'scatter', nbp_glo, index_g)
1405: !-
1406: var_name = 'ncd_dormance'
1407: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1408: & ncd_dormance, 'scatter', nbp_glo, index_g)
1409: !-
1410: var_name = 'ngd_minus5'
1411: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1412: & ngd_minus5, 'scatter', nbp_glo, index_g)
1413: !-
1414: var_name = 'time_lowgpp'
1415: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1416: & time_lowgpp, 'scatter', nbp_glo, index_g)
1417: !-
1418: var_name = 'time_hum_min'
1419: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1420: & time_hum_min, 'scatter', nbp_glo, index_g)
1421: !-
1422: var_name = 'hum_min_dormance'
1423: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1424: & hum_min_dormance, 'scatter', nbp_glo, index_g)
1425: !-
1426: ! 12 Plant status
1427: !-
1428: var_name = 'PFTpresent'
1429: *V-----> WHERE ( PFTpresent(:,:) )
1430: || PFTpresent_real = 1.
1431: || ELSEWHERE
1432: *V----- PFTpresent_real = 0.
1433: ENDWHERE
1434: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1435: & PFTpresent_real, 'scatter', nbp_glo, index_g)
1436: !-
1437: var_name = 'ind'
1438: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1439: & ind, 'scatter', nbp_glo, index_g)
1440: !-
1441: var_name = 'turnover_time'
1442: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1443: & turnover_time, 'scatter', nbp_glo, index_g)
1444: !-
1445: var_name = 'adapted'
1446: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1447: & adapted, 'scatter', nbp_glo, index_g)
1448: !-
1449: var_name = 'regenerate'
1450: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1451: & regenerate, 'scatter', nbp_glo, index_g)
1452: !-
1453: var_name = 'npp_longterm'
1454: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1455: & npp_longterm, 'scatter', nbp_glo, index_g)
1456: !-
1457: var_name = 'lm_lastyearmax'
1458: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1459: & lm_lastyearmax, 'scatter', nbp_glo, index_g)
1460: !-
1461: var_name = 'lm_thisyearmax'
1462: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1463: & lm_thisyearmax, 'scatter', nbp_glo, index_g)
1464: !-
1465: var_name = 'maxfpc_lastyear'
1466: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1467: & maxfpc_lastyear, 'scatter', nbp_glo, index_g)
1468: !-
1469: var_name = 'maxfpc_thisyear'
1470: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1471: & maxfpc_thisyear, 'scatter', nbp_glo, index_g)
1472: !-
1473: +------> DO k=1,nparts
1474: | WRITE(part_str,'(I2)') k
1475: | IF (k < 10) part_str(1:1) = '0'
1476: | var_name = 'turnover_longterm_'//part_str(1:LEN_TRIM(part_str))
1477: | CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1478: | & turnover_longterm(:,:,k), 'scatter', nbp_glo, index_g)
1479: +------ ENDDO
1480: !-
1481: var_name = 'gpp_week'
1482: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1483: & gpp_week, 'scatter', nbp_glo, index_g)
1484: !-
1485: +------> DO k=1,nparts
1486: | WRITE(part_str,'(I2)') k
1487: | IF (k < 10) part_str(1:1) = '0'
1488: | var_name = 'biomass_'//part_str(1:LEN_TRIM(part_str))
1489: | CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1490: | & biomass(:,:,k), 'scatter', nbp_glo, index_g)
1491: +------ ENDDO
1492: !-
1493: +------> DO k=1,nparts
1494: | WRITE(part_str,'(I2)') k
1495: | IF (k < 10) part_str(1:1) = '0'
1496: | var_name = 'maint_resp_'//part_str(1:LEN_TRIM(part_str))
1497: | CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1498: | & resp_maint_part(:,:,k), 'scatter', nbp_glo, index_g)
1499: +------ ENDDO
1500: !-
1501: var_name = 'fvm'
1502: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1503: & fvm, 'scatter', nbp_glo, index_g)
1504: !-
1505: var_name = 'fv'
1506: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1507: & fv, 'scatter', nbp_glo, index_g)
1508: !-
1509: +------> DO m=1,nleafages
1510: | WRITE(part_str,'(I2)') m
1511: | IF (m < 10) part_str(1:1) = '0'
1512: | var_name = 'leaf_age_'//part_str(1:LEN_TRIM(part_str))
1513: | CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1514: | & leaf_age(:,:,m), 'scatter', nbp_glo, index_g)
1515: +------ ENDDO
1516: !-
1517: +------> DO m=1,nleafages
1518: | WRITE(part_str,'(I2)') m
1519: | IF (m < 10) part_str(1:1) = '0'
1520: | var_name = 'leaf_frac_'//part_str(1:LEN_TRIM(part_str))
1521: | CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1522: | & leaf_frac(:,:,m), 'scatter', nbp_glo, index_g)
1523: +------ ENDDO
1524: !-
1525: var_name = 'senescence'
1526: *V-----> WHERE ( senescence(:,:) )
1527: || senescence_real = 1.
1528: || ELSEWHERE
1529: *V----- senescence_real = 0.
1530: ENDWHERE
1531: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1532: & senescence_real, 'scatter', nbp_glo, index_g)
1533: !-
1534: var_name = 'when_growthinit'
1535: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1536: & when_growthinit, 'scatter', nbp_glo, index_g)
1537: !-
1538: var_name = 'age'
1539: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft , 1, itime, &
1540: & age, 'scatter', nbp_glo, index_g)
1541: !-
1542: ! 13 CO2
1543: !-
1544: var_name = 'resp_hetero'
1545: CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
1546: & resp_hetero, 'scatter', nbp_glo, index_g)
1547: !-
1548: var_name = 'resp_maint'
1549: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1550: & resp_maint, 'scatter', nbp_glo, index_g)
1551: !-
1552: var_name = 'resp_growth'
1553: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1554: & resp_growth, 'scatter', nbp_glo, index_g)
1555: !-
1556: var_name = 'co2_fire'
1557: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1558: & co2_fire, 'scatter', nbp_glo, index_g)
1559: !-
1560: var_name = 'co2_to_bm_dgvm'
1561: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1562: & co2_to_bm_dgvm, 'scatter', nbp_glo, index_g)
1563: !-
1564: ! 14 vegetation distribution after last light competition
1565: !-
1566: var_name = 'veget_lastlight'
1567: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1568: & veget_lastlight, 'scatter', nbp_glo, index_g)
1569: !-
1570: ! 15 establishment criteria
1571: !-
1572: var_name = 'everywhere'
1573: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1574: & everywhere, 'scatter', nbp_glo, index_g)
1575: !-
1576: var_name = 'need_adjacent'
1577: *V-----> WHERE (need_adjacent(:,:))
1578: || need_adjacent_real(:,:) = 1.
1579: || ELSEWHERE
1580: *V----- need_adjacent_real(:,:) = 0.
1581: ENDWHERE
1582: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1583: & need_adjacent_real, 'scatter', nbp_glo, index_g)
1584: !-
1585: var_name = 'RIP_time'
1586: CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1587: & RIP_time, 'scatter', nbp_glo, index_g)
1588: !-
1589: ! 16 black carbon
1590: !-
1591: var_name = 'black_carbon'
1592: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
1593: & black_carbon, 'scatter', nbp_glo, index_g)
1594: !-
1595: ! 17 litter
1596: !-
1597: +------> DO l=1,nlitt
1598: | var_name = 'litterpart_'//litter_str(l)
1599: | CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1600: | & litterpart(:,:,l), 'scatter', nbp_glo, index_g)
1601: +------ ENDDO
1602: !-
1603: +------> DO l=1,nlevs
1604: |+-----> DO m=1,nvegtypes
1605: || var_name = 'litter_'//vegtype_str(m)//'_'//level_str(l)
1606: || CALL restput_p (rest_id_stomate, var_name, nbp_glo, nlitt, 1, itime, &
1607: || & litter(:,:,m,l), 'scatter', nbp_glo, index_g)
1608: |+----- ENDDO
1609: +------ ENDDO
1610: !-
1611: +------> DO l=1,nlitt
1612: | var_name = 'dead_leaves_'//litter_str(l)
1613: | CALL restput_p (rest_id_stomate, var_name, nbp_glo, npft, 1, itime, &
1614: | & dead_leaves(:,:,l), 'scatter', nbp_glo, index_g)
1615: +------ ENDDO
1616: !-
1617: +------> DO m=1,nvegtypes
1618: | var_name = 'carbon_'//vegtype_str(m)
1619: | CALL restput_p (rest_id_stomate, var_name, nbp_glo, ncarb, 1, itime, &
1620: | & carbon(:,:,m), 'scatter', nbp_glo, index_g)
1621: +------ ENDDO
1622: !-
1623: +------> DO l=1,nlevs
1624: | var_name = 'lignin_struc_'//level_str(l)
1625: | CALL restput_p &
1626: | & (rest_id_stomate, var_name, nbp_glo, nvegtypes, 1, itime, &
1627: | & lignin_struc(:,:,l), 'scatter', nbp_glo, index_g)
1628: +------ ENDDO
1629:
1630: !-
1631: ! 18 deforestation
1632: !-
1633: var_name = 'prod10'
1634: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 11, 1, itime, &
1635: & prod10, 'scatter', nbp_glo, index_g)
1636: var_name = 'prod100'
1637: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 101, 1, itime, &
1638: & prod100, 'scatter', nbp_glo, index_g)
1639: var_name = 'flux10'
1640: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 10, 1, itime, &
1641: & flux10, 'scatter', nbp_glo, index_g)
1642: var_name = 'flux100'
1643: CALL restput_p (rest_id_stomate, var_name, nbp_glo, 100, 1, itime, &
1644: & flux100, 'scatter', nbp_glo, index_g)
1645:
1646: !-
1647: IF (bavard >= 4) WRITE(numout,*) 'Leaving writerestart'
1648: !--------------------------
1649: END SUBROUTINE writerestart
1650: !-
1651: !===
1652: !-
1653: SUBROUTINE readbc (npts, lalo, resolution, tref)
1654: !---------------------------------------------------------------------
1655: !-
1656: ! 0.1 input
1657: !-
1658: ! Domain size
1659: INTEGER(i_std),INTENT(in) :: npts
1660: ! Geogr. coordinates (latitude,longitude) (degrees)
1661: REAL(r_std),DIMENSION (npts,2),INTENT(in) :: lalo
1662: ! size in x an y of the grid (m)
1663: REAL(r_std),DIMENSION (npts,2),INTENT(in) :: resolution
1664: !-
1665: ! 0.2 not necessarily output
1666: !-
1667: ! "long term" reference 2 meter temperatures (K)
1668: REAL(r_std),DIMENSION(npts),INTENT(inout) :: tref
1669: !---------------------------------------------------------------------
1670: !-
1671: ! If the vegetation is static, then the long-term reference
1672: ! temperature is a boundary condition.
1673: !-
1674: IF ( .NOT. control%ok_dgvm ) THEN
1675: CALL get_reftemp (npts, lalo, resolution, tref)
1676: ENDIF
1677: !--------------------
1678: END SUBROUTINE readbc
1679: !-
1680: !===
1681: !-
1682: SUBROUTINE get_reftemp_clear
1683: !---------------------------------------------------------------------
1684: firstcall=.TRUE.
1685: IF (ALLOCATED (trefe)) DEALLOCATE( trefe )
1686: !-------------------------------
1687: END SUBROUTINE get_reftemp_clear
1688: !-
1689: !===
1690: !-
1691: SUBROUTINE get_reftemp (npts, lalo, resolution, tref_out)
1692: !---------------------------------------------------------------------
1693: !- read the long-term reference temperature from a boundary condition
1694: !- file. If the vegetation is dynamic, this field is used to
1695: !- initialize correctly the (prognostic) long-term reference
1696: !- temperature (in the case it is not found in the restart file).
1697: !- If the vegetation is static, the field read here is a real boundary
1698: !- condition that is not modified by the model.
1699: !---------------------------------------------------------------------
1700: !-
1701: ! 0 declarations
1702: !-
1703: ! 0.1 input
1704: !-
1705: ! Domain size
1706: INTEGER(i_std),INTENT(in) :: npts
1707: ! Geogr. coordinates (latitude,longitude) (degrees)
1708: REAL(r_std),DIMENSION (npts,2),INTENT(in) :: lalo
1709: ! size in x an y of the grid (m)
1710: REAL(r_std),DIMENSION (npts,2),INTENT(in) :: resolution
1711: !-
1712: ! 0.2 output
1713: !-
1714: ! reference temperature (K)
1715: REAL(r_std), DIMENSION(npts),INTENT(out) :: tref_out
1716: !-
1717: ! 0.3 local
1718: !-
1719: INTEGER(i_std),PARAMETER :: nbvmax=200
1720: REAL(r_std),PARAMETER :: R_Earth = 6378000.
1721: CHARACTER(LEN=80) :: filename
1722: INTEGER(i_std) :: &
1723: & iml, jml, lml, tml, fid, ib, ip, jp, fopt, ilf, lastjp
1724: REAL(r_std) :: lev(1), date, dt, coslat
1725: INTEGER(i_std) :: itau(1)
1726: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: &
1727: & lat_rel, lon_rel, lat_ful, lon_ful, tref_file
1728: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: &
1729: & loup_rel, lolow_rel, laup_rel, lalow_rel
1730: REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
1731: REAL(r_std) :: ax, ay, sgn
1732: REAL(r_std),DIMENSION(nbvmax) :: area
1733: REAL(r_std),DIMENSION(nbvmax) :: tt
1734: REAL(r_std) :: m_pi
1735: REAL(r_std) :: resx, resy
1736: LOGICAL :: do_again
1737: !---------------------------------------------------------------------
1738: m_pi = 4. * ATAN(1.)
1739: !-
1740: ! 1 If this is the first call, calculate the reference temperature
1741: ! and keep it in memory
1742: !-
1743: IF (firstcall) THEN
1744: !---
1745: !-- 1.1 only do this once
1746: !---
1747: firstcall = .FALSE.
1748: !---
1749: !-- 1.2 allocate the field
1750: !---
1751: ALLOCATE( trefe(npts) )
1752: !---
1753: !-- 1.3 read and interpolate the temperature file
1754: !---
1755: !-- Needs to be a configurable variable
1756: !---
1757: !Config Key = REFTEMP_FILE
1758: !Config Desc = Name of file from which the reference
1759: !Config temperature is read
1760: !Config Def = reftemp.nc
1761: !Config Help = The name of the file to be opened to read
1762: !Config the reference surface temperature.
1763: !Config The data from this file is then interpolated
1764: !Config to the grid of of the model.
1765: !Config The aim is to get a reference temperature either
1766: !Config to initialize the corresponding prognostic model
1767: !Config variable correctly (ok_dgvm=TRUE) or to impose it
1768: !Config as boundary condition (ok_dgvm=FALSE)
1769: !---
1770: filename = 'reftemp.nc'
1771: CALL getin_p('REFTEMP_FILE',filename)
1772: !---
1773: IF (is_root_prc) CALL flininfo(filename,iml, jml, lml, tml, fid)
1774: CALL bcast(iml)
1775: CALL bcast(jml)
1776: CALL bcast(lml)
1777: CALL bcast(tml)
1778: !---
1779: ALLOCATE (lat_rel(iml,jml))
1780: ALLOCATE (lon_rel(iml,jml))
1781: ALLOCATE (laup_rel(iml,jml))
1782: ALLOCATE (loup_rel(iml,jml))
1783: ALLOCATE (lalow_rel(iml,jml))
1784: ALLOCATE (lolow_rel(iml,jml))
1785: ALLOCATE (lat_ful(iml+2,jml+2))
1786: ALLOCATE (lon_ful(iml+2,jml+2))
1787: ALLOCATE (tref_file(iml,jml))
1788: !---
1789: IF (is_root_prc) CALL flinopen (filename, .FALSE., iml, jml, lml, &
1790: & lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
1791: CALL bcast(lon_rel)
1792: CALL bcast(lat_rel)
1793: CALL bcast(itau)
1794: CALL bcast(date)
1795: CALL bcast(dt)
1796:
1797: !---
1798: IF (is_root_prc) CALL flinget (fid, 'temperature', iml, jml, lml, tml, &
1799: & 1, 1, tref_file)
1800: CALL bcast(tref_file)
1801: !---
1802: IF (is_root_prc) CALL flinclo (fid)
1803: !---
1804: !-- Duplicate the border assuming we have a global grid
1805: !-- going from west to east
1806: !---
1807: *V-----> lon_ful(2:iml+1,2:jml+1) = lon_rel(1:iml,1:jml)
1808: *V----- lat_ful(2:iml+1,2:jml+1) = lat_rel(1:iml,1:jml)
1809: !---
1810: IF ( lon_rel(iml,1) < lon_ful(2,2)) THEN
1811: V------> lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)
1812: V------ lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
1813: ELSE
1814: V------> lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)-360
1815: V------ lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
1816: ENDIF
1817: !---
1818: IF ( lon_rel(1,1) > lon_ful(iml+1,2)) THEN
1819: V------> lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)
1820: V------ lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
1821: ELSE
1822: V------> lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)+360
1823: V------ lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
1824: ENDIF
1825: !---
1826: sgn = lat_rel(1,1)/ABS(lat_rel(1,1))
1827: V====== lat_ful(2:iml+1,1) = sgn*180 - lat_rel(1:iml,1)
1828: sgn = lat_rel(1,jml)/ABS(lat_rel(1,jml))
1829: V====== lat_ful(2:iml+1,jml+2) = sgn*180 - lat_rel(1:iml,jml)
1830: lat_ful(1,1) = lat_ful(iml+1,1)
1831: lat_ful(iml+2,1) = lat_ful(2,1)
1832: lat_ful(1,jml+2) = lat_ful(iml+1,jml+2)
1833: lat_ful(iml+2,jml+2) = lat_ful(2,jml+2)
1834: !---
1835: !-- Add the longitude lines to the top and bottom
1836: !---
1837: V------> lon_ful(:,1) = lon_ful(:,2)
1838: V------ lon_ful(:,jml+2) = lon_ful(:,jml+1)
1839: !---
1840: !-- Get the upper and lower limits of each grid box
1841: !---
1842: X------> DO ip=1,iml
1843: |+-----> DO jp=1,jml
1844: || loup_rel(ip,jp) = &
1845: || & MAX(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), &
1846: || & 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
1847: || lolow_rel(ip,jp) = &
1848: || & MIN(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), &
1849: || & 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
1850: || laup_rel(ip,jp) = &
1851: || & MAX(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), &
1852: || & 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
1853: || lalow_rel(ip,jp) = &
1854: || & MIN(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), &
1855: || & 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
1856: |+----- ENDDO
1857: X------ ENDDO
1858: !---
1859: !-- Now we take each grid point and find out which values
1860: !-- from the forcing we need to average
1861: !---
1862: +------> DO ib=1,npts
1863: | !-----
1864: | resx = resolution(ib,1)
1865: | resy = resolution(ib,2)
1866: | !-----
1867: | do_again = .TRUE.
1868: | !-----
1869: |+-----> DO WHILE (do_again)
1870: || !-----
1871: || do_again = .FALSE.
1872: || !-------
1873: || !------ We find the 4 limits of the grid-box.
1874: || !------ As we transform the resolution of the model into longitudes
1875: || !------ and latitudes we do not have the problem of periodicity.
1876: || !------ coslat is a help variable here !
1877: || !-------
1878: || coslat = MAX(COS(lalo(ib,1)*m_pi/180.),0.001)*m_pi/180.*R_Earth
1879: || !-------
1880: || lon_up = lalo(ib,2)+resx/(2.0*coslat)
1881: || lon_low = lalo(ib,2)-resx/(2.0*coslat)
1882: || !-------
1883: || coslat = m_pi/180.*R_Earth
1884: || !-------
1885: || lat_up = lalo(ib,1)+resy/(2.0*coslat)
1886: || lat_low = lalo(ib,1)-resy/(2.0*coslat)
1887: || !-------
1888: || !------ Find the grid boxes from the data that go into
1889: || !------ the model's boxes.
1890: || !------ We still work as if we had a regular grid !
1891: || !------ Well it needs to be localy regular so that
1892: || !------ the longitude at the latitude of the last found point
1893: || !------ is close to the one of the next point.
1894: || !-------
1895: || fopt = 0
1896: || lastjp = 1
1897: ||+----> DO ip=1,iml
1898: ||| !---------
1899: ||| !-------- Either the center of the data grid point is in the interval
1900: ||| !-------- of the model grid or the East and West limits of the data
1901: ||| !-------- grid point are on either sides of the border of the data grid
1902: ||| !---------
1903: ||| IF ( lon_rel(ip,lastjp) > lon_low &
1904: ||| & .AND. lon_rel(ip,lastjp) < lon_up &
1905: ||| & .OR. lolow_rel(ip,lastjp) < lon_low &
1906: ||| & .AND. loup_rel(ip,lastjp) > lon_low &
1907: ||| & .OR. lolow_rel(ip,lastjp) < lon_up &
1908: ||| & .AND. loup_rel(ip,lastjp) > lon_up ) THEN
1909: |||+---> DO jp=1,jml
1910: |||| !-------------
1911: |||| !------------ Now that we have the longitude let us find the latitude
1912: |||| !-------------
1913: |||| IF ( lat_rel(ip,jp) > lat_low &
1914: |||| & .AND. lat_rel(ip,jp) < lat_up &
1915: |||| & .OR. lalow_rel(ip,jp) < lat_low &
1916: |||| & .AND. laup_rel(ip,jp) > lat_low &
1917: |||| & .OR. lalow_rel(ip,jp) < lat_up &
1918: |||| & .AND. laup_rel(ip,jp) > lat_up) THEN
1919: |||| lastjp = jp
1920: |||| !---------------
1921: |||| fopt = fopt + 1
1922: |||| IF ( fopt > nbvmax) THEN
1923: |||| WRITE(numout,*) &
1924: |||| & 'Please increase nbvmax in subroutine get_reftemp',ib
1925: |||| STOP
1926: |||| ELSE
1927: |||| !-----------------
1928: |||| !---------------- Get the area of the fine grid in the model grid
1929: |||| !-----------------
1930: |||| coslat = MAX(COS(lat_rel(ip,jp)*m_pi/180.),0.001)
1931: |||| ax = ( MIN(lon_up,loup_rel(ip,jp)) &
1932: |||| & -MAX(lon_low,lolow_rel(ip,jp))) &
1933: |||| & *m_pi/180.*R_Earth*coslat
1934: |||| ay = ( MIN(lat_up,laup_rel(ip,jp)) &
1935: |||| & -MAX(lat_low,lalow_rel(ip,jp))) &
1936: |||| & *m_pi/180.*R_Earth
1937: |||| area(fopt) = ax*ay
1938: |||| tt(fopt) = tref_file(ip,jp)
1939: |||| ENDIF
1940: |||| ENDIF
1941: |||+--- ENDDO
1942: ||| ENDIF
1943: ||+---- ENDDO
1944: || !-------
1945: || !------ Check that we found some points
1946: || !-------
1947: || trefe(ib) = 0.
1948: || !-------
1949: || IF (fopt == 0) THEN
1950: || do_again = .TRUE.
1951: || !-------
1952: || !------ increase search radius
1953: || !-------
1954: || resx = resx*2.
1955: || resy = resy*2.
1956: || IF ( resx > 2.*m_pi*R_Earth .OR. resy > m_pi*R_Earth ) THEN
1957: || STOP 'get_reftemp: found no point'
1958: || ENDIF
1959: || ELSE
1960: || sgn = zero
1961: || !-------
1962: || !------ Compute the average surface air temperature
1963: || !-------
1964: ||V----> DO ilf=1,fopt
1965: ||| trefe(ib) = trefe(ib) + tt(ilf) * area(ilf)
1966: ||| sgn = sgn + area(ilf)
1967: ||V---- ENDDO
1968: || !-------
1969: || !------ Normalize the surface
1970: || !-------
1971: || IF (sgn < min_sechiba) THEN
1972: || do_again = .TRUE.
1973: || !---------
1974: || !-------- increase search radius
1975: || !---------
1976: || resx = resx * 2.
1977: || resy = resy * 2.
1978: || IF ( resx > 2.*m_pi*R_Earth .OR. resy > m_pi*R_Earth ) THEN
1979: || STOP 'get_reftemp: found no point'
1980: || ENDIF
1981: || ELSE
1982: || trefe(ib) = trefe(ib) / sgn
1983: || ENDIF
1984: || ENDIF
1985: |+----- ENDDO
1986: +------ ENDDO
1987: !-
1988: ! transform into Kelvin
1989: !-
1990: V====== trefe(:) = trefe(:) + ZeroCelsius
1991: !-
1992: ! deallocate
1993: !-
1994: DEALLOCATE (lat_rel)
1995: DEALLOCATE (lon_rel)
1996: DEALLOCATE (laup_rel)
1997: DEALLOCATE (loup_rel)
1998: DEALLOCATE (lalow_rel)
1999: DEALLOCATE (lolow_rel)
2000: DEALLOCATE (lat_ful)
2001: DEALLOCATE (lon_ful)
2002: DEALLOCATE (tref_file)
2003: ENDIF
2004: !-
2005: ! 2 output the reference temperature
2006: !-
2007: V====== tref_out(:) = trefe(:)
2008: !-------------------------
2009: END SUBROUTINE get_reftemp
2010: !-
2011: !===
2012: !-
2013: END MODULE stomate_io
ORCHIDEE/src_stomate/i.stomate_litter.L 0000754 0103600 0005670 00000130606 11164403473 017661 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:32 2008
FILE NAME: i.stomate_litter.f90
PROGRAM NAME: stomate_litter
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
137 obsol( 18): CHARACTER* form of character declaration is used.
138 obsol( 18): CHARACTER* form of character declaration is used.
139 obsol( 18): CHARACTER* form of character declaration is used.
140 obsol( 18): CHARACTER* form of character declaration is used.
183 vec ( 1): Vectorized loop.
218 vec ( 4): Vectorized array expression.
246 vec ( 3): Unvectorized loop.
246 vec ( 13): Overhead of loop division is too large.
247 opt (1017): Subroutine call prevents optimization.
247 vec ( 17): Unvectorizable statement.
251 vec ( 3): Unvectorized loop.
251 vec ( 13): Overhead of loop division is too large.
252 opt (1017): Subroutine call prevents optimization.
252 vec ( 17): Unvectorizable statement.
257 vec ( 3): Unvectorized loop.
257 vec ( 7): Iteration count is too small.
258 opt (1017): Subroutine call prevents optimization.
258 vec ( 17): Unvectorizable statement.
265 vec ( 3): Unvectorized loop.
265 vec ( 7): Iteration count is too small.
273 vec ( 3): Unvectorized loop.
273 vec ( 7): Iteration count is too small.
274 opt (1017): Subroutine call prevents optimization.
288 vec ( 3): Unvectorized loop.
288 vec ( 13): Overhead of loop division is too large.
297 vec ( 4): Vectorized array expression.
297 vec ( 4): Vectorized array expression.
306 vec ( 4): Vectorized array expression.
307 vec ( 4): Vectorized array expression.
307 vec ( 4): Vectorized array expression.
308 vec ( 4): Vectorized array expression.
308 vec ( 4): Vectorized array expression.
308 vec ( 4): Vectorized array expression.
308 vec ( 4): Vectorized array expression.
308 vec ( 4): Vectorized array expression.
308 vec ( 4): Vectorized array expression.
322 vec ( 4): Vectorized array expression.
322 vec ( 4): Vectorized array expression.
322 vec ( 4): Vectorized array expression.
322 vec ( 4): Vectorized array expression.
331 vec ( 4): Vectorized array expression.
331 vec ( 4): Vectorized array expression.
331 vec ( 4): Vectorized array expression.
331 vec ( 4): Vectorized array expression.
331 vec ( 4): Vectorized array expression.
331 vec ( 4): Vectorized array expression.
331 vec ( 4): Vectorized array expression.
331 vec ( 4): Vectorized array expression.
332 vec ( 4): Vectorized array expression.
332 vec ( 4): Vectorized array expression.
332 vec ( 4): Vectorized array expression.
332 vec ( 4): Vectorized array expression.
344 vec ( 3): Unvectorized loop.
351 vec ( 4): Vectorized array expression.
373 opt (1036): Potential feedback - use directive if OK.
374 opt (1036): Potential feedback - use directive if OK.
386 opt (1036): Potential feedback - use directive if OK.
386 vec ( 4): Vectorized array expression.
399 opt (1036): Potential feedback - use directive if OK.
415 vec ( 4): Vectorized array expression.
415 vec ( 4): Vectorized array expression.
415 vec ( 4): Vectorized array expression.
415 vec ( 4): Vectorized array expression.
415 vec ( 4): Vectorized array expression.
415 vec ( 4): Vectorized array expression.
415 vec ( 4): Vectorized array expression.
415 vec ( 4): Vectorized array expression.
423 vec ( 4): Vectorized array expression.
423 vec ( 4): Vectorized array expression.
423 vec ( 4): Vectorized array expression.
423 vec ( 4): Vectorized array expression.
432 vec ( 4): Vectorized array expression.
432 vec ( 4): Vectorized array expression.
450 vec ( 2): Partially vectorized loop.
450 vec ( 25): Work vectors are used. Size=48byte
458 vec ( 4): Vectorized array expression.
458 vec ( 4): Vectorized array expression.
479 vec ( 4): Vectorized array expression.
493 vec ( 3): Unvectorized loop.
493 vec ( 3): Unvectorized loop.
495 opt (1592): Outer loop unrolled inside inner loop.
495 vec ( 4): Vectorized array expression.
495 vec ( 4): Vectorized array expression.
501 vec ( 4): Vectorized array expression.
525 vec ( 3): Unvectorized loop.
525 vec ( 3): Unvectorized loop.
527 opt (1592): Outer loop unrolled inside inner loop.
527 vec ( 4): Vectorized array expression.
527 vec ( 4): Vectorized array expression.
533 vec ( 4): Vectorized array expression.
540 vec ( 3): Unvectorized loop.
548 opt (1036): Potential feedback - use directive if OK.
548 opt (1036): Potential feedback - use directive if OK.
548 opt (1037): Feedback of array elements.
548 vec ( 4): Vectorized array expression.
560 vec ( 4): Vectorized array expression.
565 opt (1019): Feedback of scalar value from one loop pass to another.
565 opt (1019): Feedback of scalar value from one loop pass to another.
565 opt (1019): Feedback of scalar value from one loop pass to another.
565 vec ( 4): Vectorized array expression.
568 opt (1019): Feedback of scalar value from one loop pass to another.
575 opt (1019): Feedback of scalar value from one loop pass to another.
597 opt (1019): Feedback of scalar value from one loop pass to another.
597 vec ( 4): Vectorized array expression.
602 opt (1019): Feedback of scalar value from one loop pass to another.
602 vec ( 4): Vectorized array expression.
605 opt (1019): Feedback of scalar value from one loop pass to another.
616 vec ( 4): Vectorized array expression.
627 warn ( 82): Name "zdiff_min" is not used.
627 warn ( 82): Name "i" is not used.
660 vec ( 4): Vectorized array expression.
662 vec ( 3): Unvectorized loop.
662 vec ( 13): Overhead of loop division is too large.
665 opt (1019): Feedback of scalar value from one loop pass to another.
665 vec ( 4): Vectorized array expression.
668 opt (1019): Feedback of scalar value from one loop pass to another.
668 vec ( 4): Vectorized array expression.
678 vec ( 4): Vectorized array expression.
702 vec ( 4): Vectorized array expression.
725 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:32 2008
FILE NAME: i.stomate_litter.f90
PROGRAM NAME: stomate_litter
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! Update litter and lignine content after litter fall.
2: ! Calculate litter decomposition.
3: !
4: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_litter.f90,v 1.7 2007/05/28 15:03:35 ssipsl Exp $
5: ! IPSL (2006)
6: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
7: !
8: MODULE stomate_litter
9:
10: ! modules used:
11:
12: USE ioipsl
13: USE stomate_constants
14: USE constantes_veg
15:
16: IMPLICIT NONE
17:
18: ! private & public routines
19:
20: PRIVATE
21: PUBLIC littercalc,littercalc_clear, deadleaf
22:
23: ! first call
24: LOGICAL, SAVE :: firstcall = .TRUE.
25:
26: CONTAINS
27:
28: SUBROUTINE littercalc_clear
29: firstcall =.TRUE.
30: END SUBROUTINE littercalc_clear
31:
32:
33: SUBROUTINE littercalc (npts, dt, space_nat, &
34: turnover, bm_to_litter, &
35: tsurf, tsoil, soilhum, litterhum, &
36: litterpart, litter, dead_leaves, lignin_struc, &
37: deadleaf_cover, resp_hetero_litter, &
38: soilcarbon_input, control_temp, control_moist)
39:
40: !
41: ! 0 declarations
42: !
43:
44: ! 0.1 input
45:
46: ! Domain size
47: INTEGER(i_std), INTENT(in) :: npts
48: ! time step in days
49: REAL(r_std), INTENT(in) :: dt
50: ! total natural space (fraction of total space)
51: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
52: ! Turnover rates (gC/(m**2 of nat/agri ground)/day)
53: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: turnover
54: ! conversion of biomass to litter (gC/(m**2 of average nat. or agric. ground)) / day
55: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: bm_to_litter
56: ! temperature (K) at the surface
57: REAL(r_std), DIMENSION(npts), INTENT(in) :: tsurf
58: ! soil temperature (K)
59: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil
60: ! daily soil humidity
61: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum
62: ! daily litter humidity
63: REAL(r_std), DIMENSION(npts), INTENT(in) :: litterhum
64:
65: ! 0.2 modified fields
66:
67: ! fraction of litter above the ground belonging to different PFTs
68: REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: litterpart
69: ! metabolic and structural litter, natural and agricultural,
70: ! above and below ground (gC/m**2 of natural or agricultural ground)
71: REAL(r_std), DIMENSION(npts,nlitt,nvegtypes,nlevs), INTENT(inout) :: litter
72: ! dead leaves on ground, per PFT, metabolic and structural,
73: ! in gC/(m**2 of nat/agri ground)
74: REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: dead_leaves
75: ! ratio Lignine/Carbon in structural litter, above and below ground,
76: ! natural and agricultural (gC/m**2)
77: REAL(r_std), DIMENSION(npts,nvegtypes,nlevs), INTENT(inout) :: lignin_struc
78:
79: ! 0.3 output
80:
81: ! fraction of soil covered by dead leaves
82: REAL(r_std), DIMENSION(npts), INTENT(out) :: deadleaf_cover
83: ! litter heterotrophic respiration (first in gC/day/m**2 of natural/agricultural ground,
84: ! but output in gC/day/m**2 of total ground)
85: REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(out) :: resp_hetero_litter
86: ! quantity of carbon going into carbon pools from litter decomposition
87: ! (gC/(m**2 of nat/agri ground)/day)
88: REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(out) :: soilcarbon_input
89: ! temperature control of heterotrophic respiration, above and below
90: REAL(r_std), DIMENSION(npts,nlevs), INTENT(out) :: control_temp
91: ! moisture control of heterotrophic respiration
92: REAL(r_std), DIMENSION(npts,nlevs), INTENT(out) :: control_moist
93:
94: ! 0.4 local
95:
96: ! C/N ratio
97: REAL(r_std), SAVE, DIMENSION(nparts) :: CN
98: ! what fraction of leaves, wood, etc. goes into metabolic and structural litterpools
99: REAL(r_std), SAVE, DIMENSION(nparts,nlitt) :: litterfrac
100: ! Lignine/C ratio of the different plant parts
101: REAL(r_std), SAVE, DIMENSION(nparts) :: LC
102: ! soil levels (m)
103: REAL(r_std), SAVE, DIMENSION(0:nbdl) :: z_soil
104: ! scaling depth for soil activity (m)
105: REAL(r_std), PARAMETER :: z_decomp = 0.2
106: ! integration constant for vertical profiles
107: REAL(r_std), DIMENSION(npts) :: rpc
108: ! residence time in litter pools (days)
109: REAL(r_std), SAVE, DIMENSION(nlitt) :: litter_tau
110: ! decomposition flux fraction that goes into soil (litter -> carbon, above and below)
111: ! rest goes into atmosphere
112: REAL(r_std), SAVE, DIMENSION(nlitt,ncarb,nlevs) :: frac_soil
113: ! temperature used for decompostition in soil (K)
114: REAL(r_std), DIMENSION(npts) :: tsoil_decomp
115: ! humidity used for decompostition in soil
116: REAL(r_std), DIMENSION(npts) :: soilhum_decomp
117: ! fraction of structural or metabolic litter decomposed
118: REAL(r_std), DIMENSION(npts) :: fd
119: ! quantity of structural or metabolic litter decomposed (gC/m**2)
120: REAL(r_std), DIMENSION(npts) :: qd
121: ! old structural litter, natural and agricultural, above and below (gC/m**2)
122: REAL(r_std), DIMENSION(npts,nvegtypes,nlevs) :: old_struc
123: ! increase of litter, per PFT, metabolic and structural,
124: ! above and below ground (gC/m**2 of natural or agricultural ground)
125: REAL(r_std), DIMENSION(npts,npft,nlitt,nlevs) :: litter_inc_PFT
126: ! increase of metabolic and structural litter, natural and agricultural,
127: ! above and below ground (gC/m**2 of natural or agricultural ground)
128: REAL(r_std), DIMENSION(npts,nlitt,nvegtypes,nlevs) :: litter_inc
129: ! lignin increase in structural litter, natural and agricultural,
130: ! above and below ground (gC/m**2 of natural or agricultural ground)
131: REAL(r_std), DIMENSION(npts,nvegtypes,nlevs) :: lignin_struc_inc
132: ! metabolic and structural litter above the ground per PFT ( for natural PFTs)
133: REAL(r_std), DIMENSION(npts,npft,nlitt) :: litter_pft
134: ! intermediate array for looking for minimum
135: REAL(r_std), DIMENSION(npts) :: zdiff_min
136: ! for messages
137: CHARACTER*10, DIMENSION(nlitt) :: litter_str
138: CHARACTER*22, DIMENSION(nparts) :: part_str
139: CHARACTER*7, DIMENSION(ncarb) :: carbon_str
140: CHARACTER*5, DIMENSION(nlevs) :: level_str
141: ! Indices
142: INTEGER(i_std) :: i,j,k,l,m
143:
144: ! =========================================================================
145:
146: IF (bavard.GE.3) WRITE(numout,*) 'Entering littercalc'
147:
148: !
149: ! 1 Initialisations
150: !
151:
152: IF ( firstcall ) THEN
153:
154: !
155: ! 1.1 get soil "constants"
156: !
157:
158: ! 1.1.1 C/N ratios
159:
160: CN(ileaf) = 40.0
161: CN(isapabove) = 40.0
162: CN(isapbelow) = 40.0
163: CN(iheartabove) = 40.0
164: CN(iheartbelow) = 40.0
165: CN(iroot) = 40.0
166: CN(ifruit) = 40.0
167: CN(icarbres) = 40.0
168:
169: ! 1.1.2 Lignine/C ratios
170:
171: LC(ileaf) = 0.22
172: LC(isapabove) = 0.35
173: LC(isapbelow) = 0.35
174: LC(iheartabove) = 0.35
175: LC(iheartbelow) = 0.35
176: LC(iroot) = 0.22
177: LC(ifruit) = 0.22
178: LC(icarbres) = 0.22
179:
180: ! 1.1.3 litter fractions:
181: ! what fraction of leaves, wood, etc. goes into metabolic and structural litterpools
182:
183: V------> DO k = 1, nparts
184: |
185: | litterfrac(k,imetabolic) = 0.85 - 0.018 * LC(k) * CN(k)
186: | litterfrac(k,istructural) = 1. - litterfrac(k,imetabolic)
187: |
188: V------ ENDDO
189:
190: ! 1.1.4 residence times in litter pools (days)
191:
192: litter_tau(imetabolic) = .066 * one_year !!!!???? .5 years
193: litter_tau(istructural) = .245 * one_year !!!!???? 3 years
194:
195: ! 1.1.5 decomposition flux fraction that goes into soil
196: ! (litter -> carbon, above and below)
197: ! 1-frac_soil goes into atmosphere
198:
199: +++==== frac_soil(:,:,:) = zero
200:
201: ! structural litter: lignin fraction goes into slow pool + respiration,
202: ! rest into active pool + respiration
203: frac_soil(istructural,iactive,iabove) = .55
204: frac_soil(istructural,iactive,ibelow) = .45
205: frac_soil(istructural,islow,iabove) = .7
206: frac_soil(istructural,islow,ibelow) = .7
207:
208: ! metabolic litter: all goes into active pool + respiration.
209: ! Nothing into slow or passive pool.
210: frac_soil(imetabolic,iactive,iabove) = .45
211: frac_soil(imetabolic,iactive,ibelow) = .45
212:
213: !
214: ! 1.2 soil levels
215: !
216:
217: z_soil(0) = 0.
218: V====== z_soil(1:nbdl) = diaglev(1:nbdl)
219:
220: !
221: ! 1.3 messages
222: !
223:
224: litter_str(imetabolic) = 'metabolic'
225: litter_str(istructural) = 'structural'
226:
227: carbon_str(iactive) = 'active'
228: carbon_str(islow) = 'slow'
229: carbon_str(ipassive) = 'passive'
230:
231: level_str(iabove) = 'above'
232: level_str(ibelow) = 'below'
233:
234: part_str(ileaf) = 'leaves'
235: part_str(isapabove) = 'sap above ground'
236: part_str(isapbelow) = 'sap below ground'
237: part_str(iheartabove) = 'heartwood above ground'
238: part_str(iheartbelow) = 'heartwood below ground'
239: part_str(iroot) = 'roots'
240: part_str(ifruit) = 'fruits'
241: part_str(icarbres) = 'carbohydrate reserve'
242:
243: WRITE(numout,*) 'litter:'
244:
245: WRITE(numout,*) ' > C/N ratios: '
246: +------> DO k = 1, nparts
247: | WRITE(numout,*) ' ', part_str(k), ': ',CN(k)
248: +------ ENDDO
249:
250: WRITE(numout,*) ' > Lignine/C ratios: '
251: +------> DO k = 1, nparts
252: | WRITE(numout,*) ' ', part_str(k), ': ',LC(k)
253: +------ ENDDO
254:
255: WRITE(numout,*) ' > fraction of compartment that goes into litter: '
256: +------> DO k = 1, nparts
257: |+-----> DO m = 1, nlitt
258: || WRITE(numout,*) ' ', part_str(k), '-> ',litter_str(m), ':',litterfrac(k,m)
259: |+----- ENDDO
260: +------ ENDDO
261:
262: WRITE(numout,*) ' > scaling depth for decomposition (m): ',z_decomp
263:
264: WRITE(numout,*) ' > minimal carbon residence time in litter pools (d):'
265: +------> DO m = 1, nlitt
266: | WRITE(numout,*) ' ',litter_str(m),':',litter_tau(m)
267: +------ ENDDO
268:
269: WRITE(numout,*) ' > litter decomposition flux fraction that really goes '
270: WRITE(numout,*) ' into carbon pools (rest into the atmosphere):'
271: +------> DO m = 1, nlitt
272: |+-----> DO l = 1, nlevs
273: ||+----> DO k = 1, ncarb
274: ||| WRITE(numout,*) ' ',litter_str(m),' ',level_str(l),' -> ',&
275: ||| carbon_str(k),':', frac_soil(m,k,l)
276: ||+---- ENDDO
277: |+----- ENDDO
278: +------ ENDDO
279:
280: firstcall = .FALSE.
281:
282: ENDIF
283:
284: !
285: ! 1.3 litter above the ground per PFT.
286: !
287:
288: +------> DO j = 1, npft
289: |
290: | IF ( natural(j) ) THEN
291: | m = inat
292: | ELSE
293: | m = iagri
294: | ENDIF
295: |
296: |+-----> DO k = 1, nlitt
297: ||V==== litter_pft(:,j,k) = litterpart(:,j,k) * litter(:,k,m,iabove)
298: |+----- ENDDO
299: |
300: +------ ENDDO
301:
302: !
303: ! 1.4 set output to zero
304: !
305:
306: V====== deadleaf_cover(:) = zero
307: +V===== resp_hetero_litter(:,:) = zero
308: ++V==== soilcarbon_input(:,:,:) = zero
309:
310: !
311: ! 2 Add biomass to different litterpools (per m**2 of nat/agri ground)
312: !
313:
314: !
315: ! 2.1 first, save old structural litter (needed for lignin fractions).
316: ! nat/agri, above/below
317: !
318:
319: +------> DO l = 1, nlevs
320: |+-----> DO m = 1, nvegtypes
321: ||
322: ||V==== old_struc(:,m,l) = litter(:,istructural,m,l)
323: ||
324: |+----- ENDDO
325: +------ ENDDO
326:
327: !
328: ! 2.2 update litter, dead leaves, and lignin content in structural litter
329: !
330:
331: +++V=== litter_inc(:,:,:,:) = zero
332: ++V==== lignin_struc_inc(:,:,:) = zero
333:
334: +------> DO j = 1, npft
335: |
336: | ! 2.2.1 natural or agricultural litter
337: |
338: | IF ( natural(j) ) THEN
339: | m = inat
340: | ELSE
341: | m = iagri
342: | ENDIF
343: |
344: |+-----> DO k = 1, nlitt ! metabolic and structural
345: ||
346: || ! 2.2.2 calculate litter increase (per m**2 of average agricultural or
347: || ! natural ground).
348: || ! Only a given fracion of fruit turnover is directly coverted into litter.
349: || ! Litter increase for each PFT, structural and metabolic, above/below
350: ||
351: ||V----> litter_inc_PFT(:,j,k,iabove) = &
352: ||| litterfrac(ileaf,k) * bm_to_litter(:,j,ileaf) + &
353: ||| litterfrac(isapabove,k) * bm_to_litter(:,j,isapabove) + &
354: ||| litterfrac(iheartabove,k) * bm_to_litter(:,j,iheartabove) + &
355: ||| litterfrac(ifruit,k) * bm_to_litter(:,j,ifruit) + &
356: ||| litterfrac(icarbres,k) * bm_to_litter(:,j,icarbres) + &
357: ||| litterfrac(ileaf,k) * turnover(:,j,ileaf) + &
358: ||| litterfrac(isapabove,k) * turnover(:,j,isapabove) + &
359: ||| litterfrac(iheartabove,k) * turnover(:,j,iheartabove) + &
360: ||| litterfrac(ifruit,k) * turnover(:,j,ifruit) + &
361: ||| litterfrac(icarbres,k) * turnover(:,j,icarbres)
362: |||
363: ||| litter_inc_PFT(:,j,k,ibelow) = &
364: ||| litterfrac(isapbelow,k) * bm_to_litter(:,j,isapbelow) + &
365: ||| litterfrac(iheartbelow,k) * bm_to_litter(:,j,iheartbelow) + &
366: ||| litterfrac(iroot,k) * bm_to_litter(:,j,iroot) + &
367: ||| litterfrac(isapbelow,k) * turnover(:,j,isapbelow) + &
368: ||| litterfrac(iheartbelow,k) * turnover(:,j,iheartbelow) + &
369: ||| litterfrac(iroot,k) * turnover(:,j,iroot)
370: |||
371: ||| ! litter increase, met/struct, nat/agri, above/below
372: |||
373: ||| litter_inc(:,k,m,iabove) = litter_inc(:,k,m,iabove) + litter_inc_PFT(:,j,k,iabove)
374: ||| litter_inc(:,k,m,ibelow) = litter_inc(:,k,m,ibelow) + litter_inc_PFT(:,j,k,ibelow)
375: |||
376: ||| ! 2.2.3 dead leaves, for soil cover.
377: |||
378: ||V---- dead_leaves(:,j,k) = &
379: || dead_leaves(:,j,k) + &
380: || litterfrac(ileaf,k) * ( bm_to_litter(:,j,ileaf) + turnover(:,j,ileaf) )
381: ||
382: || ! 2.2.4 lignin increase in structural litter
383: ||
384: || IF ( k .EQ. istructural ) THEN
385: ||
386: ||V----> lignin_struc_inc(:,m,iabove) = &
387: ||| lignin_struc_inc(:,m,iabove) + &
388: ||| LC(ileaf) * bm_to_litter(:,j,ileaf) + &
389: ||| LC(isapabove) * bm_to_litter(:,j,isapabove) + &
390: ||| LC(iheartabove) * bm_to_litter(:,j,iheartabove) + &
391: ||| LC(ifruit) * bm_to_litter(:,j,ifruit) + &
392: ||| LC(icarbres) * bm_to_litter(:,j,icarbres) + &
393: ||| LC(ileaf) * turnover(:,j,ileaf) + &
394: ||| LC(isapabove) * turnover(:,j,isapabove) + &
395: ||| LC(iheartabove) * turnover(:,j,iheartabove) + &
396: ||| LC(ifruit) * turnover(:,j,ifruit) + &
397: ||| LC(icarbres) * turnover(:,j,icarbres)
398: |||
399: ||V---- lignin_struc_inc(:,m,ibelow) = &
400: || lignin_struc_inc(:,m,ibelow) + &
401: || LC(isapbelow) * bm_to_litter(:,j,isapbelow) + &
402: || LC(iheartbelow) * bm_to_litter(:,j,iheartbelow) + &
403: || LC(iroot) * bm_to_litter(:,j,iroot) + &
404: || LC(isapbelow)*turnover(:,j,isapbelow) + &
405: || LC(iheartbelow)*turnover(:,j,iheartbelow) + &
406: || LC(iroot)*turnover(:,j,iroot)
407: ||
408: || ENDIF
409: ||
410: |+----- ENDDO
411: +------ ENDDO
412:
413: ! 3.2.5 add new litter (struct/met, nat/agri, above/below)
414:
415: +++V=== litter(:,:,:,:) = litter(:,:,:,:) + litter_inc(:,:,:,:)
416:
417: ! 3.2.6 for security: can't add more lignin than structural litter
418: ! (nat/agri, above/below)
419:
420: +------> DO l = 1, nlevs
421: |+-----> DO m = 1, nvegtypes
422: ||
423: ||V==== lignin_struc_inc(:,m,l) = &
424: || MIN( lignin_struc_inc(:,m,l), litter_inc(:,istructural,m,l) )
425: ||
426: |+----- ENDDO
427: +------ ENDDO
428:
429: ! 3.2.7 new lignin content: add old lignin and lignin increase, divide by
430: ! total structural litter (nat/agri, above/below)
431:
432: **V----> WHERE ( litter(:,istructural,:,:) .GT. 0.0 )
433: |||
434: ||| lignin_struc(:,:,:) = &
435: ||| ( lignin_struc(:,:,:)*old_struc(:,:,:) + lignin_struc_inc(:,:,:) ) / &
436: ||| litter(:,istructural,:,:)
437: |||
438: ||| ELSEWHERE
439: |||
440: **V---- lignin_struc(:,:,:) = zero
441:
442: ENDWHERE
443:
444: !
445: ! 3.3 new litter fraction per PFT (for structural and metabolic litter, above
446: ! the ground). Fractions are calculated separately for the natural and
447: ! for the agricultural ground.
448: !
449:
450: V------> DO j = 1, npft
451: |
452: | IF ( natural(j) ) THEN
453: | m = inat
454: | ELSE
455: | m = iagri
456: | ENDIF
457: |
458: |*V----> WHERE ( litter(:,:,m,iabove) .GT. 0.0 )
459: |||
460: ||| litterpart(:,j,:) = &
461: ||| ( litter_pft(:,j,:) + litter_inc_PFT(:,j,:,iabove) ) / litter(:,:,m,iabove)
462: |||
463: ||| ELSEWHERE
464: |||
465: |*V---- litterpart(:,j,:) = zero
466: |
467: | ENDWHERE
468: |
469: V------ ENDDO
470:
471: !
472: ! 4 Temperature control on decay: Factor between 0 and 1
473: !
474:
475: !
476: ! 4.1 above: surface temperature
477: !
478:
479: V------> control_temp(:,iabove) = control_temp_func (npts, tsurf)
480: |
481: | !
482: | ! 4.2 below: convolution of temperature and decomposer profiles
483: | ! (exponential decomposer profile supposed)
484: | !
485: |
486: | ! 4.2.1 rpc is an integration constant such that the integral of the root profile is 1.
487: | rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_decomp ) )
488: |
489: | ! 4.2.2 integrate over the nbdl levels
490: |
491: V------ tsoil_decomp(:) = 0.0
492:
493: +------> DO l = 1, nbdl
494: |
495: |V===== tsoil_decomp(:) = &
496: | tsoil_decomp(:) + tsoil(:,l) * rpc(:) * &
497: | ( EXP( -z_soil(l-1)/z_decomp ) - EXP( -z_soil(l)/z_decomp ) )
498: |
499: +------ ENDDO
500:
501: V------> control_temp(:,ibelow) = control_temp_func (npts, tsoil_decomp)
502: |
503: | !
504: | ! 5 Moisture control. Factor between 0 and 1
505: | !
506: |
507: | !
508: | ! 5.1 above the ground: litter humidity
509: | !
510: |
511: | control_moist(:,iabove) = control_moist_func (npts, litterhum)
512: |
513: | !
514: | ! 5.2 below: convolution of humidity and decomposer profiles
515: | ! (exponential decomposer profile supposed)
516: | !
517: |
518: | ! 5.2.1 rpc is an integration constant such that the integral of the root profile is 1.
519: | rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / z_decomp ) )
520: |
521: | ! 5.2.2 integrate over the nbdl levels
522: |
523: V------ soilhum_decomp(:) = 0.0
524:
525: +------> DO l = 1, nbdl
526: |
527: |V===== soilhum_decomp(:) = &
528: | soilhum_decomp(:) + soilhum(:,l) * rpc(:) * &
529: | ( EXP( -z_soil(l-1)/z_decomp ) - EXP( -z_soil(l)/z_decomp ) )
530: |
531: +------ ENDDO
532:
533: V====== control_moist(:,ibelow) = control_moist_func (npts, soilhum_decomp)
534:
535: !
536: ! 6 fluxes from litter to carbon pools and respiration
537: !
538:
539: +------> DO l = 1, nlevs
540: |+-----> DO m = 1, nvegtypes
541: ||
542: || !
543: || ! 6.1 structural litter: goes into active and slow carbon pools + respiration
544: || !
545: ||
546: || ! 6.1.1 total quantity of structural litter which is decomposed
547: ||
548: ||V----> fd(:) = dt/litter_tau(istructural) * &
549: ||| control_temp(:,l) * control_moist(:,l) * exp( -3. * lignin_struc(:,m,l) )
550: |||
551: ||| qd(:) = litter(:,istructural,m,l) * fd(:)
552: |||
553: ||V---- litter(:,istructural,m,l) = litter(:,istructural,m,l) - qd(:)
554: ||
555: || ! 6.1.2 decompose same fraction of structural part of dead leaves. Not exact
556: || ! as lignine content is not the same as that of the total structural litter.
557: ||
558: || ! to avoid a multiple (for ibelow and iabove) modification of dead_leaves,
559: || ! we do this test to do this calcul only ones in 1,nlev loop
560: ||V==== if (l == iabove) dead_leaves(:,m,istructural) = dead_leaves(:,m,istructural) * ( 1. - fd(:) )
561: ||
562: || ! 6.1.3 non-lignin fraction of structural litter goes into
563: || ! active carbon pool + respiration
564: ||
565: ||V----> soilcarbon_input(:,iactive,m) = soilcarbon_input(:,iactive,m) + &
566: ||| frac_soil(istructural,iactive,l) * qd(:) * ( 1. - lignin_struc(:,m,l) ) / dt
567: |||
568: ||| resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
569: ||| ( 1. - frac_soil(istructural,iactive,l) ) * qd(:) * &
570: ||| ( 1. - lignin_struc(:,m,l) ) / dt
571: |||
572: ||| ! 6.1.4 lignin fraction of structural litter goes into
573: ||| ! slow carbon pool + respiration
574: |||
575: ||| soilcarbon_input(:,islow,m) = soilcarbon_input(:,islow,m) + &
576: ||| frac_soil(istructural,islow,l) * qd(:) * lignin_struc(:,m,l) / dt
577: |||
578: ||| resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
579: ||| ( 1. - frac_soil(istructural,islow,l) ) * qd(:) * lignin_struc(:,m,l) / dt
580: |||
581: ||| !
582: ||| ! 6.2 metabolic litter goes into active carbon pool + respiration
583: ||| !
584: |||
585: ||| ! 6.2.1 total quantity of metabolic litter that is decomposed
586: |||
587: ||| fd(:) = dt/litter_tau(imetabolic) * control_temp(:,l) * control_moist(:,l)
588: |||
589: ||| qd(:) = litter(:,imetabolic,m,l) * fd(:)
590: |||
591: ||V---- litter(:,imetabolic,m,l) = litter(:,imetabolic,m,l) - qd(:)
592: ||
593: || ! 6.2.2 decompose same fraction of metabolic part of dead leaves.
594: ||
595: || ! to avoid a multiple (for ibelow and iabove) modification of dead_leaves,
596: || ! we do this test to do this calcul only ones in 1,nlev loop
597: ||V==== if (l == iabove) dead_leaves(:,m,imetabolic) = dead_leaves(:,m,imetabolic) * ( 1. - fd(:) )
598: ||
599: ||
600: || ! 6.2.3 put decomposed litter into carbon pool + respiration
601: ||
602: ||V----> soilcarbon_input(:,iactive,m) = soilcarbon_input(:,iactive,m) + &
603: ||| frac_soil(imetabolic,iactive,l) * qd(:) / dt
604: |||
605: ||V---- resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
606: || ( 1. - frac_soil(imetabolic,iactive,l) ) * qd(:) / dt
607: ||
608: |+----- ENDDO
609: +------ ENDDO
610:
611: !
612: ! 7 transform respiration from gC/day/(m**2 of nat/agri ground) to
613: ! gC/day/(m**2 of total ground), as it goes into the atmosphere.
614: !
615:
616: V------> resp_hetero_litter(:,iagri) = resp_hetero_litter(:,iagri) * ( 1. - space_nat(:) )
617: V------ resp_hetero_litter(:,inat) = resp_hetero_litter(:,inat) * ( space_nat(:) )
618:
619: !
620: ! 8 calculate fraction of total soil covered by dead leaves
621: !
622:
623: CALL deadleaf (npts, space_nat, dead_leaves, deadleaf_cover)
624:
625: IF (bavard.GE.4) WRITE(numout,*) 'Leaving littercalc'
626:
627: END SUBROUTINE littercalc
628:
629: SUBROUTINE deadleaf (npts, space_nat, dead_leaves, deadleaf_cover)
630:
631: !
632: ! 0 declarations
633: !
634:
635: ! 0.1 input
636:
637: ! Domain size
638: INTEGER(i_std), INTENT(in) :: npts
639: ! total natural space (fraction of total space)
640: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
641: ! dead leaves on ground, per PFT, metabolic and structural,
642: ! in gC/(m**2 of nat/agri ground)
643: REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(in) :: dead_leaves
644:
645: ! 0.2. output
646: ! fraction of soil covered by dead leaves
647: REAL(r_std), DIMENSION(npts), INTENT(out) :: deadleaf_cover
648:
649: ! 0.3. local
650:
651: ! LAI of dead leaves
652: REAL(r_std), DIMENSION(npts) :: dead_lai
653: ! Index
654: INTEGER(i_std) :: j
655:
656: !
657: ! 1 LAI of dead leaves
658: !
659:
660: V====== dead_lai(:) = zero
661:
662: +------> DO j = 1, npft
663: |
664: | IF ( natural(j) ) THEN
665: |V===== dead_lai(:) = dead_lai(:) + space_nat(:) * &
666: | ( dead_leaves(:,j,imetabolic) + dead_leaves(:,j,istructural) ) * sla(j)
667: | ELSE
668: |V===== dead_lai(:) = dead_lai(:) + ( 1. - space_nat(:) ) * &
669: | ( dead_leaves(:,j,imetabolic) + dead_leaves(:,j,istructural) ) * sla(j)
670: | ENDIF
671: |
672: +------ ENDDO
673:
674: !
675: ! 2 fraction of soil covered by dead leaves
676: !
677:
678: V====== deadleaf_cover(:) = 1. - exp( - 0.5 * dead_lai(:) )
679:
680: IF (bavard.GE.4) WRITE(numout,*) 'Leaving deadleaf'
681:
682: END SUBROUTINE deadleaf
683:
684: FUNCTION control_moist_func (npts, moist_in) RESULT (moistfunc_result)
685:
686: !
687: ! 0 declarations
688: !
689:
690: ! 0.1 input
691:
692: ! Domain size
693: INTEGER(i_std), INTENT(in) :: npts
694: ! relative humidity
695: REAL(r_std), DIMENSION(npts), INTENT(in) :: moist_in
696:
697: ! 0.2 result
698:
699: ! moisture control factor
700: REAL(r_std), DIMENSION(npts) :: moistfunc_result
701:
702: V------> moistfunc_result(:) = -1.1 * moist_in(:) * moist_in(:) + 2.4 * moist_in(:) - 0.29
703: V------ moistfunc_result(:) = MAX( 0.25_r_std, MIN( 1._r_std, moistfunc_result(:) ) )
704:
705: END FUNCTION control_moist_func
706:
707: FUNCTION control_temp_func (npts, temp_in) RESULT (tempfunc_result)
708:
709: !
710: ! 0 declarations
711: !
712:
713: ! 0.1 input
714:
715: ! Domain size
716: INTEGER(i_std), INTENT(in) :: npts
717: ! temperature (K)
718: REAL(r_std), DIMENSION(npts), INTENT(in) :: temp_in
719:
720: ! 0.2 result
721:
722: ! temperature control factor
723: REAL(r_std), DIMENSION(npts) :: tempfunc_result
724:
725: V------> tempfunc_result(:) = exp( 0.69 * ( temp_in(:) - (ZeroCelsius+30.) ) / 10. )
726: V------ tempfunc_result(:) = MIN( 1._r_std, tempfunc_result(:) )
727:
728: END FUNCTION control_temp_func
729:
730: END MODULE stomate_litter
ORCHIDEE/src_stomate/i.stomate_npp.L 0000754 0103600 0005670 00000072336 11164403473 017160 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:34 2008
FILE NAME: i.stomate_npp.f90
PROGRAM NAME: stomate_npp
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
150 vec ( 4): Vectorized array expression.
167 opt (1593): Loop nest collapsed into one loop.
167 vec ( 4): Vectorized array expression.
179 vec ( 4): Vectorized array expression.
185 vec ( 3): Unvectorized loop.
185 vec ( 13): Overhead of loop division is too large.
187 vec ( 4): Vectorized array expression.
199 opt (1592): Outer loop unrolled inside inner loop.
199 vec ( 4): Vectorized array expression.
213 vec ( 4): Vectorized array expression.
230 vec ( 4): Vectorized array expression.
232 vec ( 4): Vectorized array expression.
239 opt (1082): Backward transfers inhibit loop optimization.
239 vec ( 4): Vectorized array expression.
243 vec ( 3): Unvectorized loop.
245 opt (1592): Outer loop unrolled inside inner loop.
245 vec ( 4): Vectorized array expression.
269 vec ( 4): Vectorized array expression.
272 warn ( 7): Characters in a line over this form limitation 132.
272 vec ( 3): Unvectorized loop.
273 vec ( 4): Vectorized array expression.
287 opt (1036): Potential feedback - use directive if OK.
287 vec ( 4): Vectorized array expression.
289 vec ( 1): Vectorized loop.
327 vec ( 3): Unvectorized loop.
328 opt (1592): Outer loop unrolled inside inner loop.
328 vec ( 4): Vectorized array expression.
336 opt (1036): Potential feedback - use directive if OK.
336 vec ( 4): Vectorized array expression.
338 opt (1592): Outer loop unrolled inside inner loop.
338 opt (1592): Outer loop unrolled inside inner loop.
346 vec ( 4): Vectorized array expression.
348 vec ( 3): Unvectorized loop.
349 vec ( 4): Vectorized array expression.
350 opt (1592): Outer loop unrolled inside inner loop.
359 opt (1592): Outer loop unrolled inside inner loop.
359 vec ( 4): Vectorized array expression.
361 opt (1592): Outer loop unrolled inside inner loop.
361 vec ( 4): Vectorized array expression.
371 vec ( 3): Unvectorized loop.
371 vec ( 13): Overhead of loop division is too large.
373 vec ( 4): Vectorized array expression.
389 opt (1593): Loop nest collapsed into one loop.
389 vec ( 4): Vectorized array expression.
407 opt (1592): Outer loop unrolled inside inner loop.
407 vec ( 4): Vectorized array expression.
409 opt (1592): Outer loop unrolled inside inner loop.
409 vec ( 4): Vectorized array expression.
423 opt (1592): Outer loop unrolled inside inner loop.
423 vec ( 4): Vectorized array expression.
433 opt (1592): Outer loop unrolled inside inner loop.
433 vec ( 4): Vectorized array expression.
433 vec ( 4): Vectorized array expression.
433 vec ( 4): Vectorized array expression.
449 opt (1592): Outer loop unrolled inside inner loop.
449 vec ( 4): Vectorized array expression.
467 vec ( 3): Unvectorized loop.
467 vec ( 13): Overhead of loop division is too large.
476 vec ( 4): Vectorized array expression.
481 opt (1082): Backward transfers inhibit loop optimization.
481 vec ( 4): Vectorized array expression.
508 warn ( 83): Dummy argument "lai" is not used.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:34 2008
FILE NAME: i.stomate_npp.f90
PROGRAM NAME: stomate_npp
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! Npp: Maintenance and growth respiration
2: ! We calculte first the maintenance rspiration. This is substracted from the
3: ! allocatable biomass (and from the present biomass if the GPP is too low).
4: ! Of the rest, a part is lost as growth respiration, while the other part is
5: ! effectively allocated.
6: !
7: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_npp.f90,v 1.10 2007/05/28 14:49:02 ssipsl Exp $
8: ! IPSL (2006)
9: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
10: !
11: MODULE stomate_npp
12:
13: ! modules used:
14:
15: USE ioipsl
16: USE stomate_constants
17: USE stomate_natagritot
18:
19: IMPLICIT NONE
20:
21: ! private & public routines
22:
23: PRIVATE
24: PUBLIC npp_calc,npp_calc_clear
25:
26: ! first call
27: LOGICAL, SAVE :: firstcall = .TRUE.
28:
29: CONTAINS
30:
31: SUBROUTINE npp_calc_clear
32: firstcall=.TRUE.
33: END SUBROUTINE npp_calc_clear
34:
35: SUBROUTINE npp_calc (npts, dt, space_nat, &
36: PFTpresent, &
37: tlong_ref, t2m, tsoil, lai, rprof, &
38: gpp, f_alloc, resp_maint_part,&
39: biomass, leaf_age, leaf_frac, age, &
40: resp_maint, resp_growth, npp)
41:
42: !
43: ! 0 declarations
44: !
45:
46: ! 0.1 input
47:
48: ! Domain size
49: INTEGER(i_std), INTENT(in) :: npts
50: ! time step (days)
51: REAL(r_std), INTENT(in) :: dt
52: ! fraction of total space that is natural
53: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
54: ! PFT exists
55: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
56: ! long term annual mean 2 meter reference temperature
57: REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
58: ! 2 meter temperature
59: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m
60: ! soil temperature (K)
61: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil
62: ! leaf area index
63: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
64: ! root depth (m)
65: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: rprof
66: ! gross primary productivity (gC/days/(m**2 of natural/agricultural ground))
67: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gpp
68: ! fraction that goes into plant part
69: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: f_alloc
70: ! maintenance respiration of different plant parts (gC/day/m**2 of nat/agri ground)
71: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: resp_maint_part
72:
73: ! 0.2 modified fields
74:
75: ! biomass (gC/(m**2 of natural/agricultural ground))
76: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
77: ! leaf age (days)
78: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
79: ! fraction of leaves in leaf age class
80: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
81: ! age (years)
82: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
83:
84: ! 0.3 output
85:
86: ! maintenance respiration (gC/day/m**2 of total ground)
87: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: resp_maint
88: ! autotrophic respiration (gC/day/m**2 of total ground)
89: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: resp_growth
90: ! net primary productivity (gC/day/m**2 of natural/agricultural ground)
91: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: npp
92:
93: ! 0.4 local
94:
95: ! maximum fraction of allocatable biomass used for maintenance respiration
96: REAL(r_std), PARAMETER :: tax_max = 0.8
97: ! soil levels (m)
98: REAL(r_std), SAVE, DIMENSION(0:nbdl) :: z_soil
99: ! root temperature (convolution of root and soil temperature profiles)
100: REAL(r_std), DIMENSION(npts,npft) :: t_root
101: ! maintenance respiration coefficients at 0 deg C (g/g d**-1)
102: REAL(r_std), DIMENSION(npts,npft,nparts) :: coeff_maint
103: ! temperature which is pertinent for maintenance respiration (K)
104: REAL(r_std), DIMENSION(npts,nparts) :: t_maint
105: ! integration constant for root profile
106: REAL(r_std), DIMENSION(npts) :: rpc
107: ! long term annual mean temperature, C
108: REAL(r_std), DIMENSION(npts) :: tl
109: ! slope of maintenance respiration coefficient (1/K)
110: REAL(r_std), DIMENSION(npts) :: slope
111: ! growth respiration of different plant parts (gC/day/m**2 of nat/agri ground)
112: REAL(r_std), DIMENSION(npts,nparts) :: resp_growth_part
113: ! allocatable biomass (gC/m**2 of nat/agri ground) for the whole plant
114: REAL(r_std), DIMENSION(npts,npft) :: bm_alloc_tot
115: ! biomass increase, i.e. NPP per plant part
116: REAL(r_std), DIMENSION(npts,npft,nparts) :: bm_alloc
117: ! biomass increase
118: REAL(r_std), DIMENSION(npts) :: bm_add
119: ! new biomass
120: REAL(r_std), DIMENSION(npts) :: bm_new
121: ! leaf mass in youngest age class (gC/m**2 of nat/agri ground)
122: REAL(r_std), DIMENSION(npts,npft) :: leaf_mass_young
123: ! leaf mass after maintenance respiration
124: REAL(r_std), DIMENSION(npts,npft) :: lm_old
125: ! biomass created when biomass<0 because of dark respiration (gC/m**2 of nat/agri ground)
126: REAL(r_std), DIMENSION(npts,npft) :: bm_create
127: ! maximum part of allocatable biomass used for respiration
128: REAL(r_std), DIMENSION(npts) :: bm_tax_max
129: ! biomass that remains to be taken away
130: REAL(r_std), DIMENSION(npts) :: bm_pump
131: ! Index
132: INTEGER(i_std) :: i,j,k,l,m
133:
134: ! =========================================================================
135:
136: IF (bavard.GE.3) WRITE(numout,*) 'Entering npp'
137: !
138: ! 1 Initializations
139: !
140:
141: !
142: ! 1.1 first call
143: !
144:
145: IF ( firstcall ) THEN
146:
147: ! 1.1.1 soil levels
148:
149: z_soil(0) = 0.
150: V====== z_soil(1:nbdl) = diaglev(1:nbdl)
151:
152: ! 1.1.2 messages
153:
154: WRITE(numout,*) 'npp:'
155:
156: WRITE(numout,*) ' > max. fraction of allocatable biomass used for'// &
157: ' maint. resp.:', tax_max
158:
159: firstcall = .FALSE.
160:
161: ENDIF
162:
163: !
164: ! 1.2 set output to zero
165: !
166:
167: *W-----> resp_maint(:,:) = 0.0
168: || resp_growth(:,:) = 0.0
169: *W----- npp(:,:) = 0.0
170:
171: !
172: ! 1.3 root temperature: convolution of root and temperature profiles
173: ! suppose exponential root profile.
174: !
175:
176: +------> DO j = 1, npft
177: |
178: | ! 1.3.1 rpc is an integration constant such that the integral of the root profile is 1.
179: |V-----> rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / rprof(:,j) ) )
180: ||
181: || ! 1.3.2 integrate over the nbdl levels
182: ||
183: |V----- t_root(:,j) = 0.0
184: |
185: |+-----> DO l = 1, nbdl
186: ||
187: ||V==== t_root(:,j) = &
188: || t_root(:,j) + tsoil(:,l) * rpc(:) * &
189: || ( EXP( -z_soil(l-1)/rprof(:,j) ) - EXP( -z_soil(l)/rprof(:,j) ) )
190: ||
191: |+----- ENDDO
192: |
193: +------ ENDDO
194:
195: !
196: ! 1.4 total allocatable biomass
197: !
198:
199: +V===== bm_alloc_tot(:,:) = gpp(:,:) * dt
200:
201: !
202: ! 2 define maintenance respiration coefficients
203: !
204:
205: +------> DO j = 1, npft
206: |
207: | !
208: | ! 2.1 temperature which is taken for the plant part we are talking about
209: | !
210: |
211: | ! 2.1.1 parts above the ground
212: |
213: |V-----> t_maint(:,ileaf) = t2m(:)
214: || t_maint(:,isapabove) = t2m(:)
215: || t_maint(:,ifruit) = t2m(:)
216: ||
217: || ! 2.1.2 parts below the ground
218: ||
219: || t_maint(:,isapbelow) = t_root(:,j)
220: || t_maint(:,iroot) = t_root(:,j)
221: ||
222: || ! 2.1.3 heartwood: does not respire. Any temperature
223: ||
224: || t_maint(:,iheartbelow) = t_root(:,j)
225: |V----- t_maint(:,iheartabove) = t2m(:)
226: |
227: | ! 2.1.4 reserve: above the ground for trees, below for grasses
228: |
229: | IF ( tree(j) ) THEN
230: |V===== t_maint(:,icarbres) = t2m(:)
231: | ELSE
232: |V===== t_maint(:,icarbres) = t_root(:,j)
233: | ENDIF
234: |
235: | !
236: | ! 2.2 calculate coefficient
237: | !
238: |
239: |V-----> tl(:) = tlong_ref(:) - ZeroCelsius
240: |V----- slope(:) = maint_resp_slope(j,1) + tl(:) * maint_resp_slope(j,2) + &
241: | tl(:)*tl(:) * maint_resp_slope(j,3)
242: |
243: |+-----> DO k = 1, nparts
244: ||
245: ||V==== coeff_maint(:,j,k) = &
246: || MAX( coeff_maint_zero(j,k) * &
247: || ( 1. + slope(:) * (t_maint(:,k)-ZeroCelsius) ), 0._r_std )
248: ||
249: |+----- ENDDO
250: |
251: +------ ENDDO
252:
253: !
254: ! 3 calculate maintenance and growth respiration.
255: ! NPP = GPP - maintenance resp - growth resp.
256: !
257:
258: +------> DO j = 1, npft
259: |
260: | !
261: | ! 3.1 maintenance respiration of the different plant parts
262: | !
263: | !
264: | ! 3.2 Total maintenance respiration of the plant
265: | ! VPP killer:
266: | ! resp_maint(:,j) = SUM( resp_maint_part(:,:), DIM=2 )
267: | !
268: |
269: |V===== resp_maint(:,j) = 0.0
270: |
271: | !with the new calculation of hourly respiration, we must verify that PFT as not been killed after calcul of resp_maint_part in stomate
272: |+-----> DO k= 1, nparts
273: ||V----> WHERE (PFTpresent(:,j))
274: ||V---- resp_maint(:,j) = resp_maint(:,j) + resp_maint_part(:,j,k)
275: || ENDWHERE
276: |+----- ENDDO
277: | !
278: | ! 3.3 This maintenance respiration is taken away from the newly produced
279: | ! allocatable biomass. However, we avoid that no allocatable biomass remains.
280: | ! If the respiration is larger than a given fraction of the allocatable biomass,
281: | ! the rest is taken from the tissues themselves.
282: | ! We suppose that respiration is not dependent on leaf age ->
283: | ! do not change age structure.
284: | !
285: |
286: | ! maximum part of allocatable biomass used for respiration
287: |V===== bm_tax_max(:) = tax_max * bm_alloc_tot(:,j)
288: |
289: |V-----> DO i = 1, npts
290: ||
291: || IF ( ( bm_alloc_tot(i,j) .GT. 0.0 ) .AND. &
292: || ( ( resp_maint(i,j) * dt ) .LT. bm_tax_max(i) ) ) THEN
293: ||
294: || bm_alloc_tot(i,j) = bm_alloc_tot(i,j) - resp_maint(i,j) * dt
295: ||
296: || ELSEIF ( resp_maint(i,j) .GT. 0.0 ) THEN
297: ||
298: || ! remaining allocatable biomass
299: || bm_alloc_tot(i,j) = bm_alloc_tot(i,j) - bm_tax_max(i)
300: ||
301: || ! biomass that remains to be taken away from tissues
302: || bm_pump(i) = resp_maint(i,j) * dt - bm_tax_max(i)
303: ||
304: || ! take biomass from tissues
305: ||
306: || biomass(i,j,ileaf) = biomass(i,j,ileaf) - &
307: || bm_pump(i) * resp_maint_part(i,j,ileaf) / resp_maint(i,j)
308: || biomass(i,j,isapabove) = biomass(i,j,isapabove) - &
309: || bm_pump(i) * resp_maint_part(i,j,isapabove) / resp_maint(i,j)
310: || biomass(i,j,isapbelow) = biomass(i,j,isapbelow) - &
311: || bm_pump(i) * resp_maint_part(i,j,isapbelow) / resp_maint(i,j)
312: || biomass(i,j,iroot) = biomass(i,j,iroot) - &
313: || bm_pump(i) * resp_maint_part(i,j,iroot) / resp_maint(i,j)
314: || biomass(i,j,ifruit) = biomass(i,j,ifruit) - &
315: || bm_pump(i) * resp_maint_part(i,j,ifruit) / resp_maint(i,j)
316: || biomass(i,j,icarbres) = biomass(i,j,icarbres) - &
317: || bm_pump(i) * resp_maint_part(i,j,icarbres) / resp_maint(i,j)
318: ||
319: || ENDIF
320: ||
321: |V----- ENDDO ! Fortran95: WHERE - ELSEWHERE construct
322: |
323: | !
324: | ! 3.4 dispatch allocatable biomass
325: | !
326: |
327: |+-----> DO k = 1, nparts
328: ||V==== bm_alloc(:,j,k) = f_alloc(:,j,k) * bm_alloc_tot(:,j)
329: |+----- ENDDO
330: |
331: | !
332: | ! 3.5 growth respiration of a plant part is a given fraction of the
333: | ! remaining allocatable biomass.
334: | !
335: |
336: |*V----> resp_growth_part(:,:) = frac_growthresp * bm_alloc(:,j,:) / dt
337: |||
338: |*V---- bm_alloc(:,j,:) = ( 1. - frac_growthresp ) * bm_alloc(:,j,:)
339: |
340: | !
341: | ! 3.6 Total growth respiration of the plant
342: | ! VPP killer:
343: | ! resp_growth(:,j) = SUM( resp_growth_part(:,:), DIM=2 )
344: | !
345: |
346: |V===== resp_growth(:,j) = 0.0
347: |
348: |+-----> DO k = 1, nparts
349: ||V==== resp_growth(:,j) = resp_growth(:,j) + resp_growth_part(:,k)
350: |+----- ENDDO
351: |
352: +------ ENDDO
353:
354: !
355: ! 4 update the biomass, but save the old leaf mass for later
356: ! "old" leaf mass is leaf mass after maintenance respiration
357: !
358:
359: +V===== lm_old(:,:) = biomass(:,:,ileaf)
360:
361: ++V==== biomass(:,:,:) = biomass(:,:,:) + bm_alloc(:,:,:)
362:
363: !
364: ! 5 biomass can become negative in some rare cases, as the GPP can be negative
365: ! (dark respiration).
366: ! In this case, set biomass to some small value. This creation of matter is taken into
367: ! account by decreasing the autotrophic respiration. In this case, maintenance respiration
368: ! can become negative !!!
369: !
370:
371: +------> DO k = 1, nparts
372: |
373: |*V----> WHERE ( biomass(:,:,k) .LT. 0.0 )
374: |||
375: ||| bm_create(:,:) = min_stomate - biomass(:,:,k)
376: |||
377: ||| biomass(:,:,k) = biomass(:,:,k) + bm_create(:,:)
378: |||
379: |*V---- resp_maint(:,:) = resp_maint(:,:) - bm_create(:,:) / dt
380: |
381: | ENDWHERE
382: |
383: +------ ENDDO
384:
385: !
386: ! 6 Calculate the NPP (gC/(m**2 of nat/agri ground/day)
387: !
388:
389: W+===== npp(:,:) = gpp(:,:) - resp_growth(:,:) - resp_maint(:,:)
390:
391: !
392: ! 7 transform respiration from gC/(m**2 of nat/agri ground)/day) into
393: ! gC/(m**2 of total ground)/day), as it goes into the atmosphere.
394: !
395:
396: CALL natagritot (npts, ito_total, space_nat, resp_maint)
397: CALL natagritot (npts, ito_total, space_nat, resp_growth)
398:
399: !
400: ! 8 leaf age
401: !
402:
403: !
404: ! 8.1 Decrease leaf age in youngest class if new leaf biomass is higher than old one.
405: !
406:
407: +V===== leaf_mass_young(:,:) = leaf_frac(:,:,1) * lm_old(:,:) + bm_alloc(:,:,ileaf)
408:
409: *V-----> WHERE ( ( bm_alloc(:,:,ileaf) .GT. 0.0 ) .AND. &
410: || ( leaf_mass_young(:,:) .GT. 0.0 ) )
411: ||
412: *V----- leaf_age(:,:,1) = leaf_age(:,:,1) * ( leaf_mass_young(:,:) - bm_alloc(:,:,ileaf) ) / &
413: leaf_mass_young(:,:)
414:
415: ENDWHERE
416:
417: !
418: ! 8.2 new age class fractions (fraction in youngest class increases)
419: !
420:
421: ! 8.2.1 youngest class: new mass in youngest class divided by total new mass
422:
423: *V-----> WHERE ( biomass(:,:,ileaf) .GT. min_stomate )
424: ||
425: *V----- leaf_frac(:,:,1) = leaf_mass_young(:,:) / biomass(:,:,ileaf)
426:
427: ENDWHERE
428:
429: ! 8.2.2 other classes: old mass in leaf age class divided by new mass
430:
431: *------> DO m = 2, nleafages
432: |
433: |*V----> WHERE ( biomass(:,:,ileaf) .GT. min_stomate )
434: |||
435: |*V---- leaf_frac(:,:,m) = leaf_frac(:,:,m) * lm_old(:,:) / biomass(:,:,ileaf)
436: |
437: | ENDWHERE
438: |
439: *------ ENDDO
440:
441: !
442: ! 9 Plant age (years)
443: !
444:
445: !
446: ! 9.1 Increase age at every time step
447: !
448:
449: *V-----> WHERE ( PFTpresent(:,:) )
450: ||
451: || age(:,:) = age(:,:) + dt/one_year
452: ||
453: || ELSEWHERE
454: ||
455: *V----- age(:,:) = 0.0
456:
457: ENDWHERE
458:
459: !
460: ! 9.2 For grasses, decrease age
461: ! if new biomass is higher than old one.
462: ! For trees, age is treated in "establish" if vegetation is dynamic,
463: ! and in turnover routines if it is static (in this case, only take
464: ! into account the age of the heartwood).
465: !
466:
467: +------> DO j = 1, npft
468: |
469: | IF ( .NOT. tree(j) ) THEN
470: |
471: | ! Only four compartments for grasses
472: | ! VPP killer:
473: | ! bm_new(:) = SUM( biomass(:,j,:), DIM=2 )
474: | ! bm_add(:) = SUM( bm_alloc(:,j,:), DIM=2 )
475: |
476: |V-----> bm_new(:) = biomass(:,j,ileaf) + biomass(:,j,isapabove) + &
477: || biomass(:,j,iroot) + biomass(:,j,ifruit)
478: |V----- bm_add(:) = bm_alloc(:,j,ileaf) + bm_alloc(:,j,isapabove) + &
479: | bm_alloc(:,j,iroot) + bm_alloc(:,j,ifruit)
480: |
481: |V-----> WHERE ( ( bm_new(:) .GT. 0.0 ) .AND. ( bm_add(:) .GT. 0.0 ) )
482: |V----- age(:,j) = age(:,j) * ( bm_new(:) - bm_add(:) ) / bm_new(:)
483: | ENDWHERE
484: |
485: | ENDIF
486: |
487: +------ ENDDO
488:
489: !
490: ! 10 history
491: !
492:
493: CALL histwrite (hist_id_stomate, 'BM_ALLOC_LEAF', itime, &
494: bm_alloc(:,:,ileaf), npts*npft, horipft_index)
495: CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_AB', itime, &
496: bm_alloc(:,:,isapabove), npts*npft, horipft_index)
497: CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_BE', itime, &
498: bm_alloc(:,:,isapbelow), npts*npft, horipft_index)
499: CALL histwrite (hist_id_stomate, 'BM_ALLOC_ROOT', itime, &
500: bm_alloc(:,:,iroot), npts*npft, horipft_index)
501: CALL histwrite (hist_id_stomate, 'BM_ALLOC_FRUIT', itime, &
502: bm_alloc(:,:,ifruit), npts*npft, horipft_index)
503: CALL histwrite (hist_id_stomate, 'BM_ALLOC_RES', itime, &
504: bm_alloc(:,:,icarbres), npts*npft, horipft_index)
505:
506: IF (bavard.GE.4) WRITE(numout,*) 'Leaving npp'
507:
508: END SUBROUTINE npp_calc
509:
510: END MODULE stomate_npp
ORCHIDEE/src_stomate/i.stomate_phenology.L 0000754 0103600 0005670 00000171440 11164403473 020363 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:35 2008
FILE NAME: i.stomate_phenology.f90
PROGRAM NAME: stomate_phenology
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
166 vec ( 3): Unvectorized loop.
166 vec ( 13): Overhead of loop division is too large.
168 opt (1592): Outer loop unrolled inside inner loop.
168 vec ( 4): Vectorized array expression.
182 vec ( 4): Vectorized array expression.
189 opt (1592): Outer loop unrolled inside inner loop.
193 vec ( 3): Unvectorized loop.
199 vec ( 10): Vectorization obstructive procedure reference.:pheno_hum
206 vec ( 10): Vectorization obstructive procedure reference.:pheno_moi
214 vec ( 10): Vectorization obstructive procedure reference.:pheno_ncdgdd
220 vec ( 10): Vectorization obstructive procedure reference.:pheno_ngd
225 vec ( 10): Vectorization obstructive procedure reference.:pheno_humgdd
233 vec ( 10): Vectorization obstructive procedure reference.:pheno_moigdd
248 vec ( 9): Vectorization obstructive statement.
261 vec ( 4): Vectorized array expression.
263 vec ( 1): Vectorized loop.
338 opt (1082): Backward transfers inhibit loop optimization.
338 vec ( 4): Vectorized array expression.
342 vec ( 4): Vectorized array expression.
342 vec ( 4): Vectorized array expression.
342 vec ( 4): Vectorized array expression.
350 vec ( 4): Vectorized array expression.
350 vec ( 4): Vectorized array expression.
350 vec ( 4): Vectorized array expression.
350 vec ( 4): Vectorized array expression.
360 warn ( 83): Dummy argument "lai" is not used.
360 warn ( 83): Dummy argument "gpp" is not used.
360 warn ( 83): Dummy argument "senescence" is not used.
440 vec ( 4): Vectorized array expression.
469 vec ( 1): Vectorized loop.
572 vec ( 4): Vectorized array expression.
601 vec ( 1): Vectorized loop.
721 vec ( 4): Vectorized array expression.
727 vec ( 6): Unvectorized array expression.
727 vec ( 7): Iteration count is too small.
759 vec ( 1): Vectorized loop.
883 vec ( 4): Vectorized array expression.
889 vec ( 6): Unvectorized array expression.
889 vec ( 7): Iteration count is too small.
921 vec ( 1): Vectorized loop.
1009 vec ( 4): Vectorized array expression.
1027 vec ( 1): Vectorized loop.
1105 vec ( 4): Vectorized array expression.
1123 vec ( 1): Vectorized loop.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:35 2008
FILE NAME: i.stomate_phenology.f90
PROGRAM NAME: stomate_phenology
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! Phenology
2: !
3: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_phenology.f90,v 1.9 2007/05/28 14:49:02 ssipsl Exp $
4: ! IPSL (2006)
5: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
6: !
7: MODULE stomate_phenology
8:
9: ! modules used:
10:
11: USE ioipsl
12: USE stomate_constants
13:
14: IMPLICIT NONE
15:
16: ! private & public routines
17:
18: PRIVATE
19: PUBLIC phenology,phenology_clear
20:
21: ! first call
22: LOGICAL, SAVE :: firstcall = .TRUE.
23: LOGICAL, SAVE :: firstcall_hum = .TRUE.
24: LOGICAL, SAVE :: firstcall_moi = .TRUE.
25: LOGICAL, SAVE :: firstcall_humgdd = .TRUE.
26: LOGICAL, SAVE :: firstcall_moigdd = .TRUE.
27:
28: CONTAINS
29:
30: SUBROUTINE phenology_clear
31: firstcall=.TRUE.
32: firstcall_hum=.TRUE.
33: firstcall_moi = .TRUE.
34: firstcall_humgdd = .TRUE.
35: firstcall_moigdd = .TRUE.
36: END SUBROUTINE phenology_clear
37:
38: SUBROUTINE phenology (npts, dt, PFTpresent, &
39: veget_max, space_nat, &
40: tlong_ref, t2m_month, t2m_week, gpp, &
41: maxmoiavail_lastyear, minmoiavail_lastyear, &
42: moiavail_month, moiavail_week, &
43: gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
44: senescence, time_lowgpp, time_hum_min, &
45: biomass, leaf_frac, leaf_age, &
46: when_growthinit, co2_to_bm, lai)
47:
48: !
49: ! 0 declarations
50: !
51:
52: ! 0.1 input
53:
54: ! Domain size
55: INTEGER(i_std), INTENT(in) :: npts
56: ! time step in days
57: REAL(r_std), INTENT(in) :: dt
58: ! PFT exists
59: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
60: ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
61: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
62: ! total natural space (fraction of total space)
63: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
64: ! "long term" 2 meter reference temperatures (K)
65: REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
66: ! "monthly" 2-meter temperatures (K)
67: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
68: ! "weekly" 2-meter temperatures (K)
69: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
70: ! daily gross primary productivity (gC/(m**2 of nat/agri ground)/day)
71: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gpp
72: ! last year's maximum moisture availability
73: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
74: ! last year's minimum moisture availability
75: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
76: ! "monthly" moisture availability
77: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
78: ! "weekly" moisture availability
79: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
80: ! growing degree days, threshold -5 deg C
81: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gdd_m5_dormance
82: ! growing degree days, since midwinter
83: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_midwinter
84: ! number of chilling days since leaves were lost
85: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ncd_dormance
86: ! number of growing days, threshold -5 deg C
87: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ngd_minus5
88: ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
89: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: senescence
90: ! duration of dormance (d)
91: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_lowgpp
92: ! time elapsed since strongest moisture availability (d)
93: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_hum_min
94:
95: ! 0.2 modified fields
96:
97: ! biomass (gC/(m**2 of natural or agricultural ground))
98: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
99: ! fraction of leaves in leaf age class
100: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
101: ! leaf age (days)
102: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
103: ! how many days ago was the beginning of the growing season
104: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
105: ! co2 taken up (gC/(m**2 of total ground)/day)
106: REAL(r_std), DIMENSION(npts), INTENT(inout) :: co2_to_bm
107:
108: ! 0.3 output
109:
110: ! leaf area index
111: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
112:
113: ! 0.4 local
114:
115: ! take carbon from atmosphere if carbohydrate reserve too small?
116: LOGICAL, PARAMETER :: always_init = .FALSE.
117: ! minimum time (d) since last beginning of a growing season
118: REAL(r_std), PARAMETER :: min_growthinit_time = 300.
119: ! are we allowed to decalre the beginning of the growing season?
120: LOGICAL, DIMENSION(npts,npft) :: allow_initpheno
121: ! biomass we would like to have
122: REAL(r_std), DIMENSION(npts) :: bm_wanted
123: ! biomass we use (from carbohydrate reserve or from atmosphere)
124: REAL(r_std), DIMENSION(npts) :: bm_use
125: ! minimum leaf mass (gC/(m**2 of natural or agricultural ground))
126: REAL(r_std), DIMENSION(npts) :: lm_min
127: ! does the leaf age distribution have to be reset?
128: LOGICAL(r_std), DIMENSION(npts) :: age_reset
129: ! indices
130: INTEGER(i_std) :: i,j,m
131: ! signal to start putting leaves on
132: LOGICAL, DIMENSION(npts,npft) :: begin_leaves
133:
134: ! =========================================================================
135:
136: IF (bavard.GE.3) WRITE(numout,*) 'Entering phenology'
137:
138: !
139: ! 1 first call
140: !
141:
142: IF ( firstcall ) THEN
143:
144: WRITE(numout,*) 'phenology:'
145:
146: WRITE(numout,*) ' > take carbon from atmosphere if carbohydrate' // &
147: ' reserve too small: ', always_init
148:
149: WRITE(numout,*) ' > minimum time since last beginning of a growing' // &
150: ' season (d): ', min_growthinit_time
151:
152: firstcall = .FALSE.
153:
154: ENDIF
155:
156: !
157: ! 2 various things
158: !
159:
160: !
161: ! 2.1 allow detection of the beginning of the growing season if dormance was
162: ! long enough and last beginning of growing season was a sufficiently
163: ! long time ago
164: !
165:
166: +------> DO j = 1, npft
167: |
168: |V-----> WHERE ( ( time_lowgpp(:,j) .GE. pheno_crit%lowgpp_time(j) ) .AND. &
169: || ( when_growthinit(:,j) .GT. min_growthinit_time ) )
170: || allow_initpheno(:,j) = .TRUE.
171: || ELSEWHERE
172: |V----- allow_initpheno(:,j) = .FALSE.
173: | ENDWHERE
174: |
175: +------ ENDDO
176:
177: !
178: ! 2.2 increase counter: how many days ago was the beginning of the growing season
179: ! Needed for allocation
180: !
181:
182: *V-----> when_growthinit(:,:) = when_growthinit(:,:) + dt
183: ||
184: || !
185: || ! 3 Check biometeorological conditions
186: || !
187: ||
188: || ! default: phenology does not start
189: *V----- begin_leaves(:,:) = .FALSE.
190:
191: ! different kinds of phenology
192:
193: +------> DO j = 1, npft
194: |
195: | SELECT CASE ( pheno_crit%pheno_model(j) )
196: |
197: | CASE ( 'hum' )
198: |
199: | CALL pheno_hum (npts, j, PFTpresent, allow_initpheno, &
200: | moiavail_month, moiavail_week, &
201: | maxmoiavail_lastyear, minmoiavail_lastyear, &
202: | begin_leaves)
203: |
204: | CASE ( 'moi' )
205: |
206: | CALL pheno_moi (npts, j, PFTpresent, allow_initpheno, &
207: | time_hum_min, &
208: | moiavail_month, moiavail_week, &
209: | begin_leaves)
210: |
211: |
212: | CASE ( 'ncdgdd' )
213: |
214: | CALL pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
215: | ncd_dormance, gdd_midwinter, &
216: | t2m_month, t2m_week, begin_leaves)
217: |
218: | CASE ( 'ngd' )
219: |
220: | CALL pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd_minus5, &
221: | t2m_month, t2m_week, begin_leaves)
222: |
223: | CASE ( 'humgdd' )
224: |
225: | CALL pheno_humgdd (npts, j, PFTpresent, allow_initpheno, gdd_m5_dormance, &
226: | maxmoiavail_lastyear, minmoiavail_lastyear, &
227: | tlong_ref, t2m_month, t2m_week, &
228: | moiavail_week, moiavail_month, &
229: | begin_leaves)
230: |
231: | CASE ( 'moigdd' )
232: |
233: | CALL pheno_moigdd (npts, j, PFTpresent, allow_initpheno, gdd_m5_dormance, &
234: | time_hum_min, &
235: | tlong_ref, t2m_month, t2m_week, &
236: | moiavail_week, moiavail_month, &
237: | begin_leaves)
238: |
239: | CASE ( 'none' )
240: |
241: | ! no action
242: |
243: | CASE default
244: |
245: | WRITE(numout,*) 'phenology: don''t know how to treat this PFT.'
246: | WRITE(numout,*) ' number:',j
247: | WRITE(numout,*) ' phenology model: ',pheno_crit%pheno_model(j)
248: | STOP
249: |
250: | END SELECT
251: |
252: +------ ENDDO
253:
254: !
255: ! 4 leaves start to grow if meteorological conditions are favourable and if
256: ! leaf regrowth is allowed (cf also turnover)
257: !
258:
259: +------> DO j = 1, npft
260: |
261: |V===== age_reset(:) = .FALSE.
262: |
263: |V-----> DO i = 1, npts
264: ||
265: || IF ( begin_leaves(i,j) ) THEN
266: ||
267: || lm_min(i) = veget_max(i,j) * pheno_crit%lai_initmin(j) / sla(j)
268: ||
269: || ! do we have to put a minimum biomass into the leaves?
270: ||
271: || IF ( biomass(i,j,ileaf) .LT. lm_min(i) ) THEN
272: ||
273: || !
274: || ! 4.1 determine how much biomass we can use
275: || !
276: ||
277: || bm_wanted(i) = 2. * lm_min(i)
278: ||
279: || ! eventually take the missing carbon from the atmosphere and
280: || ! put it into carbohydrate reserve
281: ||
282: || IF ( always_init .AND. ( biomass(i,j,icarbres) .LT. bm_wanted(i) ) ) THEN
283: ||
284: || IF ( natural(j) ) THEN
285: || co2_to_bm(i) = co2_to_bm(i) + &
286: || ( bm_wanted(i) - biomass(i,j,icarbres) ) * space_nat(i) / dt
287: || ELSE
288: || co2_to_bm(i) = co2_to_bm(i) + &
289: || ( bm_wanted(i) - biomass(i,j,icarbres) ) * ( 1. - space_nat(i) ) / dt
290: || ENDIF
291: ||
292: || biomass(i,j,icarbres) = bm_wanted(i)
293: ||
294: || ENDIF
295: ||
296: || bm_use(i) = MIN( biomass(i,j,icarbres), bm_wanted(i) )
297: ||
298: || !
299: || ! 4.2 dispatch that biomass on leaves and roots
300: || !
301: ||
302: || biomass(i,j,ileaf) = biomass(i,j,ileaf) + bm_use(i) / 2.
303: ||
304: || biomass(i,j,iroot) = biomass(i,j,iroot) + bm_use(i) / 2.
305: ||
306: || !
307: || ! 4.3 decrease reservoir biomass
308: || !
309: ||
310: || biomass(i,j,icarbres) = biomass(i,j,icarbres) - bm_use(i)
311: ||
312: || !
313: || ! 4.4 decide whether we have to reset then leaf age distribution
314: || ! (done later for better vectorization)
315: || !
316: ||
317: || age_reset(i) = .TRUE.
318: ||
319: || ENDIF ! leaf mass is very low
320: ||
321: || !
322: || ! 4.5 reset counter: start of the growing season
323: || !
324: ||
325: || when_growthinit(i,j) = 0.0
326: ||
327: || ENDIF ! start of the growing season
328: ||
329: |V----- ENDDO ! loop over grid points
330: |
331: | !
332: | ! 4.6 reset leaf age distribution where necessary
333: | ! simply say that everything is in the youngest age class
334: | !
335: |
336: | ! 4.6.1 fractions
337: |
338: |V-----> WHERE ( age_reset(:) )
339: |V----- leaf_frac(:,j,1) = 1.0
340: | ENDWHERE
341: |*-----> DO m = 2, nleafages
342: ||V----> WHERE ( age_reset(:) )
343: ||V---- leaf_frac(:,j,m) = 0.0
344: || ENDWHERE
345: |*----- ENDDO
346: |
347: | ! 4.6.2 ages
348: |
349: |*-----> DO m = 1, nleafages
350: ||V----> WHERE ( age_reset(:) )
351: ||V---- leaf_age(:,j,m) = 0.0
352: || ENDWHERE
353: |*----- ENDDO
354: |
355: +------ ENDDO ! loop over PFTs
356:
357:
358: IF (bavard.GE.4) WRITE(numout,*) 'Leaving phenology'
359:
360: END SUBROUTINE phenology
361:
362: !
363: ! ==============================================================================
364: ! Phenology: begins if "weekly" soil humidity starts to exceed a certain threshold
365: ! value. This value depends on last year's max and min humidity ...
366: ! Always initiate growing season if soil moisture exceeds a certain threshold.
367: !
368:
369: SUBROUTINE pheno_hum (npts, j, PFTpresent, allow_initpheno, &
370: moiavail_month, moiavail_week, &
371: maxmoiavail_lastyear, minmoiavail_lastyear, &
372: begin_leaves)
373:
374: !
375: ! 0 declarations
376: !
377:
378: ! 0.1 input
379:
380: ! Domain size
381: INTEGER(i_std), INTENT(in) :: npts
382: ! PFT index
383: INTEGER(i_std), INTENT(in) :: j
384: ! PFT exists
385: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
386: ! are we allowed to decalre the beginning of the growing season?
387: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
388: ! "monthly" moisture availability
389: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
390: ! "weekly" moisture availability
391: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
392: ! last year's maximum moisture availability
393: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
394: ! last year's minimum moisture availability
395: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
396:
397: ! 0.2 output
398:
399: ! signal to start putting leaves on
400: LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
401:
402: ! 0.3 local
403:
404: ! moisture availability above which moisture tendency doesn't matter
405: REAL(r_std), PARAMETER :: moiavail_always_tree = 1.0
406: REAL(r_std), PARAMETER :: moiavail_always_grass = 0.6
407: REAL(r_std) :: moiavail_always
408: ! first call
409: REAL(r_std), DIMENSION(npts) :: availability_crit
410: ! index
411: INTEGER(i_std) :: i
412:
413: ! =========================================================================
414:
415: IF (bavard.GE.3) WRITE(numout,*) 'Entering hum'
416:
417: !
418: ! Initializations
419: !
420:
421: !
422: ! 1.1 messages
423: !
424:
425: IF ( firstcall_hum ) THEN
426:
427: WRITE(numout,*) 'pheno_hum:'
428: WRITE(numout,*) ' > moisture availability above which moisture tendency doesn''t matter: '
429: WRITE(numout,*) ' trees:', moiavail_always_tree
430: WRITE(numout,*) ' grasses:', moiavail_always_grass
431:
432: firstcall_hum = .FALSE.
433:
434: ENDIF
435:
436: !
437: ! 1.2 initialize output
438: !
439:
440: V====== begin_leaves(:,j) = .FALSE.
441:
442: !
443: ! 1.3 check the prescribed critical value
444: !
445:
446: IF ( pheno_crit%hum_frac(j) .EQ. undef ) THEN
447:
448: WRITE(numout,*) 'hum: pheno_crit%hum_frac is undefined for PFT',j
449: WRITE(numout,*) 'We stop.'
450: STOP
451:
452: ENDIF
453:
454: !
455: ! 1.4 critical moisture availability above which we always detect the beginning of the
456: ! growing season.
457: !
458:
459: IF ( tree(j) ) THEN
460: moiavail_always = moiavail_always_tree
461: ELSE
462: moiavail_always = moiavail_always_grass
463: ENDIF
464:
465: !
466: ! 2 PFT has to be there and start of growing season must be allowed
467: !
468:
469: V------> DO i = 1, npts
470: |
471: | IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
472: |
473: | ! critical availability: depends on last year's max and min.
474: |
475: | availability_crit(i) = minmoiavail_lastyear(i,j) + pheno_crit%hum_frac(j) * &
476: | ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
477: |
478: | ! the favorable season starts if the "monthly" moisture availability is still quite
479: | ! low, but the "weekly" availability is already higher (as it reacts faster).
480: | ! If monthly moisture availability is high enough, also initiate growing season if
481: | ! this has not happened yet.
482: |
483: | IF ( ( ( moiavail_week(i,j) .GE. availability_crit(i) ) .AND. &
484: | ( moiavail_month(i,j) .LT. moiavail_week(i,j) ) ) .OR. &
485: | ( moiavail_month(i,j) .GE. moiavail_always ) ) THEN
486: | begin_leaves(i,j) = .TRUE.
487: | ENDIF
488: |
489: | ENDIF ! PFT there and start of growing season allowed
490: |
491: V------ ENDDO
492:
493: IF (bavard.GE.4) WRITE(numout,*) 'Leaving hum'
494:
495: END SUBROUTINE pheno_hum
496:
497: !
498: ! ==============================================================================
499: ! Phenology: begins if moisture minium was a sufficiently long time ago.
500: ! Additionally, "weekly" soil humidity must be higher that "monthly" soil
501: ! humidity.
502: !
503:
504: SUBROUTINE pheno_moi (npts, j, PFTpresent, allow_initpheno, &
505: time_hum_min, &
506: moiavail_month, moiavail_week, &
507: begin_leaves)
508:
509: !
510: ! 0 declarations
511: !
512:
513: ! 0.1 input
514:
515: ! Domain size
516: INTEGER(i_std), INTENT(in) :: npts
517: ! PFT index
518: INTEGER(i_std), INTENT(in) :: j
519: ! PFT exists
520: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
521: ! are we allowed to decalre the beginning of the growing season?
522: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
523: ! time elapsed since strongest moisture availability (d)
524: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_hum_min
525: ! "monthly" moisture availability
526: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
527: ! "weekly" moisture availability
528: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
529:
530: ! 0.2 output
531:
532: ! signal to start putting leaves on
533: LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
534:
535: ! 0.3 local
536:
537: ! moisture availability above which moisture tendency doesn't matter
538: ! moisture availability above which moisture tendency doesn't matter
539: REAL(r_std), PARAMETER :: moiavail_always_tree = 1.0
540: REAL(r_std), PARAMETER :: moiavail_always_grass = 0.6
541: REAL(r_std) :: moiavail_always
542: ! index
543: INTEGER(i_std) :: i
544:
545: ! =========================================================================
546:
547: IF (bavard.GE.3) WRITE(numout,*) 'Entering moi'
548:
549: !
550: ! Initializations
551: !
552:
553: !
554: ! 1.1 messages
555: !
556:
557: IF ( firstcall_moi ) THEN
558:
559: WRITE(numout,*) 'pheno_moi:'
560: WRITE(numout,*) ' > moisture availability above which moisture tendency doesn''t matter: '
561: WRITE(numout,*) ' trees:', moiavail_always_tree
562: WRITE(numout,*) ' grasses:', moiavail_always_grass
563:
564: firstcall_moi = .FALSE.
565:
566: ENDIF
567:
568: !
569: ! 1.2 initialize output
570: !
571:
572: V====== begin_leaves(:,j) = .FALSE.
573:
574: !
575: ! 1.3 check the prescribed critical value
576: !
577:
578: IF ( pheno_crit%hum_min_time(j) .EQ. undef ) THEN
579:
580: WRITE(numout,*) 'moi: pheno_crit%hum_min_time is undefined for PFT',j
581: WRITE(numout,*) 'We stop.'
582: STOP
583:
584: ENDIF
585:
586: !
587: ! 1.4 critical moisture availability above which we always detect the beginning of the
588: ! growing season.
589: !
590:
591: IF ( tree(j) ) THEN
592: moiavail_always = moiavail_always_tree
593: ELSE
594: moiavail_always = moiavail_always_grass
595: ENDIF
596:
597: !
598: ! 2 PFT has to be there and start of growing season must be allowed
599: !
600:
601: V------> DO i = 1, npts
602: |
603: | IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
604: |
605: | ! the favorable season starts if the moisture minimum was a sufficiently long
606: | ! time ago and if the "monthly" moisture availability is lower than the "weekly"
607: | ! availability (this means that soil moisture is increasing).
608: | ! If monthly moisture availability is high enough, also initiate growing season if
609: | ! this has not happened yet.
610: |
611: | IF ( ( ( moiavail_week(i,j) .GT. moiavail_month(i,j) ) .AND. &
612: | ( time_hum_min(i,j) .GT. pheno_crit%hum_min_time(j) ) ) .OR. &
613: | ( moiavail_month(i,j) .GE. moiavail_always ) ) THEN
614: | begin_leaves(i,j) = .TRUE.
615: | ENDIF
616: |
617: | ENDIF ! PFT there and start of growing season allowed
618: |
619: V------ ENDDO
620:
621: IF (bavard.GE.4) WRITE(numout,*) 'Leaving moi'
622:
623: END SUBROUTINE pheno_moi
624:
625: !
626: ! ==============================================================================
627: ! Phenology: leaves are put on if gdd exceeds a critical value.
628: ! Additionally, there has to be at least some moisture.
629: ! Set gdd to undef if beginning of the growing season detected.
630: !
631:
632: SUBROUTINE pheno_humgdd (npts, j, PFTpresent, allow_initpheno, gdd, &
633: maxmoiavail_lastyear, minmoiavail_lastyear, &
634: tlong_ref, t2m_month, t2m_week, &
635: moiavail_week, moiavail_month, &
636: begin_leaves)
637:
638: !
639: ! 0 declarations
640: !
641:
642: ! 0.1 input
643:
644: ! Domain size
645: INTEGER(i_std), INTENT(in) :: npts
646: ! PFT index
647: INTEGER(i_std), INTENT(in) :: j
648: ! PFT exists
649: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
650: ! are we allowed to decalre the beginning of the growing season?
651: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
652: ! growing degree days, calculated since leaves have fallen
653: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gdd
654: ! last year's maximum moisture availability
655: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
656: ! last year's minimum moisture availability
657: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
658: ! "long term" 2 meter temperatures (K)
659: REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
660: ! "monthly" 2-meter temperatures (K)
661: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
662: ! "weekly" 2-meter temperatures (K)
663: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
664: ! "weekly" moisture availability
665: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
666: ! "monthly" moisture availability
667: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
668:
669: ! 0.2 output
670:
671: ! signal to start putting leaves on
672: LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
673:
674: ! 0.3 local
675:
676: ! moisture availability above which moisture tendency doesn't matter
677: ! moisture availability above which moisture tendency doesn't matter
678: REAL(r_std), PARAMETER :: moiavail_always_tree = 1.0
679: REAL(r_std), PARAMETER :: moiavail_always_grass = 0.6
680: REAL(r_std) :: moiavail_always
681: ! monthly temp. above which temp. tendency doesn't matter
682: REAL(r_std), PARAMETER :: t_always = ZeroCelsius + 10.
683: ! critical moisture availability
684: REAL(r_std), DIMENSION(npts) :: moiavail_crit
685: ! long term temperature, C
686: REAL(r_std), DIMENSION(npts) :: tl
687: ! critical GDD
688: REAL(r_std), DIMENSION(npts) :: gdd_crit
689: ! index
690: INTEGER(i_std) :: i
691:
692: ! =========================================================================
693:
694: IF (bavard.GE.3) WRITE(numout,*) 'Entering humgdd'
695:
696: !
697: ! 1 Initializations
698: !
699:
700: !
701: ! 1.1 messages
702: !
703:
704: IF ( firstcall_humgdd ) THEN
705:
706: WRITE(numout,*) 'pheno_humgdd:'
707: WRITE(numout,*) ' > moisture availability above which moisture tendency doesn''t matter: '
708: WRITE(numout,*) ' trees:', moiavail_always_tree
709: WRITE(numout,*) ' grasses:', moiavail_always_grass
710: WRITE(numout,*) ' > monthly temp. above which temp. tendency doesn''t matter: ', &
711: t_always
712:
713: firstcall_humgdd = .FALSE.
714:
715: ENDIF
716:
717: !
718: ! 1.2 initialize output
719: !
720:
721: V====== begin_leaves(:,j) = .FALSE.
722:
723: !
724: ! 1.3 check the prescribed critical values
725: !
726:
727: *====== IF ( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) THEN
728:
729: WRITE(numout,*) 'humgdd: pheno_crit%gdd is undefined for PFT',j
730: WRITE(numout,*) 'We stop.'
731: STOP
732:
733: ENDIF
734:
735: IF ( pheno_crit%hum_frac(j) .EQ. undef ) THEN
736:
737: WRITE(numout,*) 'humgdd: pheno_crit%hum_frac is undefined for PFT',j
738: WRITE(numout,*) 'We stop.'
739: STOP
740:
741: ENDIF
742:
743: !
744: ! 1.4 critical moisture availability above which we always detect the beginning of the
745: ! growing season.
746: !
747:
748: IF ( tree(j) ) THEN
749: moiavail_always = moiavail_always_tree
750: ELSE
751: moiavail_always = moiavail_always_grass
752: ENDIF
753:
754: !
755: ! 2 PFT has to be there, start of growing season must be allowed,
756: ! and gdd has to be defined
757: !
758:
759: V------> DO i = 1, npts
760: |
761: | IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
762: | ( gdd(i,j) .NE. undef ) ) THEN
763: |
764: | ! is critical gdd reached and is temperature increasing?
765: | ! be sure that at least some humidity
766: |
767: | moiavail_crit(i) = minmoiavail_lastyear(i,j) + pheno_crit%hum_frac(j) * &
768: | ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
769: |
770: | tl(i) = tlong_ref(i) - ZeroCelsius
771: | gdd_crit(i) = pheno_crit%gdd(j,1) + tl(i)*pheno_crit%gdd(j,2) + &
772: | tl(i)*tl(i)*pheno_crit%gdd(j,3)
773: |
774: | IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
775: | ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
776: | ( t2m_month(i) .GT. t_always ) ) .AND. &
777: | ( ( ( moiavail_week(i,j) .GE. moiavail_crit(i) ) .AND. &
778: | ( moiavail_month(i,j) .LT. moiavail_crit(i) ) ) .OR. &
779: | ( moiavail_month(i,j) .GE. moiavail_always ) ) ) THEN
780: | begin_leaves(i,j) = .TRUE.
781: | ENDIF
782: |
783: | ENDIF ! PFT there and start of growing season allowed
784: |
785: V------ ENDDO
786:
787: IF (bavard.GE.4) WRITE(numout,*) 'Leaving humgdd'
788:
789: END SUBROUTINE pheno_humgdd
790:
791: !
792: ! ==============================================================================
793: ! Phenology: leaves are put on if gdd exceeds a critical value.
794: ! Additionally, a certain time must have elapsed since the moisture minimum.
795: ! Set gdd to undef if beginning of the growing season detected.
796: !
797:
798: SUBROUTINE pheno_moigdd (npts, j, PFTpresent, allow_initpheno, gdd, &
799: time_hum_min, &
800: tlong_ref, t2m_month, t2m_week, &
801: moiavail_week, moiavail_month, &
802: begin_leaves)
803:
804: !
805: ! 0 declarations
806: !
807:
808: ! 0.1 input
809:
810: ! Domain size
811: INTEGER(i_std), INTENT(in) :: npts
812: ! PFT index
813: INTEGER(i_std), INTENT(in) :: j
814: ! PFT exists
815: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
816: ! are we allowed to decalre the beginning of the growing season?
817: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
818: ! growing degree days, calculated since leaves have fallen
819: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gdd
820: ! time elapsed since strongest moisture availability (d)
821: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_hum_min
822: ! "long term" 2 meter temperatures (K)
823: REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
824: ! "monthly" 2-meter temperatures (K)
825: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
826: ! "weekly" 2-meter temperatures (K)
827: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
828: ! "weekly" moisture availability
829: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
830: ! "monthly" moisture availability
831: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
832:
833: ! 0.2 output
834:
835: ! signal to start putting leaves on
836: LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
837:
838: ! 0.3 local
839:
840: ! moisture availability above which moisture tendency doesn't matter
841: ! moisture availability above which moisture tendency doesn't matter
842: REAL(r_std), PARAMETER :: moiavail_always_tree = 1.0
843: REAL(r_std), PARAMETER :: moiavail_always_grass = 0.6
844: REAL(r_std) :: moiavail_always
845: ! monthly temp. above which temp. tendency doesn't matter
846: REAL(r_std), PARAMETER :: t_always = ZeroCelsius + 10.
847: ! long term temperature, C
848: REAL(r_std), DIMENSION(npts) :: tl
849: ! critical GDD
850: REAL(r_std), DIMENSION(npts) :: gdd_crit
851: ! index
852: INTEGER(i_std) :: i
853:
854: ! =========================================================================
855:
856: IF (bavard.GE.3) WRITE(numout,*) 'Entering moigdd'
857:
858: !
859: ! 1 Initializations
860: !
861:
862: !
863: ! 1.1 messages
864: !
865:
866: IF ( firstcall_moigdd ) THEN
867:
868: WRITE(numout,*) 'pheno_moigdd:'
869: WRITE(numout,*) ' > moisture availability above which moisture tendency doesn''t matter: '
870: WRITE(numout,*) ' trees:', moiavail_always_tree
871: WRITE(numout,*) ' grasses:', moiavail_always_grass
872: WRITE(numout,*) ' > monthly temp. above which temp. tendency doesn''t matter: ', &
873: t_always
874:
875: firstcall_moigdd = .FALSE.
876:
877: ENDIF
878:
879: !
880: ! 1.2 initialize output
881: !
882:
883: V====== begin_leaves(:,j) = .FALSE.
884:
885: !
886: ! 1.3 check the prescribed critical values
887: !
888:
889: *====== IF ( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) THEN
890:
891: WRITE(numout,*) 'moigdd: pheno_crit%gdd is undefined for PFT',j
892: WRITE(numout,*) 'We stop.'
893: STOP
894:
895: ENDIF
896:
897: IF ( pheno_crit%hum_min_time(j) .EQ. undef ) THEN
898:
899: WRITE(numout,*) 'moigdd: pheno_crit%hum_min_time is undefined for PFT',j
900: WRITE(numout,*) 'We stop.'
901: STOP
902:
903: ENDIF
904:
905: !
906: ! 1.4 critical moisture availability above which we always detect the beginning of the
907: ! growing season.
908: !
909:
910: IF ( tree(j) ) THEN
911: moiavail_always = moiavail_always_tree
912: ELSE
913: moiavail_always = moiavail_always_grass
914: ENDIF
915:
916: !
917: ! 2 PFT has to be there, start of growing season must be allowed,
918: ! and gdd has to be defined
919: !
920:
921: V------> DO i = 1, npts
922: |
923: | IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
924: | ( gdd(i,j) .NE. undef ) ) THEN
925: |
926: | ! is critical gdd reached and is temperature increasing?
927: | ! has enough time gone by since moisture minimum and is moisture increasing?
928: |
929: | tl(i) = tlong_ref(i) - ZeroCelsius
930: | gdd_crit(i) = pheno_crit%gdd(j,1) + tl(i)*pheno_crit%gdd(j,2) + &
931: | tl(i)*tl(i)*pheno_crit%gdd(j,3)
932: |
933: | IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
934: | ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
935: | ( t2m_month(i) .GT. t_always ) ) .AND. &
936: | ( ( ( time_hum_min(i,j) .GT. pheno_crit%hum_min_time(j) ) .AND. &
937: | ( moiavail_week(i,j) .GT. moiavail_month(i,j) ) ) .OR. &
938: | ( moiavail_month(i,j) .GE. moiavail_always ) ) ) THEN
939: | begin_leaves(i,j) = .TRUE.
940: | ENDIF
941: |
942: | ENDIF ! PFT there and start of growing season allowed
943: |
944: V------ ENDDO
945:
946: IF (bavard.GE.4) WRITE(numout,*) 'Leaving moigdd'
947:
948: END SUBROUTINE pheno_moigdd
949:
950:
951: !
952: ! ==============================================================================
953: ! Phenology: leaves are put on if a certain relationship between ncd since leaves were
954: ! lost (number of chilling days) and gdd since midwinter (growing degree
955: ! days) is fulfilled
956: !
957:
958: SUBROUTINE pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
959: ncd_dormance, gdd_midwinter, &
960: t2m_month, t2m_week, begin_leaves)
961:
962: !
963: ! 0 declarations
964: !
965:
966: ! 0.1 input
967:
968: ! Domain size
969: INTEGER(i_std), INTENT(in) :: npts
970: ! PFT index
971: INTEGER(i_std), INTENT(in) :: j
972: ! PFT exists
973: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
974: ! are we allowed to decalre the beginning of the growing season?
975: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
976: ! number of chilling days since leaves were lost
977: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ncd_dormance
978: ! growing degree days since midwinter
979: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_midwinter
980: ! "monthly" 2-meter temperatures (K)
981: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
982: ! "weekly" 2-meter temperatures (K)
983: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
984:
985: ! 0.2 output
986:
987: ! signal to start putting leaves on
988: LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
989:
990: ! 0.3 local
991:
992: ! index
993: INTEGER(i_std) :: i
994: ! critical gdd
995: REAL(r_std) :: gdd_min
996:
997: ! =========================================================================
998:
999: IF (bavard.GE.3) WRITE(numout,*) 'Entering ncdgdd'
1000:
1001: !
1002: ! 1 Initializations
1003: !
1004:
1005: !
1006: ! 1.1 initialize output
1007: !
1008:
1009: V====== begin_leaves(:,j) = .FALSE.
1010:
1011: !
1012: ! 1.2 check the prescribed critical values
1013: !
1014:
1015: IF ( pheno_crit%ncdgdd_temp(j) .EQ. undef ) THEN
1016:
1017: WRITE(numout,*) 'ncdgdd: pheno_crit%ncdgdd_temp is undefined for PFT',j
1018: WRITE(numout,*) 'We stop.'
1019: STOP
1020:
1021: ENDIF
1022:
1023: !
1024: ! 2 PFT has to be there and start of growing season must be allowed
1025: !
1026:
1027: V------> DO i = 1, npts
1028: |
1029: | IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
1030: | ( gdd_midwinter(i,j) .NE. undef ) .AND. &
1031: | ( ncd_dormance(i,j) .NE. undef ) ) THEN
1032: |
1033: | ! critical gdd
1034: |
1035: | gdd_min = ( 603. / exp(0.0091*ncd_dormance(i,j)) - 64. )
1036: |
1037: | ! has the critical gdd been reached and are temperatures increasing?
1038: |
1039: | IF ( ( gdd_midwinter(i,j) .GE. gdd_min ) .AND. &
1040: | ( t2m_week(i) .GT. t2m_month(i) ) ) THEN
1041: | begin_leaves(i,j) = .TRUE.
1042: | gdd_midwinter(i,j)=undef
1043: | ENDIF
1044: |
1045: | ENDIF ! PFT there and start of growing season allowed
1046: |
1047: V------ ENDDO
1048:
1049: IF (bavard.GE.4) WRITE(numout,*) 'Leaving ncdgdd'
1050:
1051: END SUBROUTINE pheno_ncdgdd
1052:
1053: !
1054: ! ==============================================================================
1055: ! Phenology: leaves are put on if ngd (number of growing days, defined as
1056: ! days with t>-5 deg C) exceeds a critical value.
1057: !
1058:
1059: SUBROUTINE pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd, &
1060: t2m_month, t2m_week, begin_leaves)
1061:
1062: !
1063: ! 0 declarations
1064: !
1065:
1066: ! 0.1 input
1067:
1068: ! Domain size
1069: INTEGER(i_std), INTENT(in) :: npts
1070: ! PFT index
1071: INTEGER(i_std), INTENT(in) :: j
1072: ! PFT exists
1073: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
1074: ! are we allowed to decalre the beginning of the growing season?
1075: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: allow_initpheno
1076: ! growing degree days
1077: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ngd
1078: ! "monthly" 2-meter temperatures (K)
1079: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
1080: ! "weekly" 2-meter temperatures (K)
1081: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
1082:
1083: ! 0.2 output
1084:
1085: ! signal to start putting leaves on
1086: LOGICAL, DIMENSION(npts,npft), INTENT(out) :: begin_leaves
1087:
1088: ! 0.3 local
1089:
1090: ! index
1091: INTEGER(i_std) :: i
1092:
1093: ! =========================================================================
1094:
1095: IF (bavard.GE.3) WRITE(numout,*) 'Entering ngd'
1096:
1097: !
1098: ! Initializations
1099: !
1100:
1101: !
1102: ! 1.1 initialize output
1103: !
1104:
1105: V====== begin_leaves(:,j) = .FALSE.
1106:
1107: !
1108: ! 1.2 check the prescribed critical value
1109: !
1110:
1111: IF ( pheno_crit%ngd(j) .EQ. undef ) THEN
1112:
1113: WRITE(numout,*) 'ngd: pheno_crit%ngd is undefined for PFT',j
1114: WRITE(numout,*) 'We stop.'
1115: STOP
1116:
1117: ENDIF
1118:
1119: !
1120: ! 2 PFT has to be there and start of growing season must be allowed
1121: !
1122:
1123: V------> DO i = 1, npts
1124: |
1125: | IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
1126: |
1127: | ! is critical ngd reached and are temperatures increasing?
1128: |
1129: | IF ( ( ngd(i,j) .GE. pheno_crit%ngd(j) ) .AND. &
1130: | ( t2m_week(i) .GT. t2m_month(i) ) ) THEN
1131: | begin_leaves(i,j) = .TRUE.
1132: | ENDIF
1133: |
1134: | ENDIF ! PFT there and start of growing season allowed
1135: |
1136: V------ ENDDO
1137:
1138: IF (bavard.GE.4) WRITE(numout,*) 'Leaving ngd'
1139:
1140: END SUBROUTINE pheno_ngd
1141:
1142: END MODULE stomate_phenology
ORCHIDEE/src_stomate/i.stomate_prescribe.L 0000754 0103600 0005670 00000036301 11164403473 020331 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:36 2008
FILE NAME: i.stomate_prescribe.f90
PROGRAM NAME: stomate_prescribe
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
89 vec ( 2): Partially vectorized loop.
89 vec ( 25): Work vectors are used. Size=48byte
99 vec ( 4): Vectorized array expression.
107 vec ( 4): Vectorized array expression.
109 vec ( 3): Unvectorized loop.
109 vec ( 13): Overhead of loop division is too large.
131 opt (1036): Potential feedback - use directive if OK.
164 vec ( 4): Vectorized array expression.
180 vec ( 4): Vectorized array expression.
190 vec ( 4): Vectorized array expression.
202 opt (1057): Complicated use of variable inhibits loop optimization.
219 vec ( 3): Unvectorized loop.
219 vec ( 13): Overhead of loop division is too large.
230 vec ( 4): Vectorized array expression.
230 vec ( 26): Macro operation Sum/InnerProd.
234 vec ( 4): Vectorized array expression.
245 vec ( 18): Unvectorizable data type.
258 vec ( 4): Vectorized array expression.
258 vec ( 26): Macro operation Sum/InnerProd.
291 warn ( 83): Dummy argument "space_nat" is not used.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:36 2008
FILE NAME: i.stomate_prescribe.f90
PROGRAM NAME: stomate_prescribe
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! Initialize density of individuals and crown area to some reasonable value
2: ! if the DGVM is not (yet) activated.
3: ! Prescribe density of individuals and crown area for agricultural PFTs.
4: ! At first call, if the DGVM is not (yet) activated, impose some biomass if zero
5: ! for a prescribed PFT. Initialize leaf age classes.
6: ! At first call, if the DGVM is not (yet) activated, declare PFT present if its
7: ! prescribed vegetation cover is above 0
8: !
9: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_prescribe.f90,v 1.9 2007/05/28 14:49:02 ssipsl Exp $
10: ! IPSL (2006)
11: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
12: !
13: MODULE stomate_prescribe
14:
15: ! modules used:
16:
17: USE ioipsl
18: USE stomate_constants
19:
20: IMPLICIT NONE
21:
22: ! private & public routines
23:
24: PRIVATE
25: PUBLIC prescribe,prescribe_clear
26:
27: ! first call
28: LOGICAL, SAVE :: firstcall = .TRUE.
29:
30: CONTAINS
31:
32: SUBROUTINE prescribe_clear
33: firstcall=.TRUE.
34: END SUBROUTINE prescribe_clear
35:
36: SUBROUTINE prescribe (npts, &
37: space_nat, &
38: veget_max, PFTpresent, everywhere, when_growthinit, &
39: biomass, leaf_frac, ind, cn_ind)
40:
41: !
42: ! 0 declarations
43: !
44:
45: ! 0.1 input
46:
47: ! Domain size
48: INTEGER(i_std), INTENT(in) :: npts
49: ! total natural space (fraction of total space)
50: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
51:
52: ! 0.2 modified fields
53:
54: ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
55: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
56: ! PFT present
57: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
58: ! is the PFT everywhere in the grid box or very localized (after its introduction)
59: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
60: ! how many days ago was the beginning of the growing season
61: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
62: ! biomass (gC/(m**2 of nat/agri ground))
63: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
64: ! fraction of leaves in leaf age class
65: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
66: ! density of individuals (1/(m**2 of nat/agri ground))
67: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
68: ! crown area of individuals (m**2)
69: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: cn_ind
70:
71: ! 0.3 output
72:
73:
74: ! 0.4 local
75:
76: ! generic tree crown area (m**2)
77: REAL(r_std), PARAMETER :: cn_tree = 4.
78: ! stem diameter (m)
79: REAL(r_std), DIMENSION(npts) :: dia
80: ! woodmass (gC/(m**2 of nat/agri ground))
81: REAL(r_std), DIMENSION(npts) :: woodmass
82: ! woodmass of an individual (gC)
83: REAL(r_std), DIMENSION(npts) :: woodmass_ind
84: ! index
85: INTEGER(i_std) :: i,j
86:
87: ! =========================================================================
88:
89: V------> DO j = 1, npft
90: |
91: | ! only when the DGVM is not activated or agricultural PFT.
92: |
93: | S IF ( ( .NOT. control%ok_dgvm ) .OR. ( .NOT. natural(j) ) ) THEN
94: |
95: | !
96: | ! 1 crown area
97: | !
98: |
99: |V===== cn_ind(:,j) = 0.0
100: |
101: | S IF ( tree(j) ) THEN
102: |
103: | !
104: | ! 1.1 trees
105: | !
106: |
107: |V===== dia(:) = 0.0
108: |
109: |+-----> DO i = 1, npts
110: ||
111: || IF ( veget_max(i,j) .GT. 0.0 ) THEN
112: ||
113: || ! 1.1.1 calculate total wood mass
114: ||
115: || woodmass(i) = biomass(i,j,isapabove) + biomass(i,j,isapbelow) + &
116: || biomass(i,j,iheartabove) + biomass(i,j,iheartbelow)
117: ||
118: || IF ( woodmass(i) .GT. min_stomate ) THEN
119: ||
120: || ! 1.1.2 calculate critical density of individuals
121: ||
122: || ind(i,j) = woodmass(i) / &
123: || ( pipe_density*pi/4.*pipe_tune2 * maxdia(j)**(2.+pipe_tune3) )
124: ||
125: || ! 1.1.3 individual biomass corresponding to this critical density of individuals
126: ||
127: || woodmass_ind(i) = woodmass(i) / ind(i,j)
128: ||
129: || ! 1.1.4 stem diameter
130: ||
131: || dia(i) = ( woodmass_ind(i) / ( pipe_density * pi/4. * pipe_tune2 ) ) ** &
132: || ( 1. / ( 2. + pipe_tune3 ) )
133: ||
134: || ! 1.1.5 crown area, provisional
135: ||
136: || cn_ind(i,j) = pipe_tune1 * MIN( maxdia(j), dia(i) ) ** 1.6
137: ||
138: || ! 1.1.6 do we have to recalculate the crown area?
139: ||
140: || IF ( cn_ind(i,j) * ind(i,j) .GT. 1.002* veget_max(i,j) ) THEN
141: ||
142: || ind(i,j) = veget_max(i,j) / cn_ind(i,j)
143: ||
144: || ELSE
145: ||
146: || ind(i,j) = ( veget_max(i,j) / &
147: || ( pipe_tune1 * (woodmass(i)/(pipe_density*pi/4.*pipe_tune2))**(1.6/(2.+pipe_tune3)) ) ) &
148: || ** (1./(1.-(1.6/(2.+pipe_tune3))))
149: ||
150: || woodmass_ind(i) = woodmass(i) / ind(i,j)
151: ||
152: || dia(i) = ( woodmass_ind(i) / ( pipe_density * pi/4. * pipe_tune2 ) ) ** &
153: || ( 1. / ( 2. + pipe_tune3 ) )
154: ||
155: || ! final crown area
156: || cn_ind(i,j) = pipe_tune1 * MIN( maxdia(j), dia(i) ) ** 1.6
157: ||
158: || ENDIF
159: ||
160: || ELSE
161: ||
162: || ! woodmass = 0 => impose some value
163: ||
164: ||V==== dia(:) = maxdia(j)
165: ||
166: || cn_ind(i,j) = pipe_tune1 * MIN( maxdia(j), dia(i) ) ** 1.6
167: ||
168: || ENDIF
169: ||
170: || ENDIF ! veget_max .GT. 0.
171: ||
172: |+----- ENDDO ! loop over grid points
173: |
174: | ELSE
175: |
176: | !
177: | ! 1.2 grasses: always 1m**2
178: | !
179: |
180: |V-----> WHERE ( veget_max(:,j) .GT. 0.0 )
181: |V----- cn_ind(:,j) = 1.0
182: | ENDWHERE
183: |
184: | ENDIF ! tree/grass?
185: |
186: | !
187: | ! 2 density of individuals
188: | !
189: |
190: |V-----> WHERE ( veget_max(:,j) .GT. 0.0 )
191: ||
192: || ind(:,j) = veget_max(:,j) / cn_ind(:,j)
193: ||
194: || ELSEWHERE
195: ||
196: |V----- ind(:,j) = 0.0
197: |
198: | ENDWHERE
199: |
200: | ENDIF ! not natural or DGVM not activated?
201: |
202: V------ ENDDO ! loop over PFTs
203:
204: !
205: ! 4 first call
206: !
207:
208: IF ( firstcall ) THEN
209:
210: WRITE(numout,*) 'prescribe:'
211:
212: ! impose some biomass if zero and PFT prescribed
213:
214: WRITE(numout,*) ' > Imposing initial biomass for prescribed trees, '// &
215: 'initial reserve mass for prescribed grasses.'
216: WRITE(numout,*) ' > Declaring prescribed PFTs present.'
217:
218: +------> DO j = 1, npft
219: |+-----> DO i = 1, npts
220: ||
221: || ! is vegetation static or PFT agricultural?
222: ||
223: || IF ( ( .NOT. control%ok_dgvm ) .OR. &
224: || ( ( .NOT. natural(j) ) .AND. ( veget_max(i,j) .GT. min_stomate ) ) ) THEN
225: ||
226: || !
227: || ! 4.1 trees
228: || !
229: ||
230: ||V==== IF ( tree(j) .AND. &
231: || ( veget_max(i,j) .GT. min_stomate ) .AND. &
232: || ( SUM( biomass(i,j,:) ) .LE. min_stomate ) ) THEN
233: ||
234: ||V==== biomass(i,j,:) = 40. * bm_sapl(j,:) * ind(i,j)
235: ||
236: || ! set leaf age classes
237: ||+==== leaf_frac(i,j,:) = 0.0
238: || leaf_frac(i,j,1) = 1.0
239: ||
240: || ! set time since last beginning of growing season
241: || when_growthinit(i,j) = large_value
242: ||
243: || ! seasonal trees: no leaves at beginning
244: ||
245: || IF ( pheno_crit%pheno_model(j) .NE. 'none' ) THEN
246: ||
247: || biomass(i,j,ileaf) = 0.0
248: || leaf_frac(i,j,1) = 0.0
249: ||
250: || ENDIF
251: ||
252: || ENDIF
253: ||
254: || !
255: || ! 4.2 grasses
256: || !
257: ||
258: ||V==== IF ( ( .NOT. tree(j) ) .AND. &
259: || ( veget_max(i,j) .GT. min_stomate ) .AND. &
260: || ( SUM( biomass(i,j,:) ) .LE. min_stomate ) ) THEN
261: ||
262: || biomass(i,j,icarbres) = bm_sapl(j,icarbres) * ind(i,j)
263: ||
264: || ! set leaf age classes
265: ||*==== leaf_frac(i,j,:) = 0.0
266: || leaf_frac(i,j,1) = 1.0
267: ||
268: || ! set time since last beginning of growing season
269: || when_growthinit(i,j) = large_value
270: ||
271: || ENDIF
272: ||
273: || !
274: || ! 4.3 declare PFT present everywhere in that grid box
275: || !
276: ||
277: || IF ( veget_max(i,j) .GT. min_stomate ) THEN
278: || PFTpresent(i,j) = .TRUE.
279: || everywhere(i,j) = 1.
280: || ENDIF
281: ||
282: || ENDIF ! not control%ok_dgvm or agricultural
283: ||
284: |+----- ENDDO
285: +------ ENDDO
286:
287: firstcall = .FALSE.
288:
289: ENDIF
290:
291: END SUBROUTINE prescribe
292:
293: END MODULE stomate_prescribe
ORCHIDEE/src_stomate/i.stomate_season.L 0000754 0103600 0005670 00000162107 11164403473 017647 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:38 2008
FILE NAME: i.stomate_season.f90
PROGRAM NAME: stomate_season
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
225 opt (1593): Loop nest collapsed into one loop.
225 vec ( 4): Vectorized array expression.
225 vec ( 26): Macro operation Sum/InnerProd.
229 opt (1593): Loop nest collapsed into one loop.
229 vec ( 4): Vectorized array expression.
235 opt (1593): Loop nest collapsed into one loop.
235 vec ( 4): Vectorized array expression.
235 vec ( 26): Macro operation Sum/InnerProd.
239 opt (1593): Loop nest collapsed into one loop.
239 vec ( 4): Vectorized array expression.
247 vec ( 4): Vectorized array expression.
247 vec ( 26): Macro operation Sum/InnerProd.
251 vec ( 4): Vectorized array expression.
257 vec ( 4): Vectorized array expression.
257 vec ( 26): Macro operation Sum/InnerProd.
261 vec ( 4): Vectorized array expression.
267 vec ( 4): Vectorized array expression.
267 vec ( 26): Macro operation Sum/InnerProd.
271 vec ( 4): Vectorized array expression.
277 opt (1593): Loop nest collapsed into one loop.
277 vec ( 4): Vectorized array expression.
277 vec ( 26): Macro operation Sum/InnerProd.
282 opt (1593): Loop nest collapsed into one loop.
282 vec ( 4): Vectorized array expression.
288 opt (1593): Loop nest collapsed into one loop.
288 vec ( 4): Vectorized array expression.
288 vec ( 26): Macro operation Sum/InnerProd.
293 opt (1593): Loop nest collapsed into one loop.
293 vec ( 4): Vectorized array expression.
299 opt (1593): Loop nest collapsed into one loop.
299 vec ( 4): Vectorized array expression.
299 vec ( 26): Macro operation Sum/InnerProd.
301 opt (1593): Loop nest collapsed into one loop.
301 vec ( 4): Vectorized array expression.
306 opt (1593): Loop nest collapsed into one loop.
306 vec ( 4): Vectorized array expression.
306 vec ( 26): Macro operation Sum/InnerProd.
309 opt (1593): Loop nest collapsed into one loop.
309 vec ( 4): Vectorized array expression.
314 opt (1593): Loop nest collapsed into one loop.
314 vec ( 4): Vectorized array expression.
314 vec ( 26): Macro operation Sum/InnerProd.
316 opt (1593): Loop nest collapsed into one loop.
316 vec ( 4): Vectorized array expression.
321 opt (1593): Loop nest collapsed into one loop.
321 vec ( 4): Vectorized array expression.
321 vec ( 26): Macro operation Sum/InnerProd.
327 opt (1593): Loop nest collapsed into one loop.
327 vec ( 4): Vectorized array expression.
327 vec ( 26): Macro operation Sum/InnerProd.
333 opt (1593): Loop nest collapsed into one loop.
333 vec ( 4): Vectorized array expression.
333 vec ( 26): Macro operation Sum/InnerProd.
339 opt (1593): Loop nest collapsed into one loop.
339 vec ( 4): Vectorized array expression.
339 vec ( 26): Macro operation Sum/InnerProd.
345 opt (1593): Loop nest collapsed into one loop.
345 vec ( 4): Vectorized array expression.
345 vec ( 26): Macro operation Sum/InnerProd.
350 opt (1593): Loop nest collapsed into one loop.
350 vec ( 4): Vectorized array expression.
370 opt (1593): Loop nest collapsed into one loop.
370 vec ( 4): Vectorized array expression.
373 opt (1593): Loop nest collapsed into one loop.
373 vec ( 4): Vectorized array expression.
381 opt (1593): Loop nest collapsed into one loop.
381 vec ( 4): Vectorized array expression.
384 opt (1593): Loop nest collapsed into one loop.
384 vec ( 4): Vectorized array expression.
396 vec ( 4): Vectorized array expression.
399 vec ( 4): Vectorized array expression.
412 vec ( 4): Vectorized array expression.
421 vec ( 4): Vectorized array expression.
429 vec ( 4): Vectorized array expression.
432 vec ( 4): Vectorized array expression.
440 opt (1593): Loop nest collapsed into one loop.
440 vec ( 4): Vectorized array expression.
443 opt (1593): Loop nest collapsed into one loop.
443 vec ( 4): Vectorized array expression.
451 opt (1593): Loop nest collapsed into one loop.
451 vec ( 4): Vectorized array expression.
454 opt (1593): Loop nest collapsed into one loop.
454 vec ( 4): Vectorized array expression.
466 opt (1593): Loop nest collapsed into one loop.
466 vec ( 4): Vectorized array expression.
483 vec ( 3): Unvectorized loop.
489 opt (1084): Branch out of the loop inhibits optimization.
489 vec ( 6): Unvectorized array expression.
489 vec ( 7): Iteration count is too small.
495 vec ( 4): Vectorized array expression.
505 vec ( 4): Vectorized array expression.
515 vec ( 4): Vectorized array expression.
521 vec ( 4): Vectorized array expression.
530 opt (1593): Loop nest collapsed into one loop.
530 vec ( 4): Vectorized array expression.
538 vec ( 3): Unvectorized loop.
538 vec ( 13): Overhead of loop division is too large.
548 vec ( 4): Vectorized array expression.
560 opt (1082): Backward transfers inhibit loop optimization.
560 vec ( 4): Vectorized array expression.
571 vec ( 4): Vectorized array expression.
588 vec ( 3): Unvectorized loop.
588 vec ( 13): Overhead of loop division is too large.
596 vec ( 4): Vectorized array expression.
606 vec ( 4): Vectorized array expression.
616 vec ( 4): Vectorized array expression.
631 vec ( 3): Unvectorized loop.
631 vec ( 13): Overhead of loop division is too large.
638 vec ( 4): Vectorized array expression.
646 opt (1082): Backward transfers inhibit loop optimization.
646 vec ( 4): Vectorized array expression.
650 vec ( 4): Vectorized array expression.
654 opt (1593): Loop nest collapsed into one loop.
654 vec ( 4): Vectorized array expression.
662 vec ( 3): Unvectorized loop.
662 vec ( 13): Overhead of loop division is too large.
670 vec ( 4): Vectorized array expression.
682 vec ( 4): Vectorized array expression.
695 vec ( 4): Vectorized array expression.
704 vec ( 4): Vectorized array expression.
721 opt (1593): Loop nest collapsed into one loop.
721 vec ( 4): Vectorized array expression.
725 opt (1593): Loop nest collapsed into one loop.
725 vec ( 4): Vectorized array expression.
733 opt (1593): Loop nest collapsed into one loop.
733 vec ( 4): Vectorized array expression.
737 opt (1593): Loop nest collapsed into one loop.
737 vec ( 4): Vectorized array expression.
747 opt (1593): Loop nest collapsed into one loop.
747 vec ( 4): Vectorized array expression.
758 opt (1593): Loop nest collapsed into one loop.
758 vec ( 4): Vectorized array expression.
766 opt (1593): Loop nest collapsed into one loop.
766 vec ( 4): Vectorized array expression.
770 opt (1593): Loop nest collapsed into one loop.
770 vec ( 4): Vectorized array expression.
778 opt (1593): Loop nest collapsed into one loop.
778 vec ( 4): Vectorized array expression.
786 vec ( 4): Vectorized array expression.
794 vec ( 4): Vectorized array expression.
804 opt (1592): Outer loop unrolled inside inner loop.
804 vec ( 4): Vectorized array expression.
810 vec ( 3): Unvectorized loop.
811 opt (1592): Outer loop unrolled inside inner loop.
811 vec ( 4): Vectorized array expression.
822 opt (1593): Loop nest collapsed into one loop.
822 vec ( 4): Vectorized array expression.
836 opt (1593): Loop nest collapsed into one loop.
836 vec ( 4): Vectorized array expression.
841 vec ( 4): Vectorized array expression.
845 opt (1593): Loop nest collapsed into one loop.
845 vec ( 4): Vectorized array expression.
858 vec ( 4): Vectorized array expression.
862 opt (1593): Loop nest collapsed into one loop.
862 vec ( 4): Vectorized array expression.
874 vec ( 3): Unvectorized loop.
874 vec ( 13): Overhead of loop division is too large.
876 vec ( 4): Vectorized array expression.
894 vec ( 4): Vectorized array expression.
895 vec ( 3): Unvectorized loop.
896 vec ( 4): Vectorized array expression.
897 opt (1592): Outer loop unrolled inside inner loop.
900 vec ( 3): Unvectorized loop.
900 vec ( 13): Overhead of loop division is too large.
901 vec ( 4): Vectorized array expression.
902 opt (1592): Outer loop unrolled inside inner loop.
922 vec ( 4): Vectorized array expression.
926 vec ( 3): Unvectorized loop.
926 vec ( 13): Overhead of loop division is too large.
930 vec ( 4): Vectorized array expression.
933 vec ( 18): Unvectorizable data type.
934 opt (1019): Feedback of scalar value from one loop pass to another.
934 vec ( 4): Vectorized array expression.
936 opt (1019): Feedback of scalar value from one loop pass to another.
936 vec ( 4): Vectorized array expression.
943 vec ( 4): Vectorized array expression.
954 vec ( 3): Unvectorized loop.
954 vec ( 13): Overhead of loop division is too large.
958 opt (1082): Backward transfers inhibit loop optimization.
958 vec ( 4): Vectorized array expression.
967 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:38 2008
FILE NAME: i.stomate_season.f90
PROGRAM NAME: stomate_season
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! Calculate long-term meteorological parameters from daily temperatures
2: ! and precipitations (essentially for phenology)
3: !
4: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_season.f90,v 1.11 2007/05/28 14:49:02 ssipsl Exp $
5: ! IPSL (2006)
6: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
7: !
8: MODULE stomate_season
9:
10: ! modules used:
11:
12: USE ioipsl
13: USE stomate_constants
14: USE stomate_natagritot
15:
16: IMPLICIT NONE
17:
18: ! private & public routines
19:
20: PRIVATE
21: PUBLIC season,season_clear
22:
23: ! first call
24: LOGICAL, SAVE :: firstcall = .TRUE.
25:
26: CONTAINS
27:
28:
29: SUBROUTINE season_clear
30: firstcall=.TRUE.
31: END SUBROUTINE season_clear
32:
33: SUBROUTINE season (npts, dt, EndOfYear, space_nat, &
34: veget, veget_max, &
35: moiavail_daily, t2m_daily, tsoil_daily, soilhum_daily, &
36: precip_daily, npp_daily, biomass, turnover_daily, gpp_daily, when_growthinit, &
37: maxmoiavail_lastyear, maxmoiavail_thisyear, &
38: minmoiavail_lastyear, minmoiavail_thisyear, &
39: maxgppweek_lastyear, maxgppweek_thisyear, &
40: gdd0_lastyear, gdd0_thisyear, &
41: precip_lastyear, precip_thisyear, &
42: lm_lastyearmax, lm_thisyearmax, &
43: maxfpc_lastyear, maxfpc_thisyear, &
44: moiavail_month, moiavail_week, t2m_longterm, tlong_ref, t2m_month, t2m_week, &
45: tsoil_month, soilhum_month, &
46: npp_longterm, turnover_longterm, gpp_week, &
47: gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, time_lowgpp, &
48: time_hum_min, hum_min_dormance, herbivores)
49:
50: !
51: ! 0 declarations
52: !
53:
54: ! 0.1 input
55:
56: ! Domain size
57: INTEGER(i_std), INTENT(in) :: npts
58: ! time step in days
59: REAL(r_std), INTENT(in) :: dt
60: ! update yearly variables?
61: LOGICAL, INTENT(in) :: EndOfYear
62: ! total natural space (fraction of total space)
63: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
64: ! coverage fraction of a PFT. Here: fraction of total ground.
65: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget
66: ! "maximal" coverage fraction of a PFT (for LAI -> infinity)
67: ! Here: fraction of total ground.
68: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
69: ! Daily moisture availability
70: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_daily
71: ! Daily 2 meter temperature (K)
72: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_daily
73: ! Daily soil temperature (K)
74: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil_daily
75: ! Daily soil humidity
76: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum_daily
77: ! Daily mean precipitation (mm/day)
78: REAL(r_std), DIMENSION(npts), INTENT(in) :: precip_daily
79: ! daily net primary productivity (gC/m**2/day)
80: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: npp_daily
81: ! biomass (gC/(m**2 of nat/agri ground))
82: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: biomass
83: ! Turnover rates (gC/m**2/day)
84: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: turnover_daily
85: ! daily gross primary productivity (Here: gC/(m**2 of total ground)/day)
86: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gpp_daily
87: ! how many days ago was the beginning of the growing season
88: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: when_growthinit
89:
90: ! 0.2 modified fields
91:
92: ! last year's maximum moisture availability
93: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxmoiavail_lastyear
94: ! this year's maximum moisture availability
95: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxmoiavail_thisyear
96: ! last year's minimum moisture availability
97: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: minmoiavail_lastyear
98: ! this year's minimum moisture availability
99: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: minmoiavail_thisyear
100: ! last year's maximum weekly GPP
101: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxgppweek_lastyear
102: ! this year's maximum weekly GPP
103: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxgppweek_thisyear
104: ! last year's annual GDD0
105: REAL(r_std), DIMENSION(npts), INTENT(inout) :: gdd0_lastyear
106: ! this year's annual GDD0
107: REAL(r_std), DIMENSION(npts), INTENT(inout) :: gdd0_thisyear
108: ! last year's annual precipitation (mm/year)
109: REAL(r_std), DIMENSION(npts), INTENT(inout) :: precip_lastyear
110: ! this year's annual precipitation (mm/year)
111: REAL(r_std), DIMENSION(npts), INTENT(inout) :: precip_thisyear
112: ! last year's maximum leaf mass, for each PFT (gC/m**2)
113: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_lastyearmax
114: ! this year's maximum leaf mass, for each PFT (gC/m**2)
115: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_thisyearmax
116: ! last year's maximum fpc for each natural PFT, on *natural* ground
117: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxfpc_lastyear
118: ! this year's maximum fpc for each PFT, on *total* ground
119: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: maxfpc_thisyear
120: ! "monthly" moisture availability
121: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: moiavail_month
122: ! "weekly" moisture availability
123: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: moiavail_week
124: ! "long term" 2-meter temperatures (K)
125: REAL(r_std), DIMENSION(npts), INTENT(inout) :: t2m_longterm
126: ! "long term" refernce 2-meter temperatures (K)
127: REAL(r_std), DIMENSION(npts), INTENT(inout) :: tlong_ref
128: ! "monthly" 2-meter temperatures (K)
129: REAL(r_std), DIMENSION(npts), INTENT(inout) :: t2m_month
130: ! "weekly" 2-meter temperatures (K)
131: REAL(r_std), DIMENSION(npts), INTENT(inout) :: t2m_week
132: ! "monthly" soil temperatures (K)
133: REAL(r_std), DIMENSION(npts,nbdl), INTENT(inout) :: tsoil_month
134: ! "monthly" soil humidity
135: REAL(r_std), DIMENSION(npts,nbdl), INTENT(inout) :: soilhum_month
136: ! "long term" net primary productivity (gC/m**2/year)
137: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: npp_longterm
138: ! "long term" turnover rate (gC/m**2/year)
139: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: turnover_longterm
140: ! "weekly" GPP (gC/day/(m**2 covered)
141: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gpp_week
142: ! growing degree days, threshold -5 deg. C
143: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_m5_dormance
144: ! growing degree days since midwinter
145: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_midwinter
146: ! number of chilling days since leaves were lost
147: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ncd_dormance
148: ! number of growing days
149: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ngd_minus5
150: ! duration of dormance (d)
151: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: time_lowgpp
152: ! time elapsed since strongest moisture availability (d)
153: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: time_hum_min
154: ! minimum moisture during dormance
155: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: hum_min_dormance
156:
157: ! 0.3 output (diagnostic)
158:
159: ! time constant of probability of a leaf to be eaten by a herbivore (days)
160: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: herbivores
161:
162: ! 0.4 local
163:
164: ! indices
165: INTEGER(i_std) :: j
166: ! rapport maximal GPP/GGP_max pour dormance
167: REAL(r_std), PARAMETER :: gppfrac_dormance = 0.2
168: ! maximum ncd (d) (to avoid floating point underflows)
169: REAL(r_std) :: ncd_max
170: ! parameters for herbivore activity
171: REAL(r_std), PARAMETER :: hvc1 = 0.019
172: REAL(r_std), PARAMETER :: hvc2 = 1.38
173: REAL(r_std), PARAMETER :: leaf_frac=.33
174: ! sum of natural fpcs
175: REAL(r_std), DIMENSION(npts) :: sumfpc_nat
176: ! weights
177: REAL(r_std), DIMENSION(npts) :: weighttot
178: ! natural long-term leaf NPP ( gC/m**2/year)
179: REAL(r_std), DIMENSION(npts) :: nlflong_nat
180: ! residence time of green tissue (years)
181: REAL(r_std), DIMENSION(npts) :: green_age
182: ! herbivore consumption (gC/m**2/day)
183: REAL(r_std), DIMENSION(npts) :: consumption
184:
185: ! =========================================================================
186:
187: IF (bavard.GE.3) WRITE(numout,*) 'Entering season'
188:
189: !
190: ! 1 Initializations
191: !
192: ncd_max = 3. * one_year
193:
194: IF ( firstcall ) THEN
195:
196: !
197: ! 1.1 messages
198: !
199:
200: IF ( bavard .GE. 1 ) THEN
201:
202: WRITE(numout,*) 'season: '
203:
204: WRITE(numout,*) ' > rapport maximal GPP/GGP_max pour dormance: ',gppfrac_dormance
205:
206: WRITE(numout,*) ' > maximum possible ncd (d): ',ncd_max
207:
208: WRITE(numout,*) ' > herbivore consumption C (gC/m2/day) as a function of NPP (gC/m2/d):'
209: WRITE(numout,*) ' C=',hvc1,' * NPP^',hvc2
210: WRITE(numout,*) ' > for herbivores, suppose that ',leaf_frac*100., &
211: '% of NPP is allocated to leaves'
212:
213:
214: ENDIF
215:
216: !
217: ! 1.2 Check whether longer-term meteorological parameters are initialized
218: ! to zero
219: !
220:
221: ! 1.2.1 moisture availabilities
222:
223: ! 1.2.1.1 "monthly"
224:
225: WW===== IF ( ABS( SUM( moiavail_month(:,:) ) ) .LT. min_stomate ) THEN
226:
227: ! in this case, set them it today's moisture availability
228: WRITE(numout,*) 'Warning! We have to initialize the ''monthly'' moisture availabilities.'
229: WW===== moiavail_month(:,:) = moiavail_daily(:,:)
230:
231: ENDIF
232:
233: ! 1.2.1.2 "weekly"
234:
235: ++===== IF ( ABS( SUM( moiavail_week(:,:) ) ) .LT. min_stomate ) THEN
236:
237: ! in this case, set them it today's moisture availability
238: WRITE(numout,*) 'Warning! We have to initialize the ''weekly'' moisture availabilities.'
239: ++===== moiavail_week(:,:) = moiavail_daily(:,:)
240:
241: ENDIF
242:
243: ! 1.2.2 2-meter temperatures
244:
245: ! 1.2.2.1 "long term"
246:
247: V====== IF ( ABS( SUM( t2m_longterm(:) ) ) .LT. min_stomate ) THEN
248:
249: ! in this case, set them to today's temperature
250: WRITE(numout,*) 'Warning! We have to initialize the ''long term'' 2m temperatures.'
251: V====== t2m_longterm(:) = t2m_daily(:)
252:
253: ENDIF
254:
255: ! 1.2.2.2 "monthly"
256:
257: V====== IF ( ABS( SUM( t2m_month(:) ) ) .LT. min_stomate ) THEN
258:
259: ! in this case, set them to today's temperature
260: WRITE(numout,*) 'Warning! We have to initialize the ''monthly'' 2m temperatures.'
261: V====== t2m_month(:) = t2m_daily(:)
262:
263: ENDIF
264:
265: ! 1.2.2.3 "weekly"
266:
267: V====== IF ( ABS( SUM( t2m_week(:) ) ) .LT. min_stomate ) THEN
268:
269: ! in this case, set them to today's temperature
270: WRITE(numout,*) 'Warning! We have to initialize the ''weekly'' 2m temperatures.'
271: V====== t2m_week(:) = t2m_daily(:)
272:
273: ENDIF
274:
275: ! 1.2.3 "monthly" soil temperatures
276:
277: WW===== IF ( ABS( SUM( tsoil_month(:,:) ) ) .LT. min_stomate ) THEN
278:
279: ! in this case, set them to today's temperature
280: WRITE(numout,*) 'Warning!'// &
281: ' We have to initialize the ''monthly'' soil temperatures.'
282: WW===== tsoil_month(:,:) = tsoil_daily(:,:)
283:
284: ENDIF
285:
286: ! 1.2.4 "monthly" soil humidity
287:
288: WW===== IF ( ABS( SUM( soilhum_month(:,:) ) ) .LT. min_stomate ) THEN
289:
290: ! in this case, set them to today's humidity
291: WRITE(numout,*) 'Warning!'// &
292: ' We have to initialize the ''monthly'' soil humidity.'
293: WW===== soilhum_month(:,:) = soilhum_daily(:,:)
294:
295: ENDIF
296:
297: ! 1.2.5 growing degree days, threshold -5 deg C
298:
299: WW===== IF ( ABS( SUM( gdd_m5_dormance(:,:) ) ) .LT. min_stomate ) THEN
300: WRITE(numout,*) 'Warning! Growing degree days (-5 deg) are initialized to ''undef''.'
301: WW===== gdd_m5_dormance(:,:) = undef
302: ENDIF
303:
304: ! 1.2.6 growing degree days since midwinter
305:
306: WW===== IF ( ABS( SUM( gdd_midwinter(:,:) ) ) .LT. min_stomate ) THEN
307: WRITE(numout,*) 'Warning! Growing degree days since midwinter' // &
308: ' are initialized to ''undef''.'
309: WW===== gdd_midwinter(:,:) = undef
310: ENDIF
311:
312: ! 1.2.7 number of chilling days since leaves were lost
313:
314: W*===== IF ( ABS( SUM( ncd_dormance(:,:) ) ) .LT. min_stomate ) THEN
315: WRITE(numout,*) 'Warning! Number of chilling days is initialized to ''undef''.'
316: **===== ncd_dormance(:,:) = undef
317: ENDIF
318:
319: ! 1.2.8 number of growing days, threshold -5 deg C
320:
321: **===== IF ( ABS( SUM( ngd_minus5(:,:) ) ) .LT. min_stomate ) THEN
322: WRITE(numout,*) 'Warning! Number of growing days (-5 deg) is initialized to 0.'
323: ENDIF
324:
325: ! 1.2.9 "long term" npp
326:
327: **===== IF ( ABS( SUM( npp_longterm(:,:) ) ) .LT. min_stomate ) THEN
328: WRITE(numout,*) 'Warning! Long term NPP is initialized to 0.'
329: ENDIF
330:
331: ! 1.2.10 "long term" turnover
332:
333: ***==== IF ( ABS( SUM( turnover_longterm(:,:,:) ) ) .LT. min_stomate ) THEN
334: WRITE(numout,*) 'Warning! Long term turnover is initialized to 0.'
335: ENDIF
336:
337: ! 1.2.11 "weekly" GPP
338:
339: **===== IF ( ABS( SUM( gpp_week(:,:) ) ) .LT. min_stomate ) THEN
340: WRITE(numout,*) 'Warning! Weekly GPP is initialized to 0.'
341: ENDIF
342:
343: ! 1.2.12 minimum moisture availabilities
344:
345: **===== IF ( ABS( SUM( minmoiavail_thisyear(:,:) ) ) .LT. min_stomate ) THEN
346:
347: ! in this case, set them to a very high value
348: WRITE(numout,*) 'Warning! We have to initialize this year''s minimum '// &
349: 'moisture availabilities.'
350: **===== minmoiavail_thisyear(:,:) = large_value
351:
352: ENDIF
353:
354: !
355: ! 1.3 reset flag
356: !
357:
358: firstcall = .FALSE.
359:
360: ENDIF
361:
362: !
363: ! 2 moisture availabilities
364: !
365:
366: !
367: ! 2.1 "monthly"
368: !
369:
370: **===== moiavail_month = ( moiavail_month * ( pheno_crit%tau_hum_month - dt ) + &
371: moiavail_daily * dt ) / pheno_crit%tau_hum_month
372:
373: *W-----> WHERE ( ABS(moiavail_month(:,:)) .LT. EPSILON(0.) )
374: *W----- moiavail_month(:,:) = 0.
375: ENDWHERE
376:
377: !
378: ! 2.2 "weekly"
379: !
380:
381: W*===== moiavail_week = ( moiavail_week * ( pheno_crit%tau_hum_week - dt ) + &
382: moiavail_daily * dt ) / pheno_crit%tau_hum_week
383:
384: *W-----> WHERE ( ABS(moiavail_week(:,:)) .LT. EPSILON(0.) )
385: *W----- moiavail_week(:,:) = 0.
386: ENDWHERE
387:
388: !
389: ! 3 2-meter temperatures
390: !
391:
392: !
393: ! 3.1 "long term"
394: !
395:
396: V====== t2m_longterm = ( t2m_longterm * ( pheno_crit%tau_longterm - dt ) + &
397: t2m_daily * dt ) / pheno_crit%tau_longterm
398:
399: V------> WHERE ( ABS(t2m_longterm(:)) .LT. EPSILON(0.) )
400: V------ t2m_longterm(:) = 0.
401: ENDWHERE
402:
403: !
404: ! 3.2 "long term reference"
405: ! This temperature is used for recalculating PFT-specific parameters such as
406: ! critical photosynthesis temperatures of critical GDDs for phenology. This
407: ! means that if the reference temperature varies, the PFTs adapt to them.
408: ! Therefore the reference temperature can vary only if the vegetation is not
409: ! static.
410: !
411:
412: V------> tlong_ref(:) = MAX( tlong_ref_min, MIN( tlong_ref_max, t2m_longterm(:) ) )
413: |
414: | !
415: | ! 3.3 "monthly"
416: | !
417: |
418: V------ t2m_month = ( t2m_month * ( pheno_crit%tau_t2m_month - dt ) + &
419: t2m_daily * dt ) / pheno_crit%tau_t2m_month
420:
421: V------> WHERE ( ABS(t2m_month(:)) .LT. EPSILON(0.) )
422: V------ t2m_month(:) = 0.
423: ENDWHERE
424:
425: !
426: ! 3.4 "weekly"
427: !
428:
429: V====== t2m_week = ( t2m_week * ( pheno_crit%tau_t2m_week - dt ) + &
430: t2m_daily * dt ) / pheno_crit%tau_t2m_week
431:
432: V------> WHERE ( ABS(t2m_week(:)) .LT. EPSILON(0.) )
433: V------ t2m_week(:) = 0.
434: ENDWHERE
435:
436: !
437: ! 4 ''monthly'' soil temperatures
438: !
439:
440: W*===== tsoil_month = ( tsoil_month * ( pheno_crit%tau_tsoil_month - dt ) + &
441: tsoil_daily(:,:) * dt ) / pheno_crit%tau_tsoil_month
442:
443: *W-----> WHERE ( ABS(tsoil_month(:,:)) .LT. EPSILON(0.) )
444: *W----- tsoil_month(:,:) = 0.
445: ENDWHERE
446:
447: !
448: ! 5 ''monthly'' soil humidity
449: !
450:
451: W*===== soilhum_month = ( soilhum_month * ( pheno_crit%tau_soilhum_month - dt ) + &
452: soilhum_daily * dt ) / pheno_crit%tau_soilhum_month
453:
454: *W-----> WHERE ( ABS(soilhum_month(:,:)) .LT. EPSILON(0.) )
455: *W----- soilhum_month(:,:) = 0.
456: ENDWHERE
457:
458: !
459: ! 6 dormance (d)
460: ! when gpp is low, increase dormance time. Otherwise, set it to zero.
461: ! NV: special case (3rd condition): plant is accumulating carbohydrates
462: ! and does never use them. In this case, we allow the plant to
463: ! detect a beginning of the growing season by declaring it dormant
464: !
465:
466: *W-----> WHERE ( ( gpp_week(:,:) .EQ. 0.0 ) .OR. &
467: || ( gpp_week(:,:) .LT. gppfrac_dormance * maxgppweek_lastyear(:,:) ) .OR. &
468: || ( ( when_growthinit(:,:) .GT. 2.*one_year ) .AND. &
469: || ( biomass(:,:,icarbres) .GT. biomass(:,:,ileaf)*4. ) ) )
470: ||
471: || time_lowgpp(:,:) = time_lowgpp(:,:) + dt
472: ||
473: || ELSEWHERE
474: ||
475: *W----- time_lowgpp(:,:) = 0.0
476:
477: ENDWHERE
478:
479: !
480: ! 7 growing degree days, threshold -5 deg C
481: !
482:
483: +------> DO j = 1, npft
484: |
485: | ! only for PFTs for which critical gdd is defined
486: | ! gdd_m5_dormance is set to 0 at the end of the growing season. It is set to undef
487: | ! at the beginning of the growing season.
488: |
489: |*===== IF ( ALL(pheno_crit%gdd(j,:) .NE. undef) ) THEN
490: |
491: | !
492: | ! 7.1 set to zero if undef and no gpp
493: | !
494: |
495: |V-----> WHERE ( ( time_lowgpp(:,j) .GT. 0.0 ) .AND. ( gdd_m5_dormance(:,j) .EQ. undef ) )
496: ||
497: |V----- gdd_m5_dormance(:,j) = 0.0
498: |
499: | ENDWHERE
500: |
501: | !
502: | ! 7.2 set to undef if there is gpp
503: | !
504: |
505: |V-----> WHERE ( time_lowgpp(:,j) .EQ. 0.0 )
506: ||
507: |V----- gdd_m5_dormance(:,j) = undef
508: |
509: | ENDWHERE
510: |
511: | !
512: | ! 7.3 normal update where gdd_m5_dormance is defined
513: | !
514: |
515: |V-----> WHERE ( ( t2m_daily(:) .GT. (ZeroCelsius-5.) ) .AND. &
516: || ( gdd_m5_dormance(:,j) .NE. undef ) )
517: |V----- gdd_m5_dormance(:,j) = gdd_m5_dormance(:,j) + &
518: | dt * ( t2m_daily(:) - (ZeroCelsius-5.) )
519: | ENDWHERE
520: |
521: |V-----> WHERE ( gdd_m5_dormance(:,j) .NE. undef )
522: |V----- gdd_m5_dormance(:,j) = gdd_m5_dormance(:,j) * &
523: | ( pheno_crit%tau_gdd - dt ) / pheno_crit%tau_gdd
524: | ENDWHERE
525: |
526: | ENDIF
527: |
528: +------ ENDDO
529:
530: *W-----> WHERE ( ABS(gdd_m5_dormance(:,:)) .LT. EPSILON(0.) )
531: *W----- gdd_m5_dormance(:,:) = 0.
532: ENDWHERE
533:
534: !
535: ! 8 growing degree days since midwinter
536: !
537:
538: +------> DO j = 1, npft
539: |
540: | ! only for PFTs for which ncdgdd_crittemp is defined
541: |
542: | IF ( pheno_crit%ncdgdd_temp(j) .NE. undef ) THEN
543: |
544: | !
545: | ! 8.1 set to 0 if undef and if we detect "midwinter"
546: | !
547: |
548: |V-----> WHERE ( ( gdd_midwinter(:,j) .EQ. undef ) .AND. &
549: || ( t2m_month(:) .LT. t2m_week(:) ) .AND. &
550: || ( t2m_month(:) .LT. t2m_longterm(:) ) )
551: ||
552: |V----- gdd_midwinter(:,j) = 0.0
553: |
554: | ENDWHERE
555: |
556: | !
557: | ! 8.2 set to undef if we detect "midsummer"
558: | !
559: |
560: |V-----> WHERE ( ( t2m_month(:) .GT. t2m_week(:) ) .AND. &
561: || ( t2m_month(:) .GT. t2m_longterm(:) ) )
562: ||
563: |V----- gdd_midwinter(:,j) = undef
564: |
565: | ENDWHERE
566: |
567: | !
568: | ! 8.3 normal update
569: | !
570: |
571: |V-----> WHERE ( ( gdd_midwinter(:,j) .NE. undef ) .AND. &
572: || ( t2m_daily(:) .GT. pheno_crit%ncdgdd_temp(j)+ZeroCelsius ) )
573: ||
574: |V----- gdd_midwinter(:,j) = &
575: | gdd_midwinter(:,j) + &
576: | dt * ( t2m_daily(:) - ( pheno_crit%ncdgdd_temp(j)+ZeroCelsius ) )
577: |
578: | ENDWHERE
579: |
580: | ENDIF
581: |
582: +------ ENDDO
583:
584: !
585: ! 9 number of chilling days since leaves were lost
586: !
587:
588: +------> DO j = 1, npft
589: |
590: | IF ( pheno_crit%ncdgdd_temp(j) .NE. undef ) THEN
591: |
592: | !
593: | ! 9.1 set to zero if undef and no gpp
594: | !
595: |
596: |V-----> WHERE ( ( time_lowgpp(:,j) .GT. 0.0 ) .AND. ( ncd_dormance(:,j) .EQ. undef ) )
597: ||
598: |V----- ncd_dormance(:,j) = 0.0
599: |
600: | ENDWHERE
601: |
602: | !
603: | ! 9.2 set to undef if there is gpp
604: | !
605: |
606: |V-----> WHERE ( time_lowgpp(:,j) .EQ. 0.0 )
607: ||
608: |V----- ncd_dormance(:,j) = undef
609: |
610: | ENDWHERE
611: |
612: | !
613: | ! 9.3 normal update where ncd_dormance is defined
614: | !
615: |
616: |V-----> WHERE ( ( ncd_dormance(:,j) .NE. undef ) .AND. &
617: || ( t2m_daily(:) .LE. pheno_crit%ncdgdd_temp(j)+ZeroCelsius ) )
618: ||
619: |V----- ncd_dormance(:,j) = MIN( ncd_dormance(:,j) + dt, ncd_max )
620: |
621: | ENDWHERE
622: |
623: | ENDIF
624: |
625: +------ ENDDO
626:
627: !
628: ! 10 number of growing days, threshold -5 deg C
629: !
630:
631: +------> DO j = 1, npft
632: |
633: | !
634: | ! 10.1 Where there is GPP, set ngd to 0
635: | ! This means that we only take into account ngds when the leaves are off
636: | !
637: |
638: |V-----> WHERE ( time_lowgpp(:,j) .LT. min_stomate )
639: |V----- ngd_minus5(:,j) = 0.0
640: | ENDWHERE
641: |
642: | !
643: | ! 10.2 normal update
644: | !
645: |
646: |V-----> WHERE ( t2m_daily(:) .GT. (ZeroCelsius-5.) )
647: |V----- ngd_minus5(:,j) = ngd_minus5(:,j) + dt
648: | ENDWHERE
649: |
650: |V===== ngd_minus5(:,j) = ngd_minus5(:,j) * ( pheno_crit%tau_ngd - dt ) / pheno_crit%tau_ngd
651: |
652: +------ ENDDO
653:
654: *W-----> WHERE ( ABS(ngd_minus5(:,:)) .LT. EPSILON(0.) )
655: *W----- ngd_minus5(:,:) = 0.
656: ENDWHERE
657:
658: !
659: ! 11 minimum humidity since dormance began and time elapsed since this minimum
660: !
661:
662: +------> DO j = 1, npft
663: |
664: | IF ( pheno_crit%hum_min_time(j) .NE. undef ) THEN
665: |
666: | !
667: | ! 11.1 initialize if undef and no gpp
668: | !
669: |
670: |V-----> WHERE ( ( time_lowgpp(:,j) .GT. 0.0 ) .AND. &
671: || ( ( time_hum_min(:,j) .EQ. undef ) .OR. ( hum_min_dormance(:,j) .EQ. undef ) ) )
672: ||
673: || time_hum_min(:,j) = 0.0
674: |V----- hum_min_dormance(:,j) = moiavail_month(:,j)
675: |
676: | ENDWHERE
677: |
678: | !
679: | ! 11.2 set to undef where there is gpp
680: | !
681: |
682: |V-----> WHERE ( time_lowgpp(:,j) .EQ. 0.0 )
683: ||
684: || time_hum_min(:,j) = undef
685: |V----- hum_min_dormance(:,j) = undef
686: |
687: | ENDWHERE
688: |
689: | !
690: | ! 11.3 normal update where time_hum_min and hum_min_dormance are defined
691: | !
692: |
693: | ! 11.3.1 increase time counter
694: |
695: |V-----> WHERE ( ( time_hum_min(:,j) .NE. undef ) .AND. &
696: || ( hum_min_dormance(:,j) .NE. undef ) )
697: ||
698: |V----- time_hum_min(:,j) = time_hum_min(:,j) + dt
699: |
700: | ENDWHERE
701: |
702: | ! 11.3.2 set time to zero if minimum is reached
703: |
704: |V-----> WHERE ( ( time_hum_min(:,j) .NE. undef ) .AND. &
705: || ( hum_min_dormance(:,j) .NE. undef ) .AND. &
706: || ( moiavail_month(:,j) .LE. hum_min_dormance(:,j) ) )
707: ||
708: || hum_min_dormance(:,j) = moiavail_month(:,j)
709: |V----- time_hum_min(:,j) = 0.0
710: |
711: | ENDWHERE
712: |
713: | ENDIF
714: |
715: +------ ENDDO
716:
717: !
718: ! 12 "long term" NPP. npp_daily in gC/m**2/day, npp_longterm in gC/m**2/year.
719: !
720:
721: W*===== npp_longterm = ( npp_longterm * ( pheno_crit%tau_longterm - dt ) + &
722: (npp_daily*one_year) * dt ) / &
723: pheno_crit%tau_longterm
724:
725: *W-----> WHERE ( ABS(npp_longterm(:,:)) .LT. EPSILON(0.) )
726: *W----- npp_longterm(:,:) = 0.
727: ENDWHERE
728:
729: !
730: ! 13 "long term" turnover rates, in gC/m**2/year.
731: !
732:
733: W**==== turnover_longterm = ( turnover_longterm * ( pheno_crit%tau_longterm - dt ) + &
734: (turnover_daily*one_year) * dt ) / &
735: pheno_crit%tau_longterm
736:
737: **W----> WHERE ( ABS(turnover_longterm(:,:,:)) .LT. EPSILON(0.) )
738: **W---- turnover_longterm(:,:,:) = 0.
739: ENDWHERE
740:
741: !
742: ! 14 "weekly" GPP, in gC/(m**2 covered)/day (!)
743: ! i.e. divide daily gpp (in gC/m**2 of total ground/day) by vegetation fraction
744: ! (m**2 covered/m**2 of total ground)
745: !
746:
747: *W-----> WHERE ( veget_max .GT. 0.0 )
748: ||
749: || gpp_week = ( gpp_week * ( pheno_crit%tau_gpp_week - dt ) + &
750: || gpp_daily/veget_max * dt ) / pheno_crit%tau_gpp_week
751: ||
752: || ELSEWHERE
753: ||
754: *W----- gpp_week = 0.0
755:
756: ENDWHERE
757:
758: *W-----> WHERE ( ABS(gpp_week(:,:)) .LT. EPSILON(0.) )
759: *W----- gpp_week(:,:) = 0.
760: ENDWHERE
761:
762: !
763: ! 15 maximum and minimum moisture availabilities
764: !
765:
766: *W-----> WHERE ( moiavail_daily .GT. maxmoiavail_thisyear )
767: *W----- maxmoiavail_thisyear = moiavail_daily
768: ENDWHERE
769:
770: *W-----> WHERE ( moiavail_daily .LT. minmoiavail_thisyear )
771: *W----- minmoiavail_thisyear = moiavail_daily
772: ENDWHERE
773:
774: !
775: ! 16 annual maximum weekly GPP
776: !
777:
778: *W-----> WHERE ( gpp_week .GT. maxgppweek_thisyear )
779: *W----- maxgppweek_thisyear = gpp_week
780: ENDWHERE
781:
782: !
783: ! 17 annual GDD0
784: !
785:
786: V------> WHERE ( t2m_daily .GT. ZeroCelsius )
787: V------ gdd0_thisyear = gdd0_thisyear + dt * ( t2m_daily - ZeroCelsius )
788: ENDWHERE
789:
790: !
791: ! 18 annual precipitation
792: !
793:
794: V====== precip_thisyear = precip_thisyear + dt * precip_daily
795:
796: !
797: ! 19 annual maximum leaf mass
798: ! If STOMATE is not activated, this corresponds to the maximum possible
799: ! LAI of the PFT
800: !
801:
802: IF ( control%ok_stomate ) THEN
803:
804: *V-----> WHERE ( biomass(:,:,ileaf) .GT. lm_thisyearmax(:,:) )
805: *V----- lm_thisyearmax(:,:) = biomass(:,:,ileaf)
806: ENDWHERE
807:
808: ELSE
809:
810: +------> DO j = 1, npft
811: |V===== lm_thisyearmax(:,j) = lai_max(j) * veget_max(:,j) / sla(j)
812: +------ ENDDO
813:
814: ENDIF
815:
816: !
817: ! 20 annual maximum fpc for each PFT
818: ! "veget" is defined as fraction of total ground. Therefore, maxfpc_thisyear has
819: ! the same unit.
820: !
821:
822: *W-----> WHERE ( veget(:,:) .GT. maxfpc_thisyear(:,:) )
823: *W----- maxfpc_thisyear(:,:) = veget(:,:)
824: ENDWHERE
825:
826: !
827: ! 21 Every year, replace last year's maximum and minimum moisture availability,
828: ! annual GDD0, annual precipitation, annual max weekly GPP, and maximum leaf mass
829:
830: IF ( EndOfYear ) THEN
831:
832: !
833: ! 21.1 replace old values
834: !
835:
836: *W-----> maxmoiavail_lastyear(:,:) = maxmoiavail_thisyear(:,:)
837: || minmoiavail_lastyear(:,:) = minmoiavail_thisyear(:,:)
838: ||
839: *W----- maxgppweek_lastyear(:,:) = maxgppweek_thisyear(:,:)
840:
841: V------> gdd0_lastyear(:) = gdd0_thisyear(:)
842: |
843: V------ precip_lastyear(:) = precip_thisyear(:)
844:
845: *W-----> lm_lastyearmax(:,:) = lm_thisyearmax(:,:)
846: ||
847: || maxfpc_lastyear(:,:) = maxfpc_thisyear(:,:)
848: ||
849: || !
850: || ! 21.2 reset new values
851: || !
852: ||
853: || maxmoiavail_thisyear(:,:) = 0.0
854: || minmoiavail_thisyear(:,:) = large_value
855: ||
856: *W----- maxgppweek_thisyear(:,:) = 0.0
857:
858: V------> gdd0_thisyear(:) = 0.0
859: |
860: V------ precip_thisyear(:) = 0.0
861:
862: *W-----> lm_thisyearmax(:,:) = 0.0
863: ||
864: *W----- maxfpc_thisyear(:,:) = 0.0
865:
866: !
867: ! 21.3 Special treatment for maxfpc.
868: !
869:
870: !
871: ! 21.3.1 Only take into account natural PFTs
872: !
873:
874: +------> DO j = 1, npft
875: | IF ( .NOT. natural(j) ) THEN
876: |V===== maxfpc_lastyear(:,j) = 0.0
877: | ENDIF
878: +------ ENDDO
879:
880: ! 21.3.2 In Stomate, veget is defined as a fraction of nat/agri ground, not as a fraction
881: ! of total ground. maxfpc_lastyear will be compared to veget in lpj_light.
882: ! Therefore, we have to transform maxfpc_lastyear.
883: ! * There may be problems if space_nat has changed during the year !!! *
884:
885: CALL natagritot (npts, ito_natagri, space_nat, maxfpc_lastyear)
886:
887: ! 21.3.3 The sum of the maxfpc_lastyear for natural PFT must not exceed fpc_crit (=.95).
888: ! However, it can slightly exceed this value as not all PFTs reach their maximum
889: ! fpc at the same time. Therefore, if sum(maxfpc_lastyear) for the natural PFTs
890: ! exceeds fpc_crit, we scale the values of maxfpc_lastyear so that the sum is
891: ! fpc_crit.
892:
893: ! calculate the sum of maxfpc_lastyear
894: V====== sumfpc_nat(:) = 0.0
895: +------> DO j = 1, npft
896: |V===== sumfpc_nat(:) = sumfpc_nat(:) + maxfpc_lastyear(:,j)
897: +------ ENDDO
898:
899: ! scale so that the new sum is fpc_crit
900: +------> DO j = 1, npft
901: |V-----> WHERE ( sumfpc_nat(:) .GT. fpc_crit )
902: |V----- maxfpc_lastyear(:,j) = maxfpc_lastyear(:,j) * (fpc_crit/sumfpc_nat(:))
903: | ENDWHERE
904: +------ ENDDO
905:
906: ENDIF ! EndOfYear
907:
908: !
909: ! 22 diagnose herbivore activity, determined through as probability for a leaf to be
910: ! eaten in a day
911: ! Follows McNaughton et al., Nat 341, 142-144, 1989.
912: !
913:
914: !
915: ! 22.1 first calculate mean long-term leaf NPP in grid box, mean residence
916: ! time (years) of green tissue (i.e. tissue that will be eaten by
917: ! herbivores) (crudely approximated: 6 months for seasonal and 2 years
918: ! for evergreen) and mean length of growing season (6 months for
919: ! seasonal and 1 year for evergreen).
920: !
921:
922: V------> nlflong_nat(:) = 0.
923: | weighttot(:) = 0.
924: V------ green_age(:) = 0.
925: !
926: +------> DO j = 1, npft
927: | !
928: | IF ( natural(j) ) THEN
929: | !
930: |V-----> weighttot(:) = weighttot(:) + lm_lastyearmax(:,j)
931: |V----- nlflong_nat(:) = nlflong_nat(:) + npp_longterm(:,j) * leaf_frac
932: | !
933: | IF ( pheno_crit%pheno_model(j) .EQ. 'none' ) THEN
934: |V===== green_age(:) = green_age(:) + 2. * lm_lastyearmax(:,j)
935: | ELSE
936: |V===== green_age(:) = green_age(:) + .5 * lm_lastyearmax(:,j)
937: | ENDIF
938: | !
939: | ENDIF
940: | !
941: +------ ENDDO
942: !
943: V------> WHERE ( weighttot(:) .GT. zero )
944: | green_age(:) = green_age(:) / weighttot(:)
945: | ELSEWHERE
946: V------ green_age(:) = 1.
947: ENDWHERE
948:
949: !
950: ! 22.2 McNaughton et al. give herbivore consumption as a function of annual leaf NPP.
951: ! The annual leaf NPP can give us an idea about the edible biomass:
952: !
953:
954: +------> DO j = 1, npft
955: | !
956: | IF ( natural(j) ) THEN
957: | !
958: |V-----> WHERE ( nlflong_nat(:) .GT. zero )
959: || consumption(:) = hvc1 * nlflong_nat(:) ** hvc2
960: || herbivores(:,j) = one_year * green_age(:) * nlflong_nat(:) / consumption(:)
961: || ELSEWHERE
962: |V----- herbivores(:,j) = 100000.
963: | ENDWHERE
964: | !
965: | ELSE
966: | !
967: |V===== herbivores(:,j) = 100000.
968: | !
969: | ENDIF
970: | !
971: +------ ENDDO
972:
973: IF (bavard.GE.4) WRITE(numout,*) 'Leaving season'
974:
975: END SUBROUTINE season
976:
977: END MODULE stomate_season
ORCHIDEE/src_stomate/i.stomate_soilcarbon.L 0000754 0103600 0005670 00000032600 11164403473 020504 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:39 2008
FILE NAME: i.stomate_soilcarbon.f90
PROGRAM NAME: stomate_soilcarbon
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
85 obsol( 18): CHARACTER* form of character declaration is used.
106 vec ( 4): Vectorized array expression.
142 vec ( 3): Unvectorized loop.
142 vec ( 7): Iteration count is too small.
156 vec ( 4): Vectorized array expression.
156 vec ( 4): Vectorized array expression.
162 vec ( 4): Vectorized array expression.
162 vec ( 4): Vectorized array expression.
162 vec ( 4): Vectorized array expression.
162 vec ( 4): Vectorized array expression.
162 vec ( 4): Vectorized array expression.
162 vec ( 4): Vectorized array expression.
175 vec ( 4): Vectorized array expression.
175 vec ( 4): Vectorized array expression.
175 vec ( 4): Vectorized array expression.
186 vec ( 3): Unvectorized loop.
190 vec ( 4): Vectorized array expression.
194 opt (1019): Feedback of scalar value from one loop pass to another.
194 vec ( 4): Vectorized array expression.
199 vec ( 4): Vectorized array expression.
204 vec ( 4): Vectorized array expression.
204 vec ( 4): Vectorized array expression.
204 vec ( 4): Vectorized array expression.
213 vec ( 4): Vectorized array expression.
223 vec ( 4): Vectorized array expression.
223 vec ( 4): Vectorized array expression.
223 vec ( 4): Vectorized array expression.
234 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:39 2008
FILE NAME: i.stomate_soilcarbon.f90
PROGRAM NAME: stomate_soilcarbon
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: !
2: ! Soil dynamics. Essentially after Century.
3: ! FOR THE MOMENT, NO VERTICAL DISCRETISATION !!!!
4: !
5: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_soilcarbon.f90,v 1.6 2007/05/28 14:49:02 ssipsl Exp $
6: ! IPSL (2006)
7: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
8: !
9: MODULE stomate_soilcarbon
10:
11: ! modules used:
12:
13: USE ioipsl
14: USE stomate_constants
15:
16: IMPLICIT NONE
17:
18: ! private & public routines
19:
20: PRIVATE
21: PUBLIC soilcarbon,soilcarbon_clear
22:
23: ! first call
24: LOGICAL, SAVE :: firstcall = .TRUE.
25:
26: CONTAINS
27:
28:
29: SUBROUTINE soilcarbon_clear
30: firstcall=.TRUE.
31: ENDSUBROUTINE soilcarbon_clear
32:
33: SUBROUTINE soilcarbon (npts, dt, clay, space_nat, &
34: soilcarbon_input, control_temp, control_moist, &
35: carbon, &
36: resp_hetero_soil)
37:
38: !
39: ! 0 declarations
40: !
41:
42: ! 0.1 input
43:
44: ! Domain size
45: INTEGER(i_std), INTENT(in) :: npts
46: ! time step in days
47: REAL(r_std), INTENT(in) :: dt
48: ! clay fraction (between 0 and 1)
49: REAL(r_std), DIMENSION(npts), INTENT(in) :: clay
50: ! total natural space (fraction of total space)
51: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
52: ! quantity of carbon going into carbon pools from litter decomposition
53: ! (gC/(m**2 of nat/agri ground)/day)
54: REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(in) :: soilcarbon_input
55: ! temperature control of heterotrophic respiration
56: REAL(r_std), DIMENSION(npts,nlevs), INTENT(in) :: control_temp
57: ! moisture control of heterotrophic respiration
58: REAL(r_std), DIMENSION(npts,nlevs), INTENT(in) :: control_moist
59:
60: ! 0.2 modified fields
61:
62: ! carbon pool: active, slow, or passive, natural and agricultural (gC/m**2 of
63: ! natural or agricultural ground)
64: REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(inout) :: carbon
65:
66: ! 0.3 output
67:
68: ! soil heterotrophic respiration (first in gC/day/m**2 of natural/agricultural ground,
69: ! but output in gC/day/m**2 of total ground)
70: REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(out) :: resp_hetero_soil
71:
72: ! 0.4 local
73:
74: ! residence time in carbon pools (days)
75: REAL(r_std), SAVE, DIMENSION(ncarb) :: carbon_tau
76: ! flux fractions within carbon pools
77: REAL(r_std), DIMENSION(npts,ncarb,ncarb) :: frac_carb
78: ! fraction of carbon flux which goes into heterotrophic respiration
79: REAL(r_std), DIMENSION(npts,ncarb) :: frac_resp
80: ! total flux out of carbon pools (gC/m**2)
81: REAL(r_std), DIMENSION(npts,ncarb) :: fluxtot
82: ! fluxes between carbon pools (gC/m**2)
83: REAL(r_std), DIMENSION(npts,ncarb,ncarb) :: flux
84: ! for messages
85: CHARACTER*7, DIMENSION(ncarb) :: carbon_str
86: ! Indices
87: INTEGER(i_std) :: k,kk,m
88:
89: ! =========================================================================
90:
91: IF (bavard.GE.3) WRITE(numout,*) 'Entering soilcarbon'
92:
93: !
94: ! 1 initializations
95: !
96:
97: !
98: ! 1.1 get soil "constants"
99: !
100:
101: ! 1.1.1 flux fractions between carbon pools: depend on clay content, recalculated
102: ! each time
103:
104: ! 1.1.1.1 from active pool: depends on clay content
105:
106: V------> frac_carb(:,iactive,iactive) = 0.0
107: | frac_carb(:,iactive,ipassive) = 0.004
108: | frac_carb(:,iactive,islow) = 1. - (.85-.68*clay(:)) - frac_carb(:,iactive,ipassive)
109: |
110: | ! 1.1.1.2 from slow pool
111: |
112: | frac_carb(:,islow,islow) = .0
113: | frac_carb(:,islow,iactive) = .42
114: | frac_carb(:,islow,ipassive) = .03
115: |
116: | ! 1.1.1.3 from passive pool
117: |
118: | frac_carb(:,ipassive,ipassive) = .0
119: | frac_carb(:,ipassive,iactive) = .45
120: V------ frac_carb(:,ipassive,islow) = .0
121:
122:
123: IF ( firstcall ) THEN
124:
125: ! 1.1.2 residence times in carbon pools (days)
126:
127: carbon_tau(iactive) = .149 * one_year !!!!???? 1.5 years
128: carbon_tau(islow) = 5.48 * one_year !!!!???? 25 years
129: carbon_tau(ipassive) = 241. * one_year !!!!???? 1000 years
130:
131: !
132: ! 1.2 messages
133: !
134:
135: carbon_str(iactive) = 'active'
136: carbon_str(islow) = 'slow'
137: carbon_str(ipassive) = 'passive'
138:
139: WRITE(numout,*) 'soilcarbon:'
140:
141: WRITE(numout,*) ' > minimal carbon residence time in carbon pools (d):'
142: +------> DO k = 1, ncarb
143: | WRITE(numout,*) ' ',carbon_str(k),':',carbon_tau(k)
144: +------ ENDDO
145:
146: WRITE(numout,*) ' > flux fractions between carbon pools: depend on clay content'
147:
148: firstcall = .FALSE.
149:
150: ENDIF
151:
152: !
153: ! 1.3 set output to zero
154: !
155:
156: +V===== resp_hetero_soil(:,:) = 0.0
157:
158: !
159: ! 2 input into carbon pools
160: !
161:
162: ++V==== carbon(:,:,:) = carbon(:,:,:) + soilcarbon_input(:,:,:) * dt
163:
164: !
165: ! 3 fluxes within carbon reservoirs + respiration
166: !
167:
168: !
169: ! 3.1 determine fraction of flux that is respiration
170: ! diagonal elements of frac_carb are zero
171: ! VPP killer:
172: ! frac_resp(:,:) = 1. - SUM( frac_carb(:,:,:), DIM=3 )
173: !
174:
175: +V===== frac_resp(:,:) = 1. - frac_carb(:,:,iactive) - frac_carb(:,:,islow) - &
176: frac_carb(:,:,ipassive)
177:
178: !
179: ! 3.2 calculate fluxes
180: !
181:
182: +------> DO m = 1, nvegtypes
183: |
184: | ! 3.2.1 flux out of pools
185: |
186: |+-----> DO k = 1, ncarb
187: ||
188: || ! determine total flux out of pool
189: ||
190: ||V==== fluxtot(:,k) = dt/carbon_tau(k) * carbon(:,k,m) * &
191: || control_moist(:,ibelow) * control_temp(:,ibelow)
192: ||
193: || IF ( k .EQ. iactive ) THEN
194: ||V==== fluxtot(:,k) = fluxtot(:,k) * ( 1. - .75 * clay(:) )
195: || ENDIF
196: ||
197: || ! decrease this carbon pool
198: ||
199: ||V==== carbon(:,k,m) = carbon(:,k,m) - fluxtot(:,k)
200: ||
201: || ! fluxes towards the other pools (k -> kk)
202: ||
203: ||+----> DO kk = 1, ncarb
204: |||V=== flux(:,k,kk) = frac_carb(:,k,kk) * fluxtot(:,k)
205: ||+---- ENDDO
206: ||
207: |+----- ENDDO
208: |
209: | ! 3.2.2 respiration
210: | ! VPP killer:
211: | ! resp_hetero_soil(:,m) = SUM( frac_resp(:,:) * fluxtot(:,:), DIM=2 ) / dt
212: |
213: |V===== resp_hetero_soil(:,m) = &
214: | ( frac_resp(:,iactive) * fluxtot(:,iactive) + &
215: | frac_resp(:,islow) * fluxtot(:,islow) + &
216: | frac_resp(:,ipassive) * fluxtot(:,ipassive) ) / dt
217: |
218: | ! 3.2.3 add fluxes to active, slow, and passive pools
219: | ! VPP killer:
220: | ! carbon(:,:,m) = carbon(:,:,m) + SUM( flux(:,:,:), DIM=2 )
221: |
222: |+-----> DO k = 1, ncarb
223: ||V==== carbon(:,k,m) = carbon(:,k,m) + &
224: || flux(:,iactive,k) + flux(:,ipassive,k) + flux(:,islow,k)
225: |+----- ENDDO
226: |
227: +------ ENDDO
228:
229: !
230: ! 4 transform respiration from gC/day/(m**2 of nat/agri ground) to
231: ! gC/day/(m**2 of total ground), as it goes into the atmosphere.
232: !
233:
234: V------> resp_hetero_soil(:,iagri) = resp_hetero_soil(:,iagri) * ( 1. - space_nat(:) )
235: V------ resp_hetero_soil(:,inat) = resp_hetero_soil(:,inat) * ( space_nat(:) )
236:
237: IF (bavard.GE.4) WRITE(numout,*) 'Leaving soilcarbon'
238:
239: END SUBROUTINE soilcarbon
240:
241: END MODULE stomate_soilcarbon
ORCHIDEE/src_stomate/i.stomate_turnover.L 0000754 0103600 0005670 00000120135 11164403473 020236 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:41 2008
FILE NAME: i.stomate_turnover.f90
PROGRAM NAME: stomate_turnover
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
155 opt (1593): Loop nest collapsed into one loop.
155 vec ( 4): Vectorized array expression.
156 vec ( 4): Vectorized array expression.
164 opt (1592): Outer loop unrolled inside inner loop.
167 opt (1592): Outer loop unrolled inside inner loop.
167 vec ( 4): Vectorized array expression.
167 vec ( 4): Vectorized array expression.
167 vec ( 4): Vectorized array expression.
167 vec ( 4): Vectorized array expression.
175 vec ( 3): Unvectorized loop.
189 vec ( 4): Vectorized array expression.
194 vec ( 4): Vectorized array expression.
207 vec ( 4): Vectorized array expression.
213 vec ( 4): Vectorized array expression.
226 vec ( 4): Vectorized array expression.
238 vec ( 4): Vectorized array expression.
245 vec ( 4): Vectorized array expression.
246 vec ( 4): Vectorized array expression.
259 vec ( 4): Vectorized array expression.
262 vec ( 4): Vectorized array expression.
269 vec ( 4): Vectorized array expression.
294 vec ( 4): Vectorized array expression.
307 vec ( 4): Vectorized array expression.
318 vec ( 4): Vectorized array expression.
339 vec ( 4): Vectorized array expression.
342 vec ( 4): Vectorized array expression.
342 vec ( 4): Vectorized array expression.
342 vec ( 4): Vectorized array expression.
342 vec ( 4): Vectorized array expression.
353 vec ( 4): Vectorized array expression.
357 vec ( 3): Unvectorized loop.
358 vec ( 4): Vectorized array expression.
359 vec ( 4): Vectorized array expression.
361 opt (1059): Unable to determine last value of scalar temporary.
394 vec ( 4): Vectorized array expression.
402 vec ( 3): Unvectorized loop.
404 vec ( 4): Vectorized array expression.
406 opt (1059): Unable to determine last value of scalar temporary.
445 vec ( 4): Vectorized array expression.
448 opt (1592): Outer loop unrolled inside inner loop.
476 vec ( 3): Unvectorized loop.
476 vec ( 13): Overhead of loop division is too large.
478 opt (1033): Potential multiple store conflict -- use directive if OK.
478 vec ( 4): Vectorized array expression.
484 vec ( 18): Unvectorizable data type.
488 vec ( 4): Vectorized array expression.
491 opt (1036): Potential feedback - use directive if OK.
518 vec ( 4): Vectorized array expression.
548 vec ( 4): Vectorized array expression.
548 vec ( 4): Vectorized array expression.
548 vec ( 4): Vectorized array expression.
548 vec ( 4): Vectorized array expression.
569 vec ( 3): Unvectorized loop.
575 vec ( 4): Vectorized array expression.
591 opt (1097): This statement prevents loop optimization.
591 vec ( 4): Vectorized array expression.
593 vec ( 4): Vectorized array expression.
621 vec ( 3): Unvectorized loop.
621 vec ( 13): Overhead of loop division is too large.
625 vec ( 4): Vectorized array expression.
640 vec ( 3): Unvectorized loop.
640 vec ( 13): Overhead of loop division is too large.
647 vec ( 4): Vectorized array expression.
656 vec ( 4): Vectorized array expression.
676 vec ( 4): Vectorized array expression.
678 opt (1082): Backward transfers inhibit loop optimization.
678 vec ( 4): Vectorized array expression.
701 warn ( 83): Dummy argument "lai" is not used.
701 warn ( 83): Dummy argument "pftpresent" is not used.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:41 2008
FILE NAME: i.stomate_turnover.f90
PROGRAM NAME: stomate_turnover
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! This subroutine calculates:
2: ! 1-6 : leaf senescence, climatic and as a function of leaf age. New LAI.
3: ! 7 : herbivores
4: ! 8 : fruit turnover for trees.
5: ! 9 : sapwood conversion.
6: !
7: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_turnover.f90,v 1.11 2007/05/28 14:44:55 ssipsl Exp $
8: ! IPSL (2006)
9: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
10: !
11: MODULE stomate_turnover
12:
13: ! modules used:
14:
15: USE ioipsl
16: USE stomate_constants
17:
18: IMPLICIT NONE
19:
20: ! private & public routines
21:
22: PRIVATE
23: PUBLIC turn, turn_clear
24:
25: ! first call
26: LOGICAL, SAVE :: firstcall = .TRUE.
27:
28: CONTAINS
29:
30: SUBROUTINE turn_clear
31: firstcall=.TRUE.
32: END SUBROUTINE turn_clear
33:
34: SUBROUTINE turn (npts, dt, PFTpresent, &
35: herbivores, &
36: maxmoiavail_lastyear, minmoiavail_lastyear, &
37: moiavail_week, moiavail_month, tlong_ref, t2m_month, t2m_week, veget_max, &
38: leaf_age, leaf_frac, age, lai, biomass, &
39: turnover, senescence,turnover_time)
40:
41: !
42: ! 0 declarations
43: !
44:
45: ! 0.1 input
46:
47: ! Domain size
48: INTEGER(i_std), INTENT(in) :: npts
49: ! time step in days
50: REAL(r_std), INTENT(in) :: dt
51: ! PFT exists
52: LOGICAL, DIMENSION(npts,npft), INTENT(in) :: PFTpresent
53: ! time constant of probability of a leaf to be eaten by a herbivore (days)
54: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: herbivores
55: ! last year's maximum moisture availability
56: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
57: ! last year's minimum moisture availability
58: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
59: ! "weekly" moisture availability
60: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
61: ! "monthly" moisture availability
62: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
63: ! "long term" 2 meter reference temperatures (K)
64: REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
65: ! "monthly" 2-meter temperatures (K)
66: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
67: ! "weekly" 2 meter temperatures (K)
68: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
69: ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
70: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
71:
72: ! 0.2 modified fields
73:
74: ! age of the leaves (days)
75: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
76: ! fraction of leaves in leaf age class
77: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
78: ! age (years)
79: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
80: ! leaf area index
81: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: lai
82: ! biomass (gC/(m**2 of nat/agri ground))
83: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
84: ! turnover_time of grasse
85: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: turnover_time
86:
87: ! 0.3 output
88:
89: ! Turnover rates (gC/day/(m**2 of nat/agri ground))
90: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: turnover
91: ! is the plant senescent?
92: ! (interesting only for deciduous trees: carbohydrate reserve)
93: LOGICAL, DIMENSION(npts,npft), INTENT(out) :: senescence
94:
95: ! 0.4 local
96:
97: ! mean age of the leaves (days)
98: REAL(r_std), DIMENSION(npts,npft) :: leaf_meanage
99: ! Intermediate variable for turnover
100: REAL(r_std), DIMENSION(npts) :: dturnover
101: ! critical moisture availability, function of last year's moisture availability
102: REAL(r_std), DIMENSION(npts) :: moiavail_crit
103: ! long term annual mean temperature, C
104: REAL(r_std), DIMENSION(npts) :: tl
105: ! critical senescence temperature, function of long term annual temperature (K)
106: REAL(r_std), DIMENSION(npts) :: t_crit
107: ! shed the remaining leaves?
108: LOGICAL, DIMENSION(npts) :: shed_rest
109: ! Sapwood conversion (gC/day(m**2 of nat/agri ground))
110: REAL(r_std), DIMENSION(npts) :: sapconv
111: ! old heartwood mass (gC/(m**2 of nat/agri ground))
112: REAL(r_std), DIMENSION(npts) :: hw_old
113: ! new heartwood mass (gC/(m**2 of nat/agri ground))
114: REAL(r_std), DIMENSION(npts) :: hw_new
115: ! old leaf mass (gC/(m**2 of nat/agri ground))
116: REAL(r_std), DIMENSION(npts) :: lm_old
117: ! leaf mass change for each age class
118: REAL(r_std), DIMENSION(npts,nleafages) :: delta_lm
119: ! turnover rate
120: REAL(r_std), DIMENSION(npts) :: turnover_rate
121: ! critical leaf age (d)
122: REAL(r_std), DIMENSION(npts,npft) :: leaf_age_crit
123: ! instantaneous turnover time
124: REAL(r_std), DIMENSION(npts,npft) :: new_turnover_time
125: ! Index
126: INTEGER(i_std) :: j,m
127:
128: ! =========================================================================
129:
130: IF (bavard.GE.3) WRITE(numout,*) 'Entering turnover'
131:
132: !
133: ! 1 messages
134: !
135:
136: IF ( firstcall ) THEN
137:
138: WRITE(numout,*) 'turnover:'
139:
140: WRITE(numout,*) ' > minimum mean leaf age for senescence (d): ',pheno_crit%min_leaf_age_for_senescence
141:
142: firstcall = .FALSE.
143:
144:
145: ENDIF
146:
147: !
148: ! 2 Initializations
149: !
150:
151: !
152: ! 2.1 set output to zero
153: !
154:
155: W**==== turnover(:,:,:) = 0.0
156: *V-----> new_turnover_time=0.0
157: || senescence(:,:) = .FALSE.
158: ||
159: || !
160: || ! 2.2 mean leaf age. Should actually be recalculated at the end of this routine,
161: || ! but it does not change too fast.
162: || !
163: ||
164: *V----- leaf_meanage(:,:) = 0.0
165:
166: +------> DO m = 1, nleafages
167: |+V==== leaf_meanage(:,:) = leaf_meanage(:,:) + leaf_age(:,:,m) * leaf_frac(:,:,m)
168: +------ ENDDO
169:
170: !
171: ! 3 different types of "climatic" leaf senescence
172: ! does not change age structure.
173: !
174:
175: +------> DO j = 1, npft
176: |
177: | !
178: | ! 3.1 determine if there is climatic senescence
179: | !
180: |
181: | SELECT CASE ( pheno_crit%senescence_type(j) )
182: |
183: | CASE ( 'cold' )
184: |
185: | ! 3.1.1 summergreen species:
186: | ! monthly temperature low and temperature tendency negative ?
187: |
188: | ! critical temperature for senescence may depend on long term annual mean temperature
189: |V-----> tl(:) = tlong_ref(:) - ZeroCelsius
190: |V----- t_crit(:) = ZeroCelsius + pheno_crit%senescence_temp(j,1) + &
191: | tl(:) * pheno_crit%senescence_temp(j,2) + &
192: | tl(:)*tl(:) * pheno_crit%senescence_temp(j,3)
193: |
194: |V-----> WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. &
195: || ( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ) .AND. &
196: || ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) )
197: ||
198: |V----- senescence(:,j) = .TRUE.
199: |
200: | ENDWHERE
201: |
202: | CASE ( 'dry' )
203: |
204: | ! 3.1.2 raingreen species:
205: | ! does moisture availability drop below critical level?
206: |
207: |V===== moiavail_crit(:) = &
208: | MIN( MAX( minmoiavail_lastyear(:,j) + pheno_crit%hum_frac(j) * &
209: | ( maxmoiavail_lastyear(:,j) - minmoiavail_lastyear(:,j) ), &
210: | pheno_crit%senescence_hum(j) ), &
211: | pheno_crit%nosenescence_hum(j) )
212: |
213: |V-----> WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. &
214: || ( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ) .AND. &
215: || ( moiavail_week(:,j) .LT. moiavail_crit(:) ) )
216: ||
217: |V----- senescence(:,j) = .TRUE.
218: |
219: | ENDWHERE
220: |
221: | CASE ( 'mixed' )
222: |
223: | ! 3.1.3 mixed criterion:
224: | ! moisture availability drops below critical level, or
225: | ! monthly temperature low and temperature tendency negative
226: |V-----> moiavail_crit(:) = &
227: || MIN( MAX( minmoiavail_lastyear(:,j) + pheno_crit%hum_frac(j) * &
228: || ( maxmoiavail_lastyear(:,j) - minmoiavail_lastyear(:,j) ), &
229: || pheno_crit%senescence_hum(j) ), &
230: || pheno_crit%nosenescence_hum(j) )
231: || tl(:) = tlong_ref(:) - ZeroCelsius
232: |V----- t_crit(:) = ZeroCelsius + pheno_crit%senescence_temp(j,1) + &
233: | tl(:) * pheno_crit%senescence_temp(j,2) + &
234: | tl(:)*tl(:) * pheno_crit%senescence_temp(j,3)
235: | IF ( tree(j) ) THEN
236: |
237: | ! critical temperature for senescence may depend on long term annual mean temperature
238: |V-----> WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. &
239: || ( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ) .AND. &
240: || ( ( moiavail_week(:,j) .LT. moiavail_crit(:) ) .OR. &
241: || ( ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) ) ) )
242: |V----- senescence(:,j) = .TRUE.
243: | ENDWHERE
244: | ELSE
245: |V===== new_turnover_time(:,j)=pheno_crit%max_turnover_time(j)+20
246: |V-----> WHERE ((moiavail_week(:,j) .LT. moiavail_month(:,j))&
247: || .AND. (moiavail_week(:,j) .LT. pheno_crit%nosenescence_hum(j)))
248: |V----- new_turnover_time(:,j)=pheno_crit%max_turnover_time(j) * &
249: | & moiavail_week(:,j)/ pheno_crit%nosenescence_hum(j) + &
250: | & pheno_crit%min_turnover_time(j)
251: | ENDWHERE
252: | ! WHERE ((t2m_month(:) .LT. t_crit(:)+5) .AND. ( t2m_week(:) .LT. t2m_month(:) ))
253: | ! new_turnover_time(:,j)=new_turnover_time(:,j)*((t2m_month(:)-t_crit(:))/5*0.4+0.6)
254: | ! ENDWHERE
255: | ! WHERE (new_turnover_time(:,j) .LT. pheno_crit%min_turnover_time(j))
256: | ! new_turnover_time(:,j)=pheno_crit%min_turnover_time(j)
257: | ! ENDWHERE
258: |
259: |V-----> WHERE (new_turnover_time(:,j) .GT. turnover_time(:,j)*1.1)
260: |V----- new_turnover_time(:,j)=pheno_crit%max_turnover_time(j)+20
261: | ENDWHERE
262: |V-----> WHERE ( ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) &
263: || & .AND. ( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ))
264: |V----- new_turnover_time(:,j)=pheno_crit%min_turnover_time(j)
265: | ENDWHERE
266: | ! print *,'t_crit=',t_crit
267: |
268: |
269: |V===== turnover_time(:,j)=(turnover_time(:,j)*10./dt+new_turnover_time(:,j))/(10./dt+1.)
270: |
271: | ENDIF
272: |
273: | CASE ( 'none' )
274: |
275: | ! evergreen species: no climatic senescence
276: |
277: | CASE default
278: |
279: | WRITE(numout,*) 'turnover: don''t know how to treat this PFT.'
280: | WRITE(numout,*) ' number: ',j
281: | WRITE(numout,*) ' senescence type: ',pheno_crit%senescence_type(j)
282: | STOP
283: |
284: | END SELECT
285: |
286: | !
287: | ! 3.2 drop leaves and roots, plus stems and fruits for grasses
288: | !
289: |
290: | IF ( tree(j) ) THEN
291: |
292: | ! 3.2.1 trees
293: |
294: |V-----> WHERE ( senescence(:,j) )
295: ||
296: || turnover(:,j,ileaf) = biomass(:,j,ileaf) * dt / pheno_crit%leaffall(j)
297: || turnover(:,j,iroot) = biomass(:,j,iroot) * dt / pheno_crit%leaffall(j)
298: ||
299: || biomass(:,j,ileaf) = biomass(:,j,ileaf) - turnover(:,j,ileaf)
300: |V----- biomass(:,j,iroot) = biomass(:,j,iroot) - turnover(:,j,iroot)
301: |
302: | ENDWHERE
303: |
304: | ELSE
305: |
306: | ! 3.2.2 grasses
307: |V-----> WHERE (turnover_time(:,j) .LT. pheno_crit%max_turnover_time(j))
308: || turnover(:,j,ileaf) = biomass(:,j,ileaf) * dt / turnover_time(:,j)
309: || turnover(:,j,isapabove) = biomass(:,j,isapabove) * dt / turnover_time(:,j)
310: || turnover(:,j,iroot) = biomass(:,j,iroot) * dt / turnover_time(:,j)
311: || turnover(:,j,ifruit) = biomass(:,j,ifruit) * dt / turnover_time(:,j)
312: || ELSEWHERE
313: || turnover(:,j,ileaf)=0.0
314: || turnover(:,j,isapabove) =0.0
315: || turnover(:,j,iroot) = 0.0
316: |V----- turnover(:,j,ifruit) =0.0
317: | ENDWHERE
318: |V-----> biomass(:,j,ileaf) = biomass(:,j,ileaf) - turnover(:,j,ileaf)
319: || biomass(:,j,isapabove) = biomass(:,j,isapabove) - turnover(:,j,isapabove)
320: || biomass(:,j,iroot) = biomass(:,j,iroot) - turnover(:,j,iroot)
321: |V----- biomass(:,j,ifruit) = biomass(:,j,ifruit) - turnover(:,j,ifruit)
322: |
323: | ENDIF ! tree/grass
324: |
325: +------ ENDDO ! loop over PFTs
326:
327: !
328: ! 4 At a certain age, leaves fall off, even if the climate would allow a green plant
329: ! all year round.
330: ! Decay rate varies with leaf age.
331: ! Roots, fruits (and stems) follow leaves.
332: ! Note that plant is not declared senescent in this case (important for allocation:
333: ! if the plant loses leaves because of their age, it can renew them).
334: !
335:
336: +------> DO j = 1, npft
337: |
338: | ! save old leaf mass
339: |V===== lm_old(:) = biomass(:,j,ileaf)
340: |
341: | ! initialize leaf mass change in age class
342: |+V==== delta_lm(:,:) = 0.0
343: |
344: | IF ( tree(j) ) THEN
345: |
346: | !
347: | ! 4.1 trees: leaves, roots, fruits
348: | ! roots and fruits follow leaves.
349: | !
350: |
351: | ! 4.1.1 critical age: prescribed for trees
352: |
353: |V===== leaf_age_crit(:,j) = pheno_crit%leafagecrit(j)
354: |
355: | ! 4.1.2 loop over leaf age classes
356: |
357: |+-----> DO m = 1, nleafages
358: ||V==== turnover_rate(:) =0
359: ||V----> WHERE ( leaf_age(:,j,m) .GT. leaf_age_crit(:,j)/2. )
360: |||
361: ||| turnover_rate(:) = &
362: ||| MIN( 0.99_r_std, dt / ( leaf_age_crit(:,j) * &
363: ||| ( leaf_age_crit(:,j) / leaf_age(:,j,m) )**4._r_std ) )
364: |||
365: ||| dturnover(:) = biomass(:,j,ileaf) * leaf_frac(:,j,m) * turnover_rate(:)
366: ||| turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
367: ||| biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
368: |||
369: ||| ! save leaf mass change
370: ||| delta_lm(:,m) = - dturnover(:)
371: |||
372: ||| dturnover(:) = biomass(:,j,iroot) * leaf_frac(:,j,m) * turnover_rate(:)
373: ||| turnover(:,j,iroot) = turnover(:,j,iroot) + dturnover(:)
374: ||| biomass(:,j,iroot) = biomass(:,j,iroot) - dturnover(:)
375: |||
376: ||| dturnover(:) = biomass(:,j,ifruit) * leaf_frac(:,j,m) * turnover_rate(:)
377: ||| turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
378: ||V---- biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
379: ||
380: || ENDWHERE
381: ||
382: |+----- ENDDO
383: |
384: | ELSE
385: |
386: | !
387: | ! 4.2 grasses: leaves, roots, fruits, sap.
388: | ! roots, fruits, and sap follow leaves.
389: | !
390: |
391: | ! 4.2.1 critical leaf age depends on long-term temperature:
392: | ! generally, lower turnover in cooler climates.
393: |
394: |V===== leaf_age_crit(:,j) = &
395: | MIN( pheno_crit%leafagecrit(j) * 1.5_r_std , &
396: | MAX( pheno_crit%leafagecrit(j) * 0.75_r_std, &
397: | pheno_crit%leafagecrit(j) - 10._r_std * &
398: | ( tlong_ref(:)-ZeroCelsius-20._r_std ) ) )
399: |
400: | ! 4.2.2 loop over leaf age classes
401: |
402: |+-----> DO m = 1, nleafages
403: ||
404: ||V----> WHERE ( leaf_age(:,j,m) .GT. leaf_age_crit(:,j)/2. )
405: |||
406: ||| turnover_rate(:) = &
407: ||| MIN( 0.99_r_std, dt / ( leaf_age_crit(:,j) * &
408: ||| ( leaf_age_crit(:,j) / leaf_age(:,j,m) )**4._r_std ) )
409: |||
410: ||| dturnover(:) = biomass(:,j,ileaf) * leaf_frac(:,j,m) * turnover_rate(:)
411: ||| turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
412: ||| biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
413: |||
414: ||| ! save leaf mass change
415: ||| delta_lm(:,m) = - dturnover(:)
416: |||
417: ||| dturnover(:) = biomass(:,j,isapabove) * leaf_frac(:,j,m) * turnover_rate(:)
418: ||| turnover(:,j,isapabove) = turnover(:,j,isapabove) + dturnover(:)
419: ||| biomass(:,j,isapabove) = biomass(:,j,isapabove) - dturnover(:)
420: |||
421: ||| dturnover(:) = biomass(:,j,iroot) * leaf_frac(:,j,m) * turnover_rate(:)
422: ||| turnover(:,j,iroot) = turnover(:,j,iroot) + dturnover(:)
423: ||| biomass(:,j,iroot) = biomass(:,j,iroot) - dturnover(:)
424: |||
425: ||| dturnover(:) = biomass(:,j,ifruit) * leaf_frac(:,j,m) * turnover_rate(:)
426: ||| turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
427: ||V---- biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
428: ||
429: || ENDWHERE
430: ||
431: ||
432: |+----- ENDDO
433: |
434: | ENDIF ! tree/grass ?
435: |
436: | !
437: | ! 4.3 recalculate fraction in each leaf age class
438: | ! new fraction = new leaf mass of that fraction / new total leaf mass
439: | ! = ( old fraction*old total leaf mass + biomass change of that fraction ) /
440: | ! new total leaf mass
441: | !
442: |
443: |*-----> DO m = 1, nleafages
444: ||
445: ||V----> WHERE ( biomass(:,j,ileaf) .GT. 0.0 )
446: ||| leaf_frac(:,j,m) = ( leaf_frac(:,j,m)*lm_old(:) + delta_lm(:,m) ) / biomass(:,j,ileaf)
447: ||| ELSEWHERE
448: ||V---- leaf_frac(:,j,m) = 0.0
449: || ENDWHERE
450: ||
451: |*----- ENDDO
452: |
453: +------ ENDDO ! loop over PFTs
454:
455: !
456: ! 5 new (provisional) lai
457: !
458:
459: ! DO j = 1, npft
460:
461: ! WHERE ( PFTpresent(:,j) )
462: ! lai(:,j) = biomass(:,j,ileaf) / veget_max(:,j) * sla(j)
463: ! ELSEWHERE
464: ! lai(:,j) = 0.0
465: ! ENDWHERE
466: !
467: ! ENDDO
468:
469: !
470: ! 6 definitely drop leaves if very low leaf mass during senescence.
471: ! Also drop fruits and loose fine roots.
472: ! Set lai to zero if necessary
473: ! Check whether leaf regrowth is immediately allowed.
474: !
475:
476: +------> DO j = 1, npft
477: |
478: |V===== shed_rest(:) = .FALSE.
479: |
480: | !
481: | ! 6.1 deciduous trees
482: | !
483: |
484: | IF ( tree(j) .AND. ( pheno_crit%senescence_type(j) .NE. 'none' ) ) THEN
485: |
486: | ! check whether we shed the remaining leaves
487: |
488: |V-----> WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. senescence(:,j) .AND. &
489: || ( biomass(:,j,ileaf) .LT. (pheno_crit%lai_initmin(j) / 2.)* veget_max(:,j)/sla(j) ) )
490: ||
491: || shed_rest(:) = .TRUE.
492: ||
493: || turnover(:,j,ileaf) = turnover(:,j,ileaf) + biomass(:,j,ileaf)
494: || turnover(:,j,iroot) = turnover(:,j,iroot) + biomass(:,j,iroot)
495: || turnover(:,j,ifruit) = turnover(:,j,ifruit) + biomass(:,j,ifruit)
496: ||
497: || biomass(:,j,ileaf) = 0.0
498: || biomass(:,j,iroot) = 0.0
499: || biomass(:,j,ifruit) = 0.0
500: ||
501: ||
502: ||
503: || ! reset leaf age
504: |V----- leaf_meanage(:,j) = 0.0
505: |
506: | ENDWHERE
507: |
508: | ENDIF
509: |
510: | !
511: | ! 6.2 grasses: also convert stems
512: | !
513: |
514: | IF ( .NOT. tree(j) ) THEN
515: |
516: | ! Shed the remaining leaves if LAI very low.
517: |
518: |V-----> WHERE ( ( biomass(:,j,ileaf) .GT. 0.0 ) .AND. senescence(:,j) .AND. &
519: || ( biomass(:,j,ileaf) .LT. (pheno_crit%lai_initmin(j) / 2.)* veget_max(:,j)/sla(j) ))
520: ||
521: || shed_rest(:) = .TRUE.
522: ||
523: || turnover(:,j,ileaf) = turnover(:,j,ileaf) + biomass(:,j,ileaf)
524: || turnover(:,j,isapabove) = turnover(:,j,isapabove) + biomass(:,j,isapabove)
525: || turnover(:,j,iroot) = turnover(:,j,iroot) + biomass(:,j,iroot)
526: || turnover(:,j,ifruit) = turnover(:,j,ifruit) + biomass(:,j,ifruit)
527: ||
528: || biomass(:,j,ileaf) = 0.0
529: || biomass(:,j,isapabove) = 0.0
530: || biomass(:,j,iroot) = 0.0
531: || biomass(:,j,ifruit) = 0.0
532: ||
533: ||
534: ||
535: || ! reset leaf age
536: |V----- leaf_meanage(:,j) = 0.0
537: |
538: | ENDWHERE
539: |
540: | ENDIF
541: |
542: | !
543: | ! 6.3 reset leaf age structure
544: | !
545: |
546: |*-----> DO m = 1, nleafages
547: ||
548: ||V----> WHERE ( shed_rest(:) )
549: |||
550: ||| leaf_age(:,j,m) = 0.0
551: ||V---- leaf_frac(:,j,m) = 0.0
552: ||
553: || ENDWHERE
554: ||
555: |*----- ENDDO
556: |
557: +------ ENDDO
558:
559: !
560: ! 7 Elephants, cows, gazelles. No lions.
561: ! Does not modify leaf age structure.
562: !
563:
564: IF ( ok_herbivores ) THEN
565:
566: ! herbivore activity allowed. Eat when there are leaves. Otherwise,
567: ! there won't be many fruits anyway.
568:
569: +------> DO j = 1, npft
570: |
571: | IF ( tree(j) ) THEN
572: |
573: | ! trees: only leaves and fruits are affected
574: |
575: |V-----> WHERE ( biomass(:,j,ileaf) .GT. 0.0 )
576: ||
577: || dturnover(:) = biomass(:,j,ileaf) * dt / herbivores(:,j)
578: || turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
579: || biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
580: ||
581: || dturnover(:) = biomass(:,j,ifruit) * dt / herbivores(:,j)
582: || turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
583: |V----- biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
584: |
585: | ENDWHERE
586: |
587: | ELSE
588: |
589: | ! grasses: the whole biomass above the ground: leaves, fruits, stems
590: |
591: |V===== WHERE ( biomass(:,j,ileaf) .GT. 0.0 )
592: |
593: |V-----> WHERE ( (herbivores(:,j) .GT. 0.01) .AND. (herbivores(:,j) .LT. 100000.) )
594: ||
595: || dturnover(:) = biomass(:,j,ileaf) * dt / herbivores(:,j)
596: || turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
597: || biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
598: ||
599: || dturnover(:) = biomass(:,j,isapabove) * dt / herbivores(:,j)
600: || turnover(:,j,isapabove) = turnover(:,j,isapabove) + dturnover(:)
601: || biomass(:,j,isapabove) = biomass(:,j,isapabove) - dturnover(:)
602: ||
603: || dturnover(:) = biomass(:,j,ifruit) * dt / herbivores(:,j)
604: || turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
605: |V----- biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
606: |
607: | ENDWHERE
608: |
609: | ENDWHERE
610: |
611: | ENDIF ! tree/grass?
612: |
613: +------ ENDDO ! loop over PFTs
614:
615: ENDIF
616:
617: !
618: ! 8 fruit turnover for trees
619: !
620:
621: +------> DO j = 1, npft
622: |
623: | IF ( tree(j) ) THEN
624: |
625: |V-----> dturnover(:) = biomass(:,j,ifruit) * dt / tau_fruit(j)
626: || turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
627: |V----- biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
628: | !!$ turnover(:,j,ifruit) = biomass(:,j,ifruit) * dt / tau_fruit(j)
629: | !!$ biomass(:,j,ifruit) = biomass(:,j,ifruit) - turnover(:,j,ifruit)
630: |
631: | ENDIF
632: |
633: +------ ENDDO
634:
635: !
636: ! 9 Conversion of sapwood to heartwood
637: ! This is not added to "turnover" as the biomass is not lost!
638: !
639:
640: +------> DO j = 1, npft
641: |
642: | IF ( tree(j) ) THEN
643: |
644: | ! for age calculations
645: |
646: | IF ( .NOT. control%ok_dgvm ) THEN
647: |V===== hw_old(:) = biomass(:,j,iheartabove) + biomass(:,j,iheartbelow)
648: | ENDIF
649: |
650: | !
651: | ! 9.1 Calculate the rate of conversion and update masses
652: | !
653: |
654: | ! above the ground
655: |
656: |V-----> sapconv(:) = biomass(:,j,isapabove) * dt / tau_sap(j)
657: || biomass(:,j,isapabove) = biomass(:,j,isapabove) - sapconv(:)
658: || biomass(:,j,iheartabove) = biomass(:,j,iheartabove) + sapconv(:)
659: ||
660: || ! below the ground
661: ||
662: || sapconv(:) = biomass(:,j,isapbelow) * dt / tau_sap(j)
663: || biomass(:,j,isapbelow) = biomass(:,j,isapbelow) - sapconv(:)
664: |V----- biomass(:,j,iheartbelow) = biomass(:,j,iheartbelow) + sapconv(:)
665: |
666: |
667: | !
668: | ! 9.2 If vegetation is not dynamic, identify the age of the heartwood
669: | ! to the age of the whole tree (otherwise, the age of the tree is
670: | ! treated in the establishment routine).
671: | ! Creation of new heartwood decreases the age of the plant.
672: | !
673: |
674: | IF ( .NOT. control%ok_dgvm ) THEN
675: |
676: |V===== hw_new(:) = biomass(:,j,iheartabove) + biomass(:,j,iheartbelow)
677: |
678: |V-----> WHERE ( hw_new(:) .GT. 0.0 )
679: ||
680: |V----- age(:,j) = age(:,j) * hw_old(:)/hw_new(:)
681: |
682: | ENDWHERE
683: |
684: | ENDIF
685: |
686: | ENDIF
687: |
688: +------ ENDDO
689:
690: !
691: ! history
692: !
693:
694: CALL histwrite (hist_id_stomate, 'LEAF_AGE', itime, &
695: leaf_meanage, npts*npft, horipft_index)
696: CALL histwrite (hist_id_stomate, 'HERBIVORES', itime, &
697: herbivores, npts*npft, horipft_index)
698:
699: IF (bavard.GE.4) WRITE(numout,*) 'Leaving turnover'
700:
701: END SUBROUTINE turn
702:
703: END MODULE stomate_turnover
ORCHIDEE/src_stomate/i.stomate_vmax.L 0000754 0103600 0005670 00000036563 11164403473 017340 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:42 2008
FILE NAME: i.stomate_vmax.f90
PROGRAM NAME: stomate_vmax
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
111 opt (1593): Loop nest collapsed into one loop.
111 vec ( 4): Vectorized array expression.
124 opt (1593): Loop nest collapsed into one loop.
124 vec ( 4): Vectorized array expression.
124 vec ( 4): Vectorized array expression.
124 vec ( 4): Vectorized array expression.
124 vec ( 4): Vectorized array expression.
137 vec ( 3): Unvectorized loop.
137 vec ( 13): Overhead of loop division is too large.
142 vec ( 4): Vectorized array expression.
147 vec ( 4): Vectorized array expression.
147 vec ( 4): Vectorized array expression.
147 vec ( 4): Vectorized array expression.
155 vec ( 4): Vectorized array expression.
155 vec ( 4): Vectorized array expression.
155 vec ( 4): Vectorized array expression.
155 vec ( 4): Vectorized array expression.
159 vec ( 4): Vectorized array expression.
159 vec ( 4): Vectorized array expression.
168 vec ( 4): Vectorized array expression.
178 vec ( 4): Vectorized array expression.
178 vec ( 4): Vectorized array expression.
178 vec ( 4): Vectorized array expression.
191 vec ( 4): Vectorized array expression.
191 vec ( 4): Vectorized array expression.
191 vec ( 4): Vectorized array expression.
204 vec ( 4): Vectorized array expression.
204 vec ( 4): Vectorized array expression.
204 vec ( 4): Vectorized array expression.
204 vec ( 4): Vectorized array expression.
209 vec ( 4): Vectorized array expression.
213 vec ( 4): Vectorized array expression.
213 vec ( 4): Vectorized array expression.
213 vec ( 4): Vectorized array expression.
213 vec ( 4): Vectorized array expression.
221 vec ( 4): Vectorized array expression.
221 vec ( 4): Vectorized array expression.
221 vec ( 4): Vectorized array expression.
221 vec ( 4): Vectorized array expression.
233 opt (1057): Complicated use of variable inhibits loop optimization.
239 vec ( 3): Unvectorized loop.
239 vec ( 13): Overhead of loop division is too large.
241 vec ( 4): Vectorized array expression.
255 vec ( 4): Vectorized array expression.
255 vec ( 4): Vectorized array expression.
255 vec ( 4): Vectorized array expression.
255 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:42 2008
FILE NAME: i.stomate_vmax.f90
PROGRAM NAME: stomate_vmax
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! calculates the leaf efficiency
2: !
3: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_vmax.f90,v 1.8 2007/05/28 14:49:02 ssipsl Exp $
4: ! IPSL (2006)
5: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
6: !
7: MODULE stomate_vmax
8:
9: ! modules used:
10:
11: USE ioipsl
12: USE stomate_constants
13:
14: IMPLICIT NONE
15:
16: ! private & public routines
17:
18: PRIVATE
19: PUBLIC vmax, vmax_clear
20:
21: ! first call
22: LOGICAL, SAVE :: firstcall = .TRUE.
23:
24: CONTAINS
25:
26: SUBROUTINE vmax_clear
27: firstcall=.TRUE.
28: END SUBROUTINE vmax_clear
29:
30: SUBROUTINE vmax (npts, dt, &
31: leaf_age, leaf_frac, &
32: vcmax, vjmax)
33:
34: !
35: ! 0 declarations
36: !
37:
38: ! 0.1 input
39:
40: ! Domain size
41: INTEGER(i_std), INTENT(in) :: npts
42: ! time step of Stomate in days
43: REAL(r_std), INTENT(in) :: dt
44:
45: ! 0.2 modified fields
46:
47: ! leaf age (days)
48: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
49: ! fraction of leaves in leaf age class
50: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
51:
52: ! 0.3 output
53:
54: ! Maximum rate of carboxylation
55: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: vcmax
56: ! Maximum rate of RUbp regeneration
57: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: vjmax
58:
59: ! 0.4 local
60:
61: ! offset (minimum relative vcmax)
62: REAL(r_std), PARAMETER :: vmax_offset = 0.3
63: ! leaf age at which vmax attains vcmax_opt (in fraction of critical leaf age)
64: REAL(r_std), PARAMETER :: leafage_firstmax = 0.03
65: ! leaf age at which vmax falls below vcmax_opt (in fraction of critical leaf age)
66: REAL(r_std), PARAMETER :: leafage_lastmax = 0.5
67: ! leaf age at which vmax attains its minimum (in fraction of critical leaf age)
68: REAL(r_std), PARAMETER :: leafage_old = 1.
69: ! leaf efficiency (vcmax/vcmax_opt)
70: REAL(r_std), DIMENSION(npts) :: leaf_efficiency
71: ! change of fraction of leaves in age class
72: REAL(r_std), DIMENSION(npts,npft,nleafages) :: d_leaf_frac
73: ! new leaf age (d)
74: REAL(r_std), DIMENSION(npts,nleafages) :: leaf_age_new
75: ! sum of leaf age fractions, for normalization
76: REAL(r_std), DIMENSION(npts) :: sumfrac
77: ! relative leaf age (age/critical age)
78: REAL(r_std), DIMENSION(npts) :: rel_age
79: ! Index
80: INTEGER(i_std) :: j,m
81:
82: ! =========================================================================
83:
84: IF (bavard.GE.3) WRITE(numout,*) 'Entering vmax'
85:
86: !
87: ! 1 Initialization
88: !
89:
90: !
91: ! 1.1 first call: info about flags and parameters.
92: !
93:
94: IF ( firstcall ) THEN
95:
96: WRITE(numout,*) 'vmax:'
97:
98: WRITE(numout,*) ' > offset (minimum vcmax/vmax_opt):' , vmax_offset
99: WRITE(numout,*) ' > relative leaf age at which vmax attains vcmax_opt:', leafage_firstmax
100: WRITE(numout,*) ' > relative leaf age at which vmax falls below vcmax_opt:', leafage_lastmax
101: WRITE(numout,*) ' > relative leaf age at which vmax attains its minimum:', leafage_old
102:
103: firstcall = .FALSE.
104:
105: ENDIF
106:
107: !
108: ! 1.2 initialize output
109: !
110:
111: *W-----> vcmax(:,:) = 0.0
112: *W----- vjmax(:,:) = 0.0
113:
114: !
115: ! 2 leaf age: general increase and turnover between age classes.
116: !
117:
118: !
119: ! 2.1 increase leaf age
120: !
121:
122: *------> DO m = 1, nleafages
123: |
124: |*W----> WHERE ( leaf_frac(:,:,m) .GT. min_stomate )
125: |||
126: |*W---- leaf_age(:,:,m) = leaf_age(:,:,m) + dt
127: |
128: | ENDWHERE
129: |
130: *------ ENDDO
131:
132: !
133: ! 2.2 turnover between leaf age classes
134: ! d_leaf_frac(:,:,m) = what leaves m-1 and goes into m
135: !
136:
137: +------> DO j = 1, npft
138: |
139: | ! 2.2.1 fluxes
140: |
141: | ! nothing goes into first age class
142: |V===== d_leaf_frac(:,j,1) = 0.0
143: |
144: | ! from m-1 to m
145: |+-----> DO m = 2, nleafages
146: ||
147: ||V==== d_leaf_frac(:,j,m) = leaf_frac(:,j,m-1) * dt/leaf_timecst(j)
148: ||
149: |+----- ENDDO
150: |
151: | ! 2.2.2 new leaf age in class
152: | ! new age = ( old age * old fraction + fractional increase * age of source ) /
153: | ! new fraction
154: |
155: |+V==== leaf_age_new(:,:) = 0.0
156: |
157: |*-----> DO m = 2, nleafages-1
158: ||
159: ||V----> WHERE ( d_leaf_frac(:,j,m) .GT. min_stomate )
160: |||
161: ||V---- leaf_age_new(:,m) = ( ( (leaf_frac(:,j,m)- d_leaf_frac(:,j,m+1)) * leaf_age(:,j,m) ) + &
162: || ( d_leaf_frac(:,j,m) * leaf_age(:,j,m-1) ) ) / &
163: || ( leaf_frac(:,j,m) + d_leaf_frac(:,j,m)- d_leaf_frac(:,j,m+1) )
164: ||
165: || ENDWHERE
166: ||
167: |*----- ENDDO ! Loop over age classes
168: |V-----> WHERE ( d_leaf_frac(:,j,nleafages) .GT. min_stomate )
169: ||
170: |V----- leaf_age_new(:,nleafages) = ( ( leaf_frac(:,j,nleafages) * leaf_age(:,j,nleafages) ) + &
171: | ( d_leaf_frac(:,j,nleafages) * leaf_age(:,j,nleafages-1) ) ) / &
172: | ( leaf_frac(:,j,nleafages) + d_leaf_frac(:,j,nleafages) )
173: |
174: | ENDWHERE
175: |
176: |*-----> DO m = 2, nleafages
177: ||
178: ||V----> WHERE ( d_leaf_frac(:,j,m) .GT. min_stomate )
179: |||
180: ||V---- leaf_age(:,j,m) = leaf_age_new(:,m)
181: ||
182: || ENDWHERE
183: ||
184: |*----- ENDDO ! Loop over age classes
185: |
186: | ! 2.2.3 calculate new fraction
187: |
188: |*-----> DO m = 2, nleafages
189: ||
190: || ! where the change comes from
191: ||V----> leaf_frac(:,j,m-1) = leaf_frac(:,j,m-1) - d_leaf_frac(:,j,m)
192: |||
193: ||| ! where it goes to
194: ||V---- leaf_frac(:,j,m) = leaf_frac(:,j,m) + d_leaf_frac(:,j,m)
195: ||
196: |*----- ENDDO
197: |
198: | ! 2.2.4 renormalize fractions in order to prevent accumulation
199: | ! of numerical errors
200: |
201: | ! correct small negative values
202: |
203: |+-----> DO m = 1, nleafages
204: ||V==== leaf_frac(:,j,m) = MAX( 0._r_std, leaf_frac(:,j,m) )
205: |+----- ENDDO
206: |
207: | ! total of fractions, should be very close to one where there is leaf mass
208: |
209: |V===== sumfrac(:) = 0.0
210: |
211: |+-----> DO m = 1, nleafages
212: ||
213: ||V==== sumfrac(:) = sumfrac(:) + leaf_frac(:,j,m)
214: ||
215: |+----- ENDDO
216: |
217: | ! normalize
218: |
219: |*-----> DO m = 1, nleafages
220: ||
221: ||V----> WHERE ( sumfrac(:) .GT. min_stomate )
222: |||
223: ||| leaf_frac(:,j,m) = leaf_frac(:,j,m) / sumfrac(:)
224: |||
225: ||| ELSEWHERE
226: |||
227: ||V---- leaf_frac(:,j,m) = 0.0
228: ||
229: || ENDWHERE
230: ||
231: |*----- ENDDO
232: |
233: +------ ENDDO ! Loop over PFTs
234:
235: !
236: ! 3 calculate vmax as a function of the age
237: !
238:
239: +------> DO j = 1, npft
240: |
241: |V-----> vcmax(:,j) = 0.0
242: |V----- vjmax(:,j) = 0.0
243: |
244: | ! sum up over the different age classes
245: |
246: |*-----> DO m = 1, nleafages
247: ||
248: || !
249: || ! 3.1 efficiency in each of the age classes
250: || ! increases from 0 to 1 at the beginning (rel_age < leafage_firstmax), stays 1
251: || ! until rel_age = leafage_lastmax, then decreases to vmax_offset at
252: || ! rel_age = leafage_old, then stays at vmax_offset.
253: || !
254: ||
255: ||V----> rel_age(:) = leaf_age(:,j,m) / pheno_crit%leafagecrit(j)
256: |||
257: ||| leaf_efficiency(:) = MAX( vmax_offset, MIN( 1._r_std, &
258: ||| vmax_offset + (1._r_std-vmax_offset) * rel_age(:) / leafage_firstmax, &
259: ||| 1._r_std - (1._r_std-vmax_offset) * ( rel_age(:) - leafage_lastmax ) / &
260: ||| ( leafage_old - leafage_lastmax ) ) )
261: |||
262: ||| !
263: ||| ! 3.2 add to mean vmax
264: ||| !
265: |||
266: ||| vcmax(:,j) = vcmax(:,j) + vcmax_opt(j) * leaf_efficiency(:) * leaf_frac(:,j,m)
267: ||V---- vjmax(:,j) = vjmax(:,j) + vjmax_opt(j) * leaf_efficiency(:) * leaf_frac(:,j,m)
268: ||
269: |*----- ENDDO ! loop over age classes
270: |
271: +------ ENDDO ! loop over PFTs
272:
273: IF (bavard.GE.4) WRITE(numout,*) 'Leaving vmax'
274:
275: END SUBROUTINE vmax
276:
277: END MODULE stomate_vmax
ORCHIDEE/src_stomate/i.stomate_assimtemp.L 0000754 0103600 0005670 00000010754 11164403473 020361 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:42 2008
FILE NAME: i.stomate_assimtemp.f90
PROGRAM NAME: stomate_assimtemp
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
53 vec ( 4): Vectorized array expression.
55 vec ( 3): Unvectorized loop.
55 vec ( 13): Overhead of loop division is too large.
61 vec ( 4): Vectorized array expression.
70 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:42 2008
FILE NAME: i.stomate_assimtemp.f90
PROGRAM NAME: stomate_assimtemp
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! calculates the photosynthesis temperatures
2: !
3: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_assimtemp.f90,v 1.6 2007/05/28 14:49:02 ssipsl Exp $
4: ! IPSL (2006)
5: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
6: !
7: MODULE stomate_assimtemp
8:
9: ! modules used:
10:
11: USE stomate_constants
12:
13: IMPLICIT NONE
14:
15: ! private & public routines
16:
17: PRIVATE
18: PUBLIC assim_temp
19:
20: CONTAINS
21:
22: SUBROUTINE assim_temp (npts, tlong_ref, t2m_month, t_photo_min, t_photo_opt, t_photo_max)
23:
24: !
25: ! 0 declarations
26: !
27:
28: ! 0.1 input
29:
30: ! Domain size
31: INTEGER(i_std), INTENT(in) :: npts
32: ! "long term" 2 meter reference temperatures (K)
33: REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
34: ! "monthly" 2-meter temperatures (K)
35: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
36:
37: ! 0.2 output
38: ! Minimum temperature for photosynthesis (K)
39: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_min
40: ! Optimum temperature for photosynthesis (K)
41: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_opt
42: ! Maximum temperature for photosynthesis (K)
43: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_max
44:
45: ! 0.3 local
46: ! "long term" 2 meter reference temperatures (deg C)
47: REAL(r_std), DIMENSION(npts) :: tl
48: ! Index
49: INTEGER(i_std) :: j
50:
51: ! =========================================================================
52:
53: V====== tl(:) = tlong_ref(:) - ZeroCelsius
54:
55: +------> DO j = 1, npft
56: |
57: | !
58: | ! 1 normal case
59: | !
60: |
61: |V-----> t_photo_min(:,j) = t_photo%t_min_c(j) + t_photo%t_min_b(j)*tl(:) + t_photo%t_min_a(j)*tl(:)*tl(:) + ZeroCelsius
62: || t_photo_opt(:,j) = t_photo%t_opt_c(j) + t_photo%t_opt_b(j)*tl(:) + t_photo%t_opt_a(j)*tl(:)*tl(:) + ZeroCelsius
63: |V----- t_photo_max(:,j) = t_photo%t_max_c(j) + t_photo%t_max_b(j)*tl(:) + t_photo%t_max_a(j)*tl(:)*tl(:) + ZeroCelsius
64: |
65: | !
66: | ! 2 If the monthly temperature is too low, we set tmax < tmin.
67: | ! Therefore, photosynthesis will not be possible (we need tmin < t < tmax)
68: | !
69: |
70: |V-----> WHERE ( t2m_month(:) .LT. t_photo_min(:,j) )
71: |V----- t_photo_max(:,j) = t_photo_min(:,j) - min_stomate
72: | ENDWHERE
73: |
74: +------ ENDDO
75:
76: END SUBROUTINE assim_temp
77:
78: END MODULE stomate_assimtemp
ORCHIDEE/src_stomate/i.stomate_deforestation.L 0000754 0103600 0005670 00000054174 11164403473 021231 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:43 2008
FILE NAME: i.stomate_deforestation.f90
PROGRAM NAME: stomate_deforestation
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
161 vec ( 4): Vectorized array expression.
164 vec ( 4): Vectorized array expression.
196 opt (1017): Subroutine call prevents optimization.
206 vec ( 2): Partially vectorized loop.
206 vec ( 25): Work vectors are used. Size=64byte
213 vec ( 21): Unvectorizable dependency.
217 vec ( 21): Unvectorizable dependency.
228 vec ( 4): Vectorized array expression.
267 vec ( 4): Vectorized array expression.
284 vec ( 4): Vectorized array expression.
301 vec ( 4): Vectorized array expression.
322 vec ( 4): Vectorized array expression.
334 vec ( 1): Vectorized loop.
336 vec ( 26): Macro operation Sum/InnerProd.
338 vec ( 26): Macro operation Sum/InnerProd.
350 vec ( 1): Vectorized loop.
352 vec ( 26): Macro operation Sum/InnerProd.
354 vec ( 26): Macro operation Sum/InnerProd.
371 vec ( 4): Vectorized array expression.
372 opt (1593): Loop nest collapsed into one loop.
372 vec ( 4): Vectorized array expression.
375 vec ( 4): Vectorized array expression.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:43 2008
FILE NAME: i.stomate_deforestation.f90
PROGRAM NAME: stomate_deforestation
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: !
2: ! update/completion by P. Smith
3: !
4:
5: ! Stomate: deforestation
6: !
7: ! authors: M. Boisserie, P. Friedlingstein
8: !
9: !
10: !
11: ! version 0.0: May 2003
12: !
13: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_deforestation.f90,v 1.5 2007/06/13 07:55:43 ssipsl Exp $
14: ! IPSL (2006)
15: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
16: !
17: MODULE stomate_deforestation
18:
19:
20: ! modules used:
21:
22: USE ioipsl
23: USE stomate_constants
24: USE stomate_data
25:
26: IMPLICIT NONE
27:
28:
29: PRIVATE
30: PUBLIC deforestation
31:
32: CONTAINS
33:
34: SUBROUTINE deforestation(npts, dt_days, space_nat, space_nat_new, veget_max, veget_max_new,&
35: biomass, ind, age, PFTpresent, senescence, when_growthinit, everywhere, veget,&
36: co2_to_bm, bm_to_litter, bm_sapl, tree, cn_ind,flux10,flux100, &
37: prod10,prod100,prod10_total,prod100_total,&
38: convflux,cflux_prod_total,cflux_prod10,cflux_prod100, leaf_frac,&
39: npp_longterm, lm_lastyearmax)
40:
41: ! 0 declarations
42:
43: ! 0.1 input
44:
45: ! Domain size
46: INTEGER, INTENT(in) :: npts
47:
48: ! Time step (days)
49: REAL(r_std), INTENT(in) :: dt_days
50:
51: ! new "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
52: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max_new
53:
54: ! biomass of sapling (gC)
55: REAL(r_std) , DIMENSION (npft, nparts), INTENT(in) :: bm_sapl
56:
57: ! is pft a tree
58: LOGICAL, DIMENSION(npft), INTENT(in) :: tree
59:
60:
61: ! 0.2 modified fields
62:
63: ! total natural space (fraction of total space)
64: REAL(r_std), DIMENSION(npts), INTENT(inout) :: space_nat
65:
66: ! total natural space (fraction of total space)
67: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat_new
68:
69: ! fractional coverage on natural/agricultural ground, taking into
70: ! account LAI (=grid-scale fpc)
71: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
72:
73: ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
74: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
75:
76: ! biomass (gC/(m**2 of nat/agri ground))
77: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
78:
79: ! density of individuals 1/m**2
80: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
81:
82: ! mean age (years)
83: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
84:
85: ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
86: ! set to .FALSE. if PFT is introduced or killed
87: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: senescence
88:
89: ! PFT exists
90: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
91:
92: ! is the PFT everywhere in the grid box or very localized (after its introduction)
93: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
94:
95: ! how many days ago was the beginning of the growing season
96: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
97:
98: ! biomass uptaken (gC/(m**2 of total ground)/day)
99: REAL(r_std), DIMENSION(npts), INTENT(inout) :: co2_to_bm
100:
101: ! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
102: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: bm_to_litter
103:
104: ! crown area (m**2) per ind.
105: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: cn_ind
106:
107: ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
108: ! (10 or 100 + 1 : input from year of deforestation)
109: REAL(r_std), DIMENSION(npts,0:10), INTENT(inout) :: prod10
110: REAL(r_std), DIMENSION(npts,0:100), INTENT(inout) :: prod100
111:
112: ! annual release from the 10/100 year-turnover pool compartments
113: REAL(r_std), DIMENSION(npts,10), INTENT(inout) :: flux10
114: REAL(r_std), DIMENSION(npts,100), INTENT(inout) :: flux100
115:
116: ! fraction of leaves in leaf age class
117: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
118:
119: ! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
120: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_lastyearmax
121:
122: ! "long term" net primary productivity (gC/(m**2 of nat/agri ground)/year)
123: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: npp_longterm
124:
125:
126: ! 0.3 output
127:
128: ! release during first year following deforestation
129: REAL(r_std), DIMENSION(npts), INTENT(out) :: convflux
130:
131: ! total annual release from the 10/100 year-turnover pool
132: REAL(r_std), DIMENSION(npts), INTENT(out) :: cflux_prod10, cflux_prod100
133:
134: ! total products remaining in the pool after the annual release
135: REAL(r_std), DIMENSION(npts), INTENT(out) :: prod10_total, prod100_total
136:
137: ! total flux from conflux and the 10/100 year-turnover pool
138: REAL(r_std), DIMENSION(npts), INTENT(out) :: cflux_prod_total
139:
140:
141: ! 0.4 local
142:
143: ! indices
144: INTEGER(i_std) :: i, j, k, l, m
145:
146: ! biomass increase (gC/(m**2 of nat/agri ground))
147: REAL(r_std),DIMENSION(npts) :: bm_new
148:
149: ! change in number of individuals /m2 per year
150: REAL(r_std),DIMENSION(npts,npft) :: d_ind
151:
152: REAL(r_std) :: x,above
153: REAL(r_std),DIMENSION(npft) :: y,z
154:
155: REAL(r_std), DIMENSION(npts,npft) :: vegetspace
156: REAL(r_std), DIMENSION(npts,npft) :: vegetspace_new
157:
158: ! =========================================================================
159:
160: ! yearly initialisation
161: V------> prod10(:,0) = zero
162: V------ prod100(:,0) = zero
163: above = zero
164: V------> convflux(:) = zero
165: | cflux_prod10(:) = zero
166: | cflux_prod100(:) = zero
167: | prod10_total(:) = zero
168: | prod100_total(:) = zero
169: | cflux_prod_total(:) = zero
170: V------ bm_new(:) = zero
171:
172: +------> DO i = 1, npts
173: |
174: |+-----> DO j = 1, npft
175: ||
176: || IF( natural(j) ) THEN
177: ||
178: || vegetspace(i,j) = veget_max(i,j) * space_nat(i)
179: || vegetspace_new(i,j) = veget_max_new(i,j) * space_nat_new(i)
180: ||
181: || ELSE
182: ||
183: || vegetspace(i,j) = veget_max(i,j) *(1. - space_nat(i))
184: || vegetspace_new(i,j) = veget_max_new(i,j) *(1. - space_nat_new(i))
185: ||
186: || ENDIF
187: ||
188: || ! in case of establishment of a new PFT or extension of its coverage in a gridcell
189: || IF ( vegetspace_new(i,j) .GT. vegetspace(i,j) ) THEN
190: ||
191: || IF ( tree(j) ) THEN
192: ||
193: || IF ( abs(cn_ind(i,j)) > 1e-16) THEN
194: || d_ind(i,j) = (vegetspace_new(i,j) - vegetspace(i,j)) / cn_ind (i,j)
195: || ELSE
196: || write(numout,*) "deforestation : cn_ind est nul pour i,j = ",i,j
197: || d_ind(i,j) = zero
198: || ENDIF
199: ||
200: || ELSE
201: ||
202: || d_ind(i,j) = vegetspace_new(i,j) - vegetspace(i,j)
203: ||
204: || ENDIF
205: ||
206: ||V----> DO k = 1, nparts
207: |||
208: ||| bm_new(i) = d_ind(i,j) * bm_sapl(j,k)
209: ||| biomass(i,j,k) = biomass(i,j,k) + bm_new(i)
210: |||
211: ||| S IF( natural(j) ) THEN
212: ||| S
213: ||| S co2_to_bm(i) = co2_to_bm(i) + bm_new(i) * space_nat_new(i) / one_year * dt_days
214: |||
215: ||| ELSE
216: |||
217: ||| S co2_to_bm(i) = co2_to_bm(i) + bm_new(i) * (1.-space_nat_new(i)) / one_year * dt_days
218: |||
219: ||| ENDIF
220: |||
221: ||V---- ENDDO
222: ||
223: || PFTpresent(i,j) = .TRUE.
224: || everywhere(i,j) = 1.
225: || senescence(i,j) = .FALSE.
226: || age(i,j) = 0.
227: || ind(i,j) = veget_max_new (i,j)
228: ||V----> when_growthinit(:,j) = large_value
229: ||| leaf_frac(:,j,1) = 1.0
230: ||| npp_longterm(:,j) = 10.
231: ||V---- lm_lastyearmax(:,j) = bm_sapl(j,ileaf) * ind(:,j)
232: ||
233: || ENDIF ! End if PFT extension
234: ||
235: || ! in case of total or fractional disparition or a PFT
236: || IF ( vegetspace_new(i,j) .LT. vegetspace(i,j)) THEN
237: ||
238: || x = 40./67.
239: || y(1) = 27./67.
240: || y(2) = 27./67.
241: || y(9) = 27./67.
242: || y(3) = 20./67.
243: || y(4) = 20./67.
244: || y(5) = 20./67.
245: || y(6) = 20./67.
246: || y(7) = 20./67.
247: || y(8) = 20./67.
248: || y(10)= 20./67.
249: || y(11)= 20./67.
250: || z(3) = 7./67.
251: || z(4) = 7./67.
252: || z(5) = 7./67.
253: || z(6) = 7./67.
254: || z(7) = 7./67.
255: || z(8) = 7./67.
256: || z(11)= 7./67.
257: || z(12)= 7./67.
258: || z(1) = 0.
259: || z(2) = 0.
260: || z(9) = 0.
261: ||
262: || IF ( vegetspace_new(i,j) .EQ. 0. ) THEN
263: ||
264: || IF (.NOT. tree(j) ) THEN
265: ||
266: || ind(i,j) = 0.0
267: ||V----> bm_to_litter(i,j,:) = bm_to_litter(i,j,:) + biomass(i,j,:)
268: ||V---- biomass(i,j,:) = 0.0
269: ||
270: || ELSE
271: ||
272: || ind(i,j) = 0.0
273: || cn_ind(i,j) = 0.0
274: || above = biomass(i,j,1) + biomass(i,j,2) + &
275: || biomass(i,j,4)
276: || convflux(i) = convflux(i) + x * above
277: || prod10(i,0) = prod10(i,0) + y(j) * above
278: || prod100(i,0) = prod100(i,0) + z(j) * above
279: || bm_to_litter(i,j,3) = bm_to_litter(i,j,3) + biomass(i,j,3)
280: || bm_to_litter(i,j,5) = bm_to_litter(i,j,5) + biomass(i,j,5)
281: || bm_to_litter(i,j,6) = bm_to_litter(i,j,6) + biomass(i,j,6)
282: || bm_to_litter(i,j,7) = bm_to_litter(i,j,7) + biomass(i,j,7)
283: || bm_to_litter(i,j,8) = bm_to_litter(i,j,8) + biomass(i,j,8)
284: ||V==== biomass(i,j,:) = 0.0
285: ||
286: || ENDIF
287: ||
288: || PFTpresent(i,j) = .FALSE.
289: || senescence(i,j) = .FALSE.
290: || age(i,j) = 0.0
291: || when_growthinit(i,j) = undef
292: || everywhere(i,j) = 0.0
293: || veget(i,j) = 0.0
294: ||
295: || ELSE
296: ||
297: || d_ind(i,j) = vegetspace(i,j) - vegetspace_new(i,j)
298: ||
299: || IF (.NOT. tree (j)) THEN
300: ||
301: ||V----> bm_to_litter(i,j,:) = bm_to_litter(i,j,:) + &
302: ||| biomass(i,j,:) * d_ind(i,j) / veget_max(i,j)
303: ||V---- biomass(i,j,:) = biomass(i,j,:) * (1. - d_ind(i,j)/veget_max(i,j))
304: || ind(i,j) = ind(i,j) * (1. - d_ind(i,j))
305: ||
306: || ELSE
307: ||
308: || above =(biomass(i,j,1) + biomass(i,j,2) + biomass(i,j,4)) * d_ind(i,j)/veget_max(i,j)
309: || convflux(i) = convflux(i) + x * above
310: || prod10(i,0) = prod10(i,0) + y(j) * above
311: || prod100(i,0) = prod100(i,0) + z(j) * above
312: || bm_to_litter(i,j,3) = bm_to_litter(i,j,3) + &
313: || biomass(i,j,3)* d_ind(i,j)/vegetspace(i,j)
314: || bm_to_litter(i,j,5) = bm_to_litter(i,j,5) + &
315: || biomass(i,j,5)* d_ind(i,j)/vegetspace(i,j)
316: || bm_to_litter(i,j,6) = bm_to_litter(i,j,6) + &
317: || biomass(i,j,6)* d_ind(i,j)/vegetspace(i,j)
318: || bm_to_litter(i,j,7) = bm_to_litter(i,j,7) + &
319: || biomass(i,j,7)* d_ind(i,j)/vegetspace(i,j)
320: || bm_to_litter(i,j,8) = bm_to_litter(i,j,8) + &
321: || biomass(i,j,8)* d_ind(i,j) /vegetspace(i,j)
322: ||V==== biomass(i,j,:) = biomass(i,j,:) * ( 1. - d_ind(i,j))/vegetspace(i,j)
323: ||
324: || ENDIF
325: ||
326: || ENDIF ! End if PFT total disparition
327: ||
328: || ENDIF ! End if PFT's coverage reduction
329: ||
330: |+----- ENDDO ! End loop on PFTs
331: |
332: | ! each year, update 10 year-turnover pool content following flux emission
333: | ! (linear decay (10%) of the initial carbon input)
334: |V-----> DO l = 0, 8
335: || m = 10 - l
336: || cflux_prod10(i) = cflux_prod10(i) + flux10(i,m)
337: || prod10(i,m) = prod10(i,m-1) - flux10(i,m-1)
338: || prod10_total(i) = prod10_total(i) + prod10(i,m)
339: || flux10(i,m) = flux10(i,m-1)
340: ||
341: || IF (prod10(i,m) .LT. 1.0) prod10(i,m) = 0.0
342: ||
343: |V----- ENDDO
344: |
345: | cflux_prod10(i) = cflux_prod10(i) + flux10(i,1)
346: | flux10(i,1) = 0.1 * prod10(i,0)
347: | prod10(i,1) = prod10(i,0)
348: | prod10_total(i) = prod10_total(i) + prod10(i,1)
349: |
350: |V-----> DO l = 0, 98
351: || m = 100 - l
352: || cflux_prod100(i) = cflux_prod100(i) + flux100(i,m)
353: || prod100(i,m) = prod100(i,m-1) - flux100(i,m-1)
354: || prod100_total(i) = prod100_total(i) + prod100(i,m)
355: || flux100(i,m) = flux100(i,m-1)
356: ||
357: || IF (prod100(i,m).LT.1.0) prod100(i,m) = 0.0
358: ||
359: |V----- ENDDO
360: |
361: | cflux_prod100(i) = cflux_prod100(i) + flux100(i,1)
362: | flux100(i,1) = 0.01 * prod100(i,0)
363: | prod100(i,1) = prod100(i,0)
364: | prod100_total(i) = prod100_total(i) + prod100(i,1)
365: | cflux_prod_total(i) = convflux(i) + cflux_prod10(i) + cflux_prod100(i)
366: | prod10(i,0) = 0.0
367: | prod100(i,0) = 0.0
368: |
369: +------ ENDDO ! End loop on npts
370:
371: V====== space_nat(:) = space_nat_new(:)
372: W*===== veget_max(:,:) = veget_max_new(:,:)
373:
374: ! convert flux from /year into /time step
375: V------> convflux = convflux/one_year*dt_days
376: | cflux_prod10 = cflux_prod10/one_year*dt_days
377: V------ cflux_prod100 = cflux_prod100/one_year*dt_days
378:
379: END SUBROUTINE deforestation
380:
381: END MODULE stomate_deforestation
ORCHIDEE/src_stomate/i.stomate_resp.L 0000754 0103600 0005670 00000032543 11164403473 017330 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:44 2008
FILE NAME: i.stomate_resp.f90
PROGRAM NAME: stomate_resp
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
98 vec ( 4): Vectorized array expression.
117 vec ( 4): Vectorized array expression.
123 vec ( 3): Unvectorized loop.
123 vec ( 13): Overhead of loop division is too large.
125 vec ( 4): Vectorized array expression.
140 vec ( 4): Vectorized array expression.
157 vec ( 4): Vectorized array expression.
159 vec ( 4): Vectorized array expression.
166 opt (1082): Backward transfers inhibit loop optimization.
166 vec ( 4): Vectorized array expression.
170 vec ( 3): Unvectorized loop.
172 opt (1592): Outer loop unrolled inside inner loop.
172 vec ( 4): Vectorized array expression.
190 vec ( 4): Vectorized array expression.
196 vec ( 4): Vectorized array expression.
203 vec ( 3): Unvectorized loop.
203 vec ( 13): Overhead of loop division is too large.
208 vec ( 4): Vectorized array expression.
217 vec ( 4): Vectorized array expression.
234 warn ( 82): Name "t_maint" is not used.
234 warn ( 82): Name "i" is not used.
234 warn ( 82): Name "m" is not used.
234 warn ( 83): Dummy argument "height" is not used.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:44 2008
FILE NAME: i.stomate_resp.f90
PROGRAM NAME: stomate_resp
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_resp.f90,v 1.6 2007/05/28 14:57:23 ssipsl Exp $
2: !IPSL (2006)
3: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
4:
5: ! calculate maintenance respiration on an hourly time step (NV 14/5/2002)
6: MODULE stomate_resp
7: ! modules used:
8: USE stomate_constants
9:
10: IMPLICIT NONE
11:
12: ! private & public routines
13:
14: PRIVATE
15: PUBLIC maint_respiration,maint_respiration_clear
16:
17: ! first call
18: LOGICAL, SAVE :: firstcall = .TRUE.
19:
20: CONTAINS
21:
22: SUBROUTINE maint_respiration_clear
23: firstcall=.TRUE.
24: END SUBROUTINE maint_respiration_clear
25:
26: SUBROUTINE maint_respiration ( npts,dt,t2m,tlong_ref,stempdiag,height,veget_max,space_nat,&
27: rprof,biomass,resp_maint_part_radia)
28:
29: !
30: ! 0 declarations
31: !
32:
33: ! 0.1 input
34:
35: ! Domain size
36: INTEGER(i_std), INTENT(in) :: npts
37: ! time step (seconds)
38: REAL(r_std), INTENT(in) :: dt
39: ! 2 m air temperature (K)
40: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m
41: ! 2 m air temperature (K)
42: REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
43: ! natural space
44: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
45: ! Soil temperature
46: REAL(r_std),DIMENSION (npts,nbdl), INTENT (in) :: stempdiag
47: ! height of vegetation (m)
48: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: height
49: ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
50: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: veget_max
51: ! root depth (m)
52: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: rprof
53: ! biomass (gC/m**2)
54: REAL(r_std),DIMENSION(npts,npft,nparts),INTENT(in) :: biomass
55: ! 0.2 modified fields
56:
57:
58: ! 0.3 output
59:
60: ! maintenance respiration of different parts (gC/dt/m**2 of total ground)
61: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: resp_maint_part_radia
62: ! 0.4 local
63:
64: ! leaf area index
65: REAL(r_std), DIMENSION(npts,npft) :: lai
66: ! soil levels (m)
67: REAL(r_std), SAVE, DIMENSION(0:nbdl) :: z_soil
68: ! root temperature (convolution of root and soil temperature profiles)
69: REAL(r_std), DIMENSION(npts,npft) :: t_root
70: ! maintenance respiration coefficients at 0 deg C (g/g d**-1)
71: REAL(r_std), DIMENSION(npts,npft,nparts) :: coeff_maint
72: ! temperature which is pertinent for maintenance respiration (K)
73: REAL(r_std), DIMENSION(npts,nparts) :: t_maint
74: ! integration constant for root profile
75: REAL(r_std), DIMENSION(npts) :: rpc
76: ! temperature which is pertinent for maintenance respiration (K)
77: REAL(r_std), DIMENSION(npts,nparts) :: t_maint_radia
78: ! long term annual mean temperature, C
79: REAL(r_std), DIMENSION(npts) :: tl
80: ! slope of maintenance respiration coefficient (1/K)
81: REAL(r_std), DIMENSION(npts) :: slope
82: ! Index
83: INTEGER(i_std) :: i,j,k,l,m
84:
85: !
86: !
87: ! 2 define maintenance respiration coefficients
88: !
89: IF (bavard.GE.3) WRITE(numout,*) 'Entering respiration'
90: !
91: ! 1 Initializations
92: !
93: IF ( firstcall ) THEN
94:
95: ! 1.1.1 soil levels
96:
97: z_soil(0) = 0.
98: V====== z_soil(1:nbdl) = diaglev(1:nbdl)
99:
100: ! 1.1.2 messages
101:
102: WRITE(numout,*) 'respiration:'
103:
104: firstcall = .FALSE.
105:
106: ENDIF
107:
108: !
109:
110: !
111: ! 1 do initialisation
112: !
113:
114: +------> DO j = 1, npft
115: |
116: | ! 1.3.1 rpc is an integration constant such that the integral of the root profile is 1.
117: |V-----> rpc(:) = 1. / ( 1. - EXP( -z_soil(nbdl) / rprof(:,j) ) )
118: ||
119: || ! 1.3.2 integrate over the nbdl levels
120: ||
121: |V----- t_root(:,j) = 0.0
122: |
123: |+-----> DO l = 1, nbdl
124: ||
125: ||V==== t_root(:,j) = &
126: || t_root(:,j) + stempdiag(:,l) * rpc(:) * &
127: || ( EXP( -z_soil(l-1)/rprof(:,j) ) - EXP( -z_soil(l)/rprof(:,j) ) )
128: ||
129: |+----- ENDDO
130: |
131: +------ ENDDO
132: +------> DO j = 1, npft
133: |
134: | !
135: | ! 2.1 temperature which is taken for the plant part we are talking about
136: | !
137: |
138: | ! 2.1.1 parts above the ground
139: |
140: |V-----> t_maint_radia(:,ileaf) = t2m(:)
141: || t_maint_radia(:,isapabove) = t2m(:)
142: || t_maint_radia(:,ifruit) = t2m(:)
143: ||
144: || ! 2.1.2 parts below the ground
145: ||
146: || t_maint_radia(:,isapbelow) = t_root(:,j)
147: || t_maint_radia(:,iroot) = t_root(:,j)
148: ||
149: || ! 2.1.3 heartwood: does not respire. Any temperature
150: ||
151: || t_maint_radia(:,iheartbelow) = t_root(:,j)
152: |V----- t_maint_radia(:,iheartabove) = t2m(:)
153: |
154: | ! 2.1.4 reserve: above the ground for trees, below for grasses
155: |
156: | IF ( tree(j) ) THEN
157: |V===== t_maint_radia(:,icarbres) = t2m(:)
158: | ELSE
159: |V===== t_maint_radia(:,icarbres) = t_root(:,j)
160: | ENDIF
161: |
162: | !
163: | ! 2.2 calculate coefficient
164: | !
165: |
166: |V-----> tl(:) = tlong_ref(:) - ZeroCelsius
167: |V----- slope(:) = maint_resp_slope(j,1) + tl(:) * maint_resp_slope(j,2) + &
168: | tl(:)*tl(:) * maint_resp_slope(j,3)
169: |
170: |+-----> DO k = 1, nparts
171: ||
172: ||V==== coeff_maint(:,j,k) = &
173: || MAX( (coeff_maint_zero(j,k)*dt/one_day) * &
174: || ( 1. + slope(:) * (t_maint_radia(:,k)-ZeroCelsius) ), 0._r_std )
175: ||
176: |+----- ENDDO
177: |
178: +------ ENDDO
179:
180: !
181: ! 3 calculate maintenance respiration.
182: !
183:
184: +------> DO j = 1, npft
185: |
186: | !
187: | ! 3.1 maintenance respiration of the different plant parts
188: | !
189: | IF (natural(j)) THEN
190: |V-----> WHERE ( veget_max(:,j) .GT. 0.0 )
191: || lai(:,j) = biomass(:,j,ileaf)*space_nat / veget_max(:,j) * sla(j)
192: || ELSEWHERE
193: |V----- lai(:,j) = 0.0
194: | ENDWHERE
195: | ELSE
196: |V-----> WHERE ( veget_max(:,j) .GT. 0.0 )
197: || lai(:,j) = biomass(:,j,ileaf)*(1-space_nat) / veget_max(:,j) * sla(j)
198: || ELSEWHERE
199: |V----- lai(:,j) = 0.0
200: | ENDWHERE
201: | ENDIF
202: |
203: |+-----> DO k = 1, nparts
204: ||
205: || IF ( k .EQ. ileaf ) THEN
206: ||
207: || ! Leaves: respiration depends on leaf mass AND LAI.
208: ||V----> WHERE ( (biomass(:,j,ileaf) .GT. min_stomate) .AND. (lai(:,j) .GT. 0.0) )
209: ||| resp_maint_part_radia(:,j,k) = coeff_maint(:,j,k) * biomass(:,j,k) * &
210: ||| ( .3*lai(:,j) + 1.4*(1.-exp(-.5*lai(:,j))) ) / lai(:,j)
211: ||| ELSEWHERE
212: ||V---- resp_maint_part_radia(:,j,k) = 0.0
213: || ENDWHERE
214: ||
215: || ELSE
216: ||
217: ||V==== resp_maint_part_radia(:,j,k) = coeff_maint(:,j,k) * biomass(:,j,k)
218: ||
219: || ENDIF
220: ||
221: |+----- ENDDO
222: |
223: | !
224: | ! 3.2 Total maintenance respiration of the plant
225: | ! VPP killer:
226: | ! resp_maint(:,j) = SUM( resp_maint_part(:,:), DIM=2 )
227: | !
228: |
229: +------ ENDDO
230:
231:
232: IF (bavard.GE.4) WRITE(numout,*) 'Leaving respiration'
233:
234: END SUBROUTINE maint_respiration
235:
236: END MODULE stomate_resp
ORCHIDEE/src_stomate/i.stomate_lpj.L 0000754 0103600 0005670 00000150030 11164403473 017134 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:45 2008
FILE NAME: i.stomate_lpj.f90
PROGRAM NAME: stomate_lpj
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
338 vec ( 4): Vectorized array expression.
340 opt (1592): Outer loop unrolled inside inner loop.
340 vec ( 4): Vectorized array expression.
341 opt (1593): Loop nest collapsed into one loop.
341 vec ( 4): Vectorized array expression.
342 vec ( 4): Vectorized array expression.
343 opt (1592): Outer loop unrolled inside inner loop.
349 opt (1593): Loop nest collapsed into one loop.
349 vec ( 4): Vectorized array expression.
350 opt (1592): Outer loop unrolled inside inner loop.
350 vec ( 4): Vectorized array expression.
602 warn ( 80): Dummy argument "deadleaf_cover" with INTENT(OUT) attribute may be referenced before it is defined.
602 vec ( 4): Vectorized array expression.
611 vec ( 4): Vectorized array expression.
620 opt (1592): Outer loop unrolled inside inner loop.
655 warn ( 80): Dummy argument "deadleaf_cover" with INTENT(OUT) attribute may be referenced before it is defined.
781 warn ( 83): Dummy argument "soilhum_daily" is not used.
781 warn ( 83): Dummy argument "control_moist" is not used.
781 warn ( 83): Dummy argument "control_temp" is not used.
781 warn ( 83): Dummy argument "clay" is not used.
781 warn ( 83): Dummy argument "tsurf_daily" is not used.
781 warn ( 83): Dummy argument "soilcarbon_input" is not used.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:36:45 2008
FILE NAME: i.stomate_lpj.f90
PROGRAM NAME: stomate_lpj
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: ! Stomate: phenology, allocation, etc.
2: !
3: ! authors: A. Botta, P. Friedlingstein, C. Morphopoulos, N. Viovy, et al.
4: !
5: ! bits and pieces put together by G. Krinner
6: !
7: ! version 0.0: August 1998
8: !
9: ! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_lpj.f90,v 1.14 2007/06/13 07:44:34 ssipsl Exp $
10: ! IPSL (2006)
11: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
12: !
13: MODULE stomate_lpj
14:
15: ! modules used:
16:
17: USE ioipsl
18: USE stomate_constants
19: USE lpj_constraints
20: USE lpj_pftinout
21: USE lpj_kill
22: USE lpj_crown
23: USE lpj_fire
24: USE lpj_gap
25: USE lpj_light
26: USE lpj_establish
27: USE lpj_cover
28: USE stomate_prescribe
29: USE stomate_phenology
30: USE stomate_alloc
31: USE stomate_npp
32: USE stomate_turnover
33: USE stomate_litter
34: USE stomate_soilcarbon
35: USE stomate_vmax
36: USE stomate_assimtemp
37: ! routine added
38: USE stomate_deforestation
39: USE stomate_natagritot
40: ! USE Write_Field_p
41:
42: IMPLICIT NONE
43:
44: ! private & public routines
45:
46: PRIVATE
47: PUBLIC StomateLpj,StomateLpj_clear
48:
49: CONTAINS
50:
51: SUBROUTINE StomateLpj_clear
52:
53: CALL prescribe_clear
54: CALL phenology_clear
55: CALL npp_calc_clear
56: CALL turn_clear
57: CALL soilcarbon_clear
58: CALL constraints_clear
59: CALL establish_clear
60: CALL fire_clear
61: CALL gap_clear
62: CALL light_clear
63: CALL pftinout_clear
64: CALL alloc_clear
65: END SUBROUTINE StomateLpj_clear
66:
67: SUBROUTINE StomateLpj (npts, dt_days, EndOfYear, &
68: neighbours, resolution, space_nat, &
69: clay, herbivores, &
70: tsurf_daily, tsoil_daily, t2m_daily, t2m_min_daily, &
71: litterhum_daily, soilhum_daily, &
72: maxmoiavail_lastyear, minmoiavail_lastyear, &
73: gdd0_lastyear, precip_lastyear, &
74: moiavail_month, moiavail_week, tlong_ref, t2m_month, t2m_week, &
75: tsoil_month, soilhum_month, &
76: gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
77: turnover_longterm, gpp_daily, time_lowgpp, &
78: time_hum_min, maxfpc_lastyear, resp_maint_part, &
79: PFTpresent, age, fireindex, firelitter, &
80: leaf_age, leaf_frac, biomass, ind, adapted, regenerate, &
81: senescence, when_growthinit, &
82: litterpart, litter, dead_leaves, carbon, black_carbon, lignin_struc, &
83: veget_max, veget, npp_longterm, lm_lastyearmax, veget_lastlight, &
84: everywhere, need_adjacent, RIP_time, &
85: lai, rprof,npp_daily, turnover_daily, turnover_time,&
86: control_moist, control_temp, soilcarbon_input, &
87: co2_to_bm, co2_fire, resp_hetero, resp_maint, resp_growth, &
88: height, deadleaf_cover, vcmax, vjmax, t_photo_min, t_photo_opt, t_photo_max,bm_to_litter, &
89: prod10,prod100,flux10, flux100, space_nat_new,veget_max_new, &
90: convflux,cflux_prod10,cflux_prod100, defor)
91: ! deforestation variables added as arguments
92:
93: !
94: ! 0 declarations
95: !
96:
97: ! 0.1 input
98:
99: ! Domain size
100: INTEGER(i_std), INTENT(in) :: npts
101: ! time step of Stomate in days
102: REAL(r_std), INTENT(in) :: dt_days
103: ! indices of the 8 neighbours of each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
104: INTEGER(i_std), DIMENSION(npts,8), INTENT(in) :: neighbours
105: ! resolution at each grid point in m (1=E-W, 2=N-S)
106: REAL(r_std), DIMENSION(npts,2), INTENT(in) :: resolution
107: ! total natural space (fraction of total space)
108: ! REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat
109: REAL(r_std), DIMENSION(npts), INTENT(inout) :: space_nat
110: ! clay fraction
111: REAL(r_std), DIMENSION(npts), INTENT(in) :: clay
112: ! time constant of probability of a leaf to be eaten by a herbivore (days)
113: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: herbivores
114: ! daily surface temperatures (K)
115: REAL(r_std), DIMENSION(npts), INTENT(in) :: tsurf_daily
116: ! daily soil temperatures (K)
117: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil_daily
118: ! daily 2 meter temperatures (K)
119: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_daily
120: ! daily minimum 2 meter temperatures (K)
121: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_min_daily
122: ! daily litter humidity
123: REAL(r_std), DIMENSION(npts), INTENT(in) :: litterhum_daily
124: ! daily soil humidity
125: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum_daily
126: ! last year's maximum moisture availability
127: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxmoiavail_lastyear
128: ! last year's minimum moisture availability
129: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: minmoiavail_lastyear
130: ! last year's GDD0
131: REAL(r_std), DIMENSION(npts), INTENT(in) :: gdd0_lastyear
132: ! lastyear's precipitation (mm/year)
133: REAL(r_std), DIMENSION(npts), INTENT(in) :: precip_lastyear
134: ! "monthly" moisture availability
135: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_month
136: ! "weekly" moisture availability
137: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: moiavail_week
138: ! "long term" 2 meter reference temperatures (K)
139: REAL(r_std), DIMENSION(npts), INTENT(in) :: tlong_ref
140: ! "monthly" 2-meter temperatures (K)
141: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_month
142: ! "weekly" 2-meter temperatures (K)
143: REAL(r_std), DIMENSION(npts), INTENT(in) :: t2m_week
144: ! "monthly" soil temperatures (K)
145: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: tsoil_month
146: ! "monthly" soil humidity
147: REAL(r_std), DIMENSION(npts,nbdl), INTENT(in) :: soilhum_month
148: ! growing degree days, threshold -5 deg C (for phenology)
149: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gdd_m5_dormance
150: ! growing degree days, since midwinter (for phenology)
151: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: gdd_midwinter
152: ! number of chilling days, since leaves were lost (for phenology)
153: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ncd_dormance
154: ! number of growing days, threshold -5 deg C (for phenology)
155: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: ngd_minus5
156: ! "long term" turnover rate (gC/(m**2 of nat/agri ground)/year)
157: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(in) :: turnover_longterm
158: ! daily gross primary productivity (gC/(m**2 of nat/agri ground)/day)
159: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: gpp_daily
160: ! duration of dormance (d)
161: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_lowgpp
162: ! time elapsed since strongest moisture availability (d)
163: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: time_hum_min
164: ! last year's maximum fpc for each natural PFT, on *natural* ground
165: REAL(r_std), DIMENSION(npts,npft), INTENT(in) :: maxfpc_lastyear
166: ! maintenance respiration of different plant parts (gC/day/m**2 of nat/agri ground)
167: REAL(r_std), DIMENSION(npts,nparts,npft), INTENT(in) :: resp_maint_part
168:
169: ! 0.2 modified fields
170:
171: ! PFT exists
172: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: PFTpresent
173: ! age (years)
174: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: age
175: ! Probability of fire
176: REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: fireindex
177: ! Longer term litter above the ground, gC/m**2 of nat/agri ground
178: REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: firelitter
179: ! leaf age (days)
180: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_age
181: ! fraction of leaves in leaf age class
182: REAL(r_std), DIMENSION(npts,npft,nleafages), INTENT(inout) :: leaf_frac
183: ! biomass (gC/(m**2 of nat/agri ground))
184: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(inout) :: biomass
185: ! density of individuals (1/(m**2 of nat/agri ground))
186: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: ind
187: ! Winter too cold? between 0 and 1
188: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: adapted
189: ! Winter sufficiently cold? between 0 and 1
190: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: regenerate
191: ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
192: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: senescence
193: ! how many days ago was the beginning of the growing season
194: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: when_growthinit
195: ! fraction of litter above the ground belonging to different PFTs
196: REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: litterpart
197: ! metabolic and structural litter, natural and agricultural,
198: ! above and below ground (gC/(m**2 of nat/agri ground))
199: REAL(r_std), DIMENSION(npts,nlitt,nvegtypes,nlevs), INTENT(inout) :: litter
200: ! dead leaves on ground, per PFT, metabolic and structural,
201: ! in gC/(m**2 of nat/agri ground)
202: REAL(r_std), DIMENSION(npts,npft,nlitt), INTENT(inout) :: dead_leaves
203: ! carbon pool: active, slow, or passive, natural and agricultural
204: ! (gC/(m**2 of nat/agri ground))
205: REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(inout) :: carbon
206: ! black carbon on the ground (gC/(m**2 of total ground))
207: REAL(r_std), DIMENSION(npts), INTENT(inout) :: black_carbon
208: ! ratio Lignine/Carbon in structural litter, above and below ground,
209: ! natural and agricultural (gC/(m**2 of nat/agri ground))
210: REAL(r_std), DIMENSION(npts,nvegtypes,nlevs), INTENT(inout) :: lignin_struc
211: ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
212: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_max
213: ! fractional coverage on natural/agricultural ground, taking into
214: ! account LAI (=grid-scale fpc)
215: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget
216: ! "long term" net primary productivity (gC/(m**2 of nat/agri ground)/year)
217: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: npp_longterm
218: ! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
219: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lm_lastyearmax
220: ! vegetation fractions (on natural/agri ground) after last light competition
221: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: veget_lastlight
222: ! is the PFT everywhere in the grid box or very localized (after its introduction)
223: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: everywhere
224: ! in order for this PFT to be introduced, does it have to be present in an
225: ! adjacent grid box?
226: LOGICAL, DIMENSION(npts,npft), INTENT(inout) :: need_adjacent
227: ! How much time ago was the PFT eliminated for the last time (y)
228: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: RIP_time
229: ! Turnover_time of leaves for grasses (d)
230: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: turnover_time
231:
232: ! 0.3 output
233:
234: ! leaf area index OF AN INDIVIDUAL PLANT
235: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: lai
236: ! root depth. This will, one day, be a prognostic variable. It will be calculated by
237: ! STOMATE (save in restart file & give to hydrology module!), probably somewhere
238: ! in the allocation routine. For the moment, it is prescribed.
239: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: rprof
240: ! net primary productivity (gC/day/(m**2 of nat/agri ground))
241: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: npp_daily
242: ! Turnover rates (gC/(m**2 of nat/agri ground)/day)
243: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: turnover_daily
244: ! moisture control of heterotrophic respiration
245: REAL(r_std), DIMENSION(npts,nlevs), INTENT(inout) :: control_moist
246: ! temperature control of heterotrophic respiration, above and below
247: REAL(r_std), DIMENSION(npts,nlevs), INTENT(inout) :: control_temp
248: ! quantity of carbon going into carbon pools from litter decomposition
249: ! (gC/(m**2 of nat/agri ground)/day)
250: REAL(r_std), DIMENSION(npts,ncarb,nvegtypes), INTENT(inout) :: soilcarbon_input
251: ! co2 taken up (gC/(m**2 of total ground)/day)
252: REAL(r_std), DIMENSION(npts), INTENT(out) :: co2_to_bm
253: ! carbon emitted into the atmosphere by fire (living and dead biomass)
254: ! (in gC/m**2 of total ground/day)
255: REAL(r_std), DIMENSION(npts), INTENT(out) :: co2_fire
256: ! heterotrophic respiration (gC/day/m**2 of total ground)
257: REAL(r_std), DIMENSION(npts,nvegtypes), INTENT(inout) :: resp_hetero
258: ! maintenance respiration (gC/day/(m**2 of total ground))
259: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: resp_maint
260: ! growth respiration (gC/day/(m**2 of total ground))
261: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: resp_growth
262: ! height of vegetation (m)
263: REAL(r_std), DIMENSION(npts,npft), INTENT(inout) :: height
264: ! fraction of soil covered by dead leaves
265: REAL(r_std), DIMENSION(npts), INTENT(out) :: deadleaf_cover
266: ! Maximum rate of carboxylation
267: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: vcmax
268: ! Maximum rate of RUbp regeneration
269: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: vjmax
270: ! Minimum temperature for photosynthesis (deg C)
271: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_min
272: ! Optimum temperature for photosynthesis (deg C)
273: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_opt
274: ! Maximum temperature for photosynthesis (deg C)
275: REAL(r_std), DIMENSION(npts,npft), INTENT(out) :: t_photo_max
276: ! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
277: REAL(r_std), DIMENSION(npts,npft,nparts), INTENT(out) :: bm_to_litter
278:
279: ! 0.4 local
280:
281: ! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
282: ! REAL(r_std), DIMENSION(npts,npft,nparts) :: bm_to_litter
283: ! total conversion of biomass to litter (gC/(m**2)) / day
284: REAL(r_std), DIMENSION(npts,npft) :: tot_bm_to_litter
285: ! total living biomass (gC/(m**2))
286: REAL(r_std), DIMENSION(npts,npft) :: tot_live_biomass
287: ! total turnover rate (gC/(m**2)) / day
288: REAL(r_std), DIMENSION(npts,npft) :: tot_turnover
289: ! total soil and litter carbon (gC/(m**2))
290: REAL(r_std), DIMENSION(npts) :: tot_soil_carb
291: ! crown area of individuals (m**2)
292: REAL(r_std), DIMENSION(npts,npft) :: cn_ind
293: ! fraction that goes into plant part
294: REAL(r_std), DIMENSION(npts,npft,nparts) :: f_alloc
295: ! space availability for trees
296: REAL(r_std), DIMENSION(npts) :: avail_tree
297: ! space availability for grasses
298: REAL(r_std), DIMENSION(npts) :: avail_grass
299:
300: ! deforestation variables + EndOfYear
301: ! Do update of yearly variables? This variable must be .TRUE. once a year
302: LOGICAL :: EndOfYear
303: ! new "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
304: REAL(r_std), DIMENSION(npts,npft),INTENT(in) :: veget_max_new
305: ! new total natural space (fraction of total space)
306: REAL(r_std), DIMENSION(npts), INTENT(in) :: space_nat_new
307: ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
308: ! (10 or 100 + 1 : input from year of deforestation)
309: REAL(r_std),DIMENSION(npts,0:10), INTENT(inout) :: prod10
310: REAL(r_std),DIMENSION(npts,0:100), INTENT(inout) :: prod100
311: ! annual release from the 10/100 year-turnover pool compartments
312: REAL(r_std),DIMENSION(npts,10), INTENT(inout) :: flux10
313: REAL(r_std),DIMENSION(npts,100), INTENT(inout) :: flux100
314: ! release during first year following deforestation
315: REAL(r_std),DIMENSION(npts) :: convflux
316: ! total annual release from the 10/100 year-turnover pool
317: REAL(r_std),DIMENSION(npts) :: cflux_prod10, cflux_prod100
318: ! total products remaining in the pool after the annual release
319: REAL(r_std),DIMENSION(npts) :: prod10_total, prod100_total
320: ! total flux from conflux and the 10/100 year-turnover pool
321: REAL(r_std),DIMENSION(npts) :: cflux_prod_total
322: ! deforestation flag
323: LOGICAL, INTENT(in) :: defor
324:
325:
326: ! =========================================================================
327:
328: IF (bavard.GE.3) WRITE(numout,*) 'Entering stomate_lpj'
329:
330: !
331: ! 1 Initializations
332: !
333:
334: !
335: ! 1.1 set outputs to zero
336: !
337:
338: V------> co2_to_bm(:) = 0.0
339: V------ co2_fire(:) = 0.0
340: +V===== npp_daily(:,:) = 0.0
341: W**==== turnover_daily(:,:,:) = 0.0
342: *V-----> resp_maint(:,:) = 0.0
343: *V----- resp_growth(:,:) = 0.0
344:
345: !
346: ! 1.2 initialize some variables
347: !
348:
349: W++==== bm_to_litter(:,:,:) = 0.0
350: +V===== cn_ind(:,:) = 0.0
351:
352: !
353: ! 1.3 Prescribe some vegetation characteristics if the vegetation is not dynamic and
354: ! for agricultural PFTs.
355: ! IF the DGVM is not activated, the density of individuals and their crown
356: ! areas don't matter, but they should be defined for the case we switch on
357: ! the DGVM afterwards.
358: ! At first call, if the DGVM is not activated, impose a minimum biomass for
359: ! prescribed PFTs and declare them present.
360: !
361:
362: CALL prescribe (npts, &
363: space_nat, &
364: veget_max, PFTpresent, everywhere, when_growthinit, &
365: biomass, leaf_frac, ind, cn_ind)
366:
367: !
368: ! 2 climatic constraints for PFT presence and regenerativeness
369: ! call this even when DGVM is not activated so that "adapted" and "regenerate"
370: ! are kept up to date for the moment when the DGVM is activated.
371: !
372:
373: CALL constraints (npts, dt_days, &
374: t2m_month, t2m_min_daily, when_growthinit, &
375: adapted, regenerate)
376:
377: !
378: ! 3 PFTs in and out, based on climate criteria
379: !
380:
381: IF ( control%ok_dgvm ) THEN
382:
383: !
384: ! 3.1 do introduction/elimination
385: !
386:
387: CALL pftinout (npts, dt_days, adapted, regenerate, &
388: neighbours, space_nat, veget, veget_max, &
389: biomass, ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, &
390: PFTpresent, everywhere, when_growthinit, need_adjacent, RIP_time, &
391: co2_to_bm, &
392: avail_tree, avail_grass)
393:
394: !
395: ! 3.2 reset attributes for eliminated PFTs.
396: ! This also kills PFTs that had 0 leafmass during the last year. The message
397: ! "... after pftinout" is misleading in this case.
398: !
399:
400: CALL kill (npts, 'pftinout ', lm_lastyearmax, &
401: ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
402: lai, age, leaf_age, leaf_frac, &
403: when_growthinit, everywhere, veget, veget_max, bm_to_litter)
404:
405: !
406: ! 3.3 calculate new crown area and maximum vegetation cover
407: !
408:
409: CALL crown (npts, PFTpresent, &
410: ind, biomass, &
411: veget_max, cn_ind, height)
412:
413: ENDIF
414:
415: !
416: ! 4 phenology
417: !
418:
419: CALL phenology (npts, dt_days, PFTpresent, &
420: veget_max, space_nat, &
421: tlong_ref, t2m_month, t2m_week, gpp_daily, &
422: maxmoiavail_lastyear, minmoiavail_lastyear, &
423: moiavail_month, moiavail_week, &
424: gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
425: senescence, time_lowgpp, time_hum_min, &
426: biomass, leaf_frac, leaf_age, &
427: when_growthinit, co2_to_bm, lai)
428:
429: !
430: ! 5 allocation
431: !
432:
433: CALL alloc (npts, dt_days, &
434: lai, veget_max, senescence, when_growthinit, &
435: moiavail_week, tsoil_month, soilhum_month, &
436: biomass, leaf_age, leaf_frac, rprof, f_alloc)
437:
438: !
439: ! 6 maintenance and growth respiration. NPP
440: !
441:
442: CALL npp_calc (npts, dt_days, space_nat, &
443: PFTpresent, &
444: tlong_ref, t2m_daily, tsoil_daily, lai, rprof, &
445: gpp_daily, f_alloc, resp_maint_part,&
446: biomass, leaf_age, leaf_frac, age, &
447: resp_maint, resp_growth, npp_daily)
448:
449: IF ( control%ok_dgvm ) THEN
450:
451: ! new provisional crown area and maximum vegetation cover after growth
452:
453: CALL crown (npts, PFTpresent, &
454: ind, biomass, &
455: veget_max, cn_ind, height)
456:
457: ENDIF
458:
459: !
460: ! 7 fire.
461: !
462:
463: CALL fire (npts, dt_days, space_nat, litterpart, &
464: litterhum_daily, t2m_daily, lignin_struc, &
465: fireindex, firelitter, biomass, ind, &
466: litter, dead_leaves, bm_to_litter, black_carbon, &
467: co2_fire)
468:
469: IF ( control%ok_dgvm ) THEN
470:
471: ! reset attributes for eliminated PFTs
472:
473: CALL kill (npts, 'fire ', lm_lastyearmax, &
474: ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
475: lai, age, leaf_age, leaf_frac, &
476: when_growthinit, everywhere, veget, veget_max, bm_to_litter)
477:
478: ENDIF
479:
480: !
481: ! 8 tree mortality. Does not depend on age, therefore does not change crown area.
482: !
483:
484: CALL gap (npts, dt_days, &
485: npp_longterm, turnover_longterm, lm_lastyearmax, &
486: PFTpresent, biomass, ind, bm_to_litter)
487:
488: IF ( control%ok_dgvm ) THEN
489:
490: ! reset attributes for eliminated PFTs
491:
492: CALL kill (npts, 'gap ', lm_lastyearmax, &
493: ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
494: lai, age, leaf_age, leaf_frac, &
495: when_growthinit, everywhere, veget, veget_max, bm_to_litter)
496:
497: ENDIF
498:
499: !
500: ! 9 calculate vcmax, vjmax and photosynthesis temperatures
501: !
502:
503: CALL vmax (npts, dt_days, &
504: leaf_age, leaf_frac, &
505: vcmax, vjmax)
506:
507: CALL assim_temp (npts, tlong_ref, t2m_month, &
508: t_photo_min, t_photo_opt, t_photo_max)
509:
510: !
511: ! 10 leaf senescence and other turnover processes. New lai
512: !
513:
514: CALL turn (npts, dt_days, PFTpresent, &
515: herbivores, &
516: maxmoiavail_lastyear, minmoiavail_lastyear, &
517: moiavail_week, moiavail_month,tlong_ref, t2m_month, t2m_week, veget_max, &
518: leaf_age, leaf_frac, age, lai, biomass, &
519: turnover_daily, senescence,turnover_time)
520:
521: !
522: ! 11 light competition
523: !
524:
525: IF ( control%ok_dgvm ) THEN
526:
527: !
528: ! 11.1 do light competition
529: !
530:
531: CALL light (npts, dt_days, &
532: PFTpresent, cn_ind, lai, maxfpc_lastyear, &
533: ind, biomass, veget_lastlight, bm_to_litter)
534:
535: !
536: ! 11.2 reset attributes for eliminated PFTs
537: !
538:
539: CALL kill (npts, 'light ', lm_lastyearmax, &
540: ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
541: lai, age, leaf_age, leaf_frac, &
542: when_growthinit, everywhere, veget, veget_max, bm_to_litter)
543:
544: ENDIF
545:
546: !
547: ! 12 establishment of saplings
548: !
549:
550: IF ( control%ok_dgvm ) THEN
551:
552: !
553: ! 12.1 do establishment
554: !
555:
556: CALL establish (npts, dt_days, PFTpresent, regenerate, &
557: neighbours, resolution, space_nat, need_adjacent, herbivores, &
558: precip_lastyear, gdd0_lastyear, lm_lastyearmax, &
559: cn_ind, lai, avail_tree, avail_grass, &
560: leaf_age, leaf_frac, &
561: ind, biomass, age, everywhere, co2_to_bm)
562:
563: !
564: ! 12.2 calculate new crown area (and maximum vegetation cover)
565: !
566:
567: CALL crown (npts, PFTpresent, &
568: ind, biomass, &
569: veget_max, cn_ind, height)
570:
571: ENDIF
572:
573: !
574: ! 13 calculate final LAI and vegetation cover.
575: !
576:
577: CALL cover (npts, cn_ind, ind, biomass, &
578: veget_max, veget, lai)
579:
580: !
581: ! 14 the whole litter stuff:
582: ! litter update, lignin content, PFT parts, litter decay,
583: ! litter heterotrophic respiration, dead leaf soil cover.
584: ! No vertical discretisation in the soil for litter decay.
585: !
586:
587: ! 15.1 deforestation
588: IF(defor) then
589: IF(EndOfYear) then
590: CALL deforestation (npts, dt_days, space_nat,space_nat_new, veget_max, veget_max_new, &
591: biomass, ind, age, PFTpresent, senescence, when_growthinit, &
592: everywhere, veget, &
593: co2_to_bm, bm_to_litter, bm_sapl, tree, cn_ind,flux10,flux100, &
594: prod10,prod100,prod10_total,prod100_total,&
595: convflux,cflux_prod_total,cflux_prod10,cflux_prod100,leaf_frac,&
596: npp_longterm, lm_lastyearmax)
597:
598: ENDIF
599: ENDIF
600:
601:
602: V====== tot_soil_carb = (litter(:,istructural,inat,iabove) + litter(:,imetabolic,inat,iabove) + &
603: & litter(:,istructural,inat,ibelow) + litter(:,imetabolic,inat,ibelow) + &
604: & carbon(:,iactive,inat) + &
605: & carbon(:,islow,inat)+ carbon(:,ipassive,inat))*space_nat(:) + &
606: & (litter(:,istructural,iagri,iabove)+ litter(:,istructural,iagri,ibelow) + &
607: & litter(:,imetabolic,iagri,ibelow) + litter(:,imetabolic,iagri,iabove) + &
608: & carbon(:,iactive,iagri) + carbon(:,islow,iagri) + &
609: & carbon(:,ipassive,iagri))*(1-space_nat(:))+ deadleaf_cover
610:
611: *V-----> tot_live_biomass = biomass(:,:,ileaf) + biomass(:,:,isapabove) + biomass(:,:,isapbelow) +&
612: || & biomass(:,:,iheartabove) + biomass(:,:,iheartbelow) + &
613: || & biomass(:,:,iroot)+ biomass(:,:,ifruit)+ biomass(:,:,icarbres)
614: ||
615: || tot_turnover = turnover_daily(:,:,ileaf) + turnover_daily(:,:,isapabove) + &
616: || & turnover_daily(:,:,isapbelow) + turnover_daily(:,:,iheartabove) + &
617: || & turnover_daily(:,:,iheartbelow) + turnover_daily(:,:,iroot) + &
618: || & turnover_daily(:,:,ileaf) + turnover_daily(:,:,icarbres)
619: ||
620: *V----- tot_bm_to_litter = bm_to_litter(:,:,ileaf) + bm_to_litter(:,:,isapabove) +&
621: & bm_to_litter(:,:,isapbelow) + bm_to_litter(:,:,iheartbelow) +&
622: & bm_to_litter(:,:,iheartabove) + bm_to_litter(:,:,iroot) + &
623: & bm_to_litter(:,:,ifruit) + bm_to_litter(:,:,icarbres)
624:
625: !
626: ! 17 history
627: !
628:
629: ! 2d
630:
631: CALL histwrite (hist_id_stomate, 'RESOLUTION_X', itime, &
632: resolution(:,1), npts, hori_index)
633: CALL histwrite (hist_id_stomate, 'RESOLUTION_Y', itime, &
634: resolution(:,2), npts, hori_index)
635: CALL histwrite (hist_id_stomate, 'SPACE_NAT', itime, &
636: space_nat(:), npts, hori_index)
637: ! CALL histwrite (hist_id_stomate, 'TOTAL_SOIL_CARB', itime, &
638: ! tot_soil_carb, npts, hori_index)
639: CALL histwrite (hist_id_stomate, 'LITTER_STR_AB_NAT', itime, &
640: litter(:,istructural,inat,iabove), npts, hori_index)
641: CALL histwrite (hist_id_stomate, 'LITTER_STR_AB_AGRI', itime, &
642: litter(:,istructural,iagri,iabove), npts, hori_index)
643: CALL histwrite (hist_id_stomate, 'LITTER_MET_AB_NAT', itime, &
644: litter(:,imetabolic,inat,iabove), npts, hori_index)
645: CALL histwrite (hist_id_stomate, 'LITTER_MET_AB_AGRI', itime, &
646: litter(:,imetabolic,iagri,iabove), npts, hori_index)
647: CALL histwrite (hist_id_stomate, 'LITTER_STR_BE_NAT', itime, &
648: litter(:,istructural,inat,ibelow), npts, hori_index)
649: CALL histwrite (hist_id_stomate, 'LITTER_STR_BE_AGRI', itime, &
650: litter(:,istructural,iagri,ibelow), npts, hori_index)
651: CALL histwrite (hist_id_stomate, 'LITTER_MET_BE_NAT', itime, &
652: litter(:,imetabolic,inat,ibelow), npts, hori_index)
653: CALL histwrite (hist_id_stomate, 'LITTER_MET_BE_AGRI', itime, &
654: litter(:,imetabolic,iagri,ibelow), npts, hori_index)
655: CALL histwrite (hist_id_stomate, 'DEADLEAF_COVER', itime, &
656: deadleaf_cover, npts, hori_index)
657: CALL histwrite (hist_id_stomate, 'CARBON_ACTIVE_NAT', itime, &
658: carbon(:,iactive,inat), npts, hori_index)
659: CALL histwrite (hist_id_stomate, 'CARBON_ACTIVE_AGRI', itime, &
660: carbon(:,iactive,iagri), npts, hori_index)
661: CALL histwrite (hist_id_stomate, 'CARBON_SLOW_NAT', itime, &
662: carbon(:,islow,inat), npts, hori_index)
663: CALL histwrite (hist_id_stomate, 'CARBON_SLOW_AGRI', itime, &
664: carbon(:,islow,iagri), npts, hori_index)
665: CALL histwrite (hist_id_stomate, 'CARBON_PASSIVE_NAT', itime, &
666: carbon(:,ipassive,inat), npts, hori_index)
667: CALL histwrite (hist_id_stomate, 'CARBON_PASSIVE_AGRI', itime, &
668: carbon(:,ipassive,iagri), npts, hori_index)
669: CALL histwrite (hist_id_stomate, 'T2M_MONTH', itime, &
670: t2m_month, npts, hori_index)
671: CALL histwrite (hist_id_stomate, 'T2M_WEEK', itime, &
672: t2m_week, npts, hori_index)
673: CALL histwrite (hist_id_stomate, 'HET_RESP_NAT', itime, &
674: resp_hetero(:,inat), npts, hori_index)
675: CALL histwrite (hist_id_stomate, 'HET_RESP_AGRI', itime, &
676: resp_hetero(:,iagri), npts, hori_index)
677: CALL histwrite (hist_id_stomate, 'BLACK_CARBON', itime, &
678: black_carbon, npts, hori_index)
679: CALL histwrite (hist_id_stomate, 'FIREINDEX_NAT', itime, &
680: fireindex(:,inat), npts, hori_index)
681: CALL histwrite (hist_id_stomate, 'LITTERHUM', itime, &
682: litterhum_daily, npts, hori_index)
683: CALL histwrite (hist_id_stomate, 'CO2_FIRE', itime, &
684: co2_fire, npts, hori_index)
685: CALL histwrite (hist_id_stomate, 'CO2_TAKEN', itime, &
686: co2_to_bm, npts, hori_index)
687: ! deforestation variables
688: CALL histwrite (hist_id_stomate, 'CONVFLUX', itime, &
689: convflux, npts, hori_index)
690: CALL histwrite (hist_id_stomate, 'CFLUX_PROD10', itime, &
691: cflux_prod10, npts, hori_index)
692: CALL histwrite (hist_id_stomate, 'CFLUX_PROD100', itime, &
693: cflux_prod100, npts, hori_index)
694:
695: ! 3d
696:
697: CALL histwrite (hist_id_stomate, 'LAI', itime, &
698: lai, npts*npft, horipft_index)
699: CALL histwrite (hist_id_stomate, 'VEGET', itime, &
700: veget, npts*npft, horipft_index)
701: CALL histwrite (hist_id_stomate, 'VEGET_MAX', itime, &
702: veget_max, npts*npft, horipft_index)
703: CALL histwrite (hist_id_stomate, 'NPP', itime, &
704: npp_daily, npts*npft, horipft_index)
705: CALL histwrite (hist_id_stomate, 'GPP', itime, &
706: gpp_daily, npts*npft, horipft_index)
707: CALL histwrite (hist_id_stomate, 'IND', itime, &
708: ind, npts*npft, horipft_index)
709: ! CALL histwrite (hist_id_stomate, 'TOTAL_M', itime, &
710: ! tot_live_biomass, npts*npft, horipft_index)
711: CALL histwrite (hist_id_stomate, 'LEAF_M', itime, &
712: biomass(:,:,ileaf), npts*npft, horipft_index)
713: CALL histwrite (hist_id_stomate, 'SAP_M_AB', itime, &
714: biomass(:,:,isapabove), npts*npft, horipft_index)
715: CALL histwrite (hist_id_stomate, 'SAP_M_BE', itime, &
716: biomass(:,:,isapbelow), npts*npft, horipft_index)
717: CALL histwrite (hist_id_stomate, 'HEART_M_AB', itime, &
718: biomass(:,:,iheartabove), npts*npft, horipft_index)
719: CALL histwrite (hist_id_stomate, 'HEART_M_BE', itime, &
720: biomass(:,:,iheartbelow), npts*npft, horipft_index)
721: CALL histwrite (hist_id_stomate, 'ROOT_M', itime, &
722: biomass(:,:,iroot), npts*npft, horipft_index)
723: CALL histwrite (hist_id_stomate, 'FRUIT_M', itime, &
724: biomass(:,:,ifruit), npts*npft, horipft_index)
725: CALL histwrite (hist_id_stomate, 'RESERVE_M', itime, &
726: biomass(:,:,icarbres), npts*npft, horipft_index)
727: ! CALL histwrite (hist_id_stomate, 'TOTAL_TURN', itime, &
728: ! tot_turnover, npts*npft, horipft_index)
729: CALL histwrite (hist_id_stomate, 'LEAF_TURN', itime, &
730: turnover_daily(:,:,ileaf), npts*npft, horipft_index)
731: CALL histwrite (hist_id_stomate, 'SAP_AB_TURN', itime, &
732: turnover_daily(:,:,isapabove), npts*npft, horipft_index)
733: CALL histwrite (hist_id_stomate, 'ROOT_TURN', itime, &
734: turnover_daily(:,:,iroot), npts*npft, horipft_index)
735: CALL histwrite (hist_id_stomate, 'FRUIT_TURN', itime, &
736: turnover_daily(:,:,ifruit), npts*npft, horipft_index)
737: ! CALL histwrite (hist_id_stomate, 'TOTAL_BM_LITTER', itime, &
738: ! tot_bm_to_litter, npts*npft, horipft_index)
739: CALL histwrite (hist_id_stomate, 'LEAF_BM_LITTER', itime, &
740: bm_to_litter(:,:,ileaf), npts*npft, horipft_index)
741: CALL histwrite (hist_id_stomate, 'SAP_AB_BM_LITTER', itime, &
742: bm_to_litter(:,:,isapabove), npts*npft, horipft_index)
743: CALL histwrite (hist_id_stomate, 'SAP_BE_BM_LITTER', itime, &
744: bm_to_litter(:,:,isapbelow), npts*npft, horipft_index)
745: CALL histwrite (hist_id_stomate, 'HEART_AB_BM_LITTER', itime, &
746: bm_to_litter(:,:,iheartabove), npts*npft, horipft_index)
747: CALL histwrite (hist_id_stomate, 'HEART_BE_BM_LITTER', itime, &
748: bm_to_litter(:,:,iheartbelow), npts*npft, horipft_index)
749: CALL histwrite (hist_id_stomate, 'ROOT_BM_LITTER', itime, &
750: bm_to_litter(:,:,iroot), npts*npft, horipft_index)
751: CALL histwrite (hist_id_stomate, 'FRUIT_BM_LITTER', itime, &
752: bm_to_litter(:,:,ifruit), npts*npft, horipft_index)
753: CALL histwrite (hist_id_stomate, 'RESERVE_BM_LITTER', itime, &
754: bm_to_litter(:,:,icarbres), npts*npft, horipft_index)
755: CALL histwrite (hist_id_stomate, 'MAINT_RESP', itime, &
756: resp_maint, npts*npft, horipft_index)
757: CALL histwrite (hist_id_stomate, 'GROWTH_RESP', itime, &
758: resp_growth, npts*npft, horipft_index)
759: CALL histwrite (hist_id_stomate, 'AGE', itime, &
760: age, npts*npft, horipft_index)
761: CALL histwrite (hist_id_stomate, 'HEIGHT', itime, &
762: height, npts*npft, horipft_index)
763: CALL histwrite (hist_id_stomate, 'MOISTRESS', itime, &
764: moiavail_week, npts*npft, horipft_index)
765: CALL histwrite (hist_id_stomate, 'VCMAX', itime, &
766: vcmax, npts*npft, horipft_index)
767: CALL histwrite (hist_id_stomate, 'TURNOVER_TIME', itime, &
768: turnover_time, npts*npft, horipft_index)
769: ! deforestation variables
770: CALL histwrite (hist_id_stomate, 'PROD10', itime, &
771: prod10, npts*11, horip11_index)
772: CALL histwrite (hist_id_stomate, 'PROD100', itime, &
773: prod100, npts*101, horip101_index)
774: CALL histwrite (hist_id_stomate, 'FLUX10', itime, &
775: flux10, npts*10, horip10_index)
776: CALL histwrite (hist_id_stomate, 'FLUX100', itime, &
777: flux100, npts*100, horip100_index)
778:
779: IF (bavard.GE.4) WRITE(numout,*) 'Leaving stomate_lpj'
780:
781: END SUBROUTINE StomateLpj
782:
783: END MODULE stomate_lpj
ORCHIDEE/src_stomate/i.stomate.L 0000754 0103600 0005670 00000701635 11164403473 016304 0 ustar acamlmd lmdjus Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:37:15 2008
FILE NAME: i.stomate.f90
PROGRAM NAME: stomate
DIAGNOSTIC LIST
LINE LEVEL( NO.): DIAGNOSTIC MESSAGE
576 vec ( 3): Unvectorized loop.
577 opt (1592): Outer loop unrolled inside inner loop.
577 vec ( 4): Vectorized array expression.
580 vec ( 4): Vectorized array expression.
581 vec ( 3): Unvectorized loop.
582 opt (1592): Outer loop unrolled inside inner loop.
582 vec ( 4): Vectorized array expression.
587 opt (1593): Loop nest collapsed into one loop.
587 vec ( 4): Vectorized array expression.
598 vec ( 4): Vectorized array expression.
739 vec ( 4): Vectorized array expression.
739 vec ( 4): Vectorized array expression.
740 vec ( 4): Vectorized array expression.
741 vec ( 4): Vectorized array expression.
813 vec ( 4): Vectorized array expression.
816 vec ( 4): Vectorized array expression.
818 vec ( 4): Vectorized array expression.
822 vec ( 4): Vectorized array expression.
824 vec ( 4): Vectorized array expression.
826 vec ( 4): Vectorized array expression.
828 vec ( 4): Vectorized array expression.
833 opt (1592): Outer loop unrolled inside inner loop.
833 vec ( 4): Vectorized array expression.
833 vec ( 4): Vectorized array expression.
875 vec ( 3): Unvectorized loop.
875 vec ( 8): Unvectorizable loop structure.
878 vec ( 9): Vectorization obstructive statement.
890 vec ( 4): Vectorized array expression.
890 vec ( 4): Vectorized array expression.
893 vec ( 4): Vectorized array expression.
901 opt (1593): Loop nest collapsed into one loop.
901 vec ( 4): Vectorized array expression.
902 vec ( 4): Vectorized array expression.
903 opt (1593): Loop nest collapsed into one loop.
903 vec ( 4): Vectorized array expression.
904 opt (1593): Loop nest collapsed into one loop.
904 vec ( 4): Vectorized array expression.
905 opt (1593): Loop nest collapsed into one loop.
905 vec ( 4): Vectorized array expression.
993 vec ( 3): Unvectorized loop.
993 vec ( 13): Overhead of loop division is too large.
995 opt (1593): Loop nest collapsed into one loop.
995 vec ( 4): Vectorized array expression.
997 opt (1593): Loop nest collapsed into one loop.
997 vec ( 4): Vectorized array expression.
999 opt (1593): Loop nest collapsed into one loop.
999 vec ( 4): Vectorized array expression.
1001 vec ( 4): Vectorized array expression.
1004 opt (1017): Subroutine call prevents optimization.
1004 vec ( 17): Unvectorizable statement.
1007 vec ( 17): Unvectorizable statement.
1008 opt (1593): Loop nest collapsed into one loop.
1008 vec ( 4): Vectorized array expression.
1009 opt (1593): Loop nest collapsed into one loop.
1009 vec ( 4): Vectorized array expression.
1010 opt (1593): Loop nest collapsed into one loop.
1010 vec ( 4): Vectorized array expression.
1011 vec ( 4): Vectorized array expression.
1013 vec ( 22): Dependency unknown. Unvectorizable dependency is assumed.:iatt
1049 vec ( 4): Vectorized array expression.
1061 vec ( 4): Vectorized array expression.
1064 vec ( 4): Vectorized array expression.
1150 opt (1593): Loop nest collapsed into one loop.
1150 vec ( 4): Vectorized array expression.
1151 opt (1593): Loop nest collapsed into one loop.
1151 vec ( 4): Vectorized array expression.
1152 opt (1593): Loop nest collapsed into one loop.
1152 vec ( 4): Vectorized array expression.
1153 vec ( 4): Vectorized array expression.
1161 vec ( 4): Vectorized array expression.
1187 vec ( 3): Unvectorized loop.
1187 vec ( 13): Overhead of loop division is too large.
1191 vec ( 4): Vectorized array expression.
1199 vec ( 4): Vectorized array expression.
1203 vec ( 4): Vectorized array expression.
1204 vec ( 3): Unvectorized loop.
1204 vec ( 13): Overhead of loop division is too large.
1206 opt (1036): Potential feedback - use directive if OK.
1206 vec ( 4): Vectorized array expression.
1237 vec ( 4): Vectorized array expression.
1247 opt (1593): Loop nest collapsed into one loop.
1247 vec ( 4): Vectorized array expression.
1249 vec ( 3): Unvectorized loop.
1250 opt (1592): Outer loop unrolled inside inner loop.
1250 vec ( 4): Vectorized array expression.
1254 opt (1592): Outer loop unrolled inside inner loop.
1254 vec ( 4): Vectorized array expression.
1254 vec ( 4): Vectorized array expression.
1262 vec ( 4): Vectorized array expression.
1262 vec ( 4): Vectorized array expression.
1262 vec ( 4): Vectorized array expression.
1262 vec ( 4): Vectorized array expression.
1268 vec ( 4): Vectorized array expression.
1268 vec ( 4): Vectorized array expression.
1279 vec ( 4): Vectorized array expression.
1279 vec ( 4): Vectorized array expression.
1303 vec ( 4): Vectorized array expression.
1305 vec ( 3): Unvectorized loop.
1305 vec ( 13): Overhead of loop division is too large.
1307 vec ( 4): Vectorized array expression.
1356 vec ( 3): Unvectorized loop.
1356 vec ( 13): Overhead of loop division is too large.
1357 vec ( 4): Vectorized array expression.
1445 vec ( 3): Unvectorized loop.
1445 vec ( 8): Unvectorizable loop structure.
1448 vec ( 3): Unvectorized loop.
1448 vec ( 8): Unvectorizable loop structure.
1457 vec ( 1): Vectorized loop.
1468 vec ( 4): Vectorized array expression.
1468 vec ( 4): Vectorized array expression.
1468 vec ( 4): Vectorized array expression.
1468 vec ( 4): Vectorized array expression.
1468 vec ( 4): Vectorized array expression.
1468 vec ( 4): Vectorized array expression.
1471 vec ( 4): Vectorized array expression.
1471 vec ( 4): Vectorized array expression.
1477 vec ( 4): Vectorized array expression.
1489 vec ( 4): Vectorized array expression.
1489 vec ( 4): Vectorized array expression.
1499 vec ( 4): Vectorized array expression.
1499 vec ( 4): Vectorized array expression.
1500 vec ( 4): Vectorized array expression.
1500 vec ( 4): Vectorized array expression.
1501 vec ( 3): Unvectorized loop.
1501 vec ( 13): Overhead of loop division is too large.
1503 vec ( 4): Vectorized array expression.
1507 vec ( 4): Vectorized array expression.
1515 vec ( 4): Vectorized array expression.
1526 vec ( 4): Vectorized array expression.
1527 vec ( 4): Vectorized array expression.
1527 vec ( 4): Vectorized array expression.
1529 vec ( 4): Vectorized array expression.
1531 vec ( 4): Vectorized array expression.
1533 vec ( 4): Vectorized array expression.
1535 vec ( 4): Vectorized array expression.
1537 vec ( 4): Vectorized array expression.
1537 vec ( 4): Vectorized array expression.
1539 vec ( 4): Vectorized array expression.
1539 vec ( 4): Vectorized array expression.
1541 vec ( 4): Vectorized array expression.
1543 vec ( 4): Vectorized array expression.
1543 vec ( 4): Vectorized array expression.
1545 vec ( 4): Vectorized array expression.
1545 vec ( 4): Vectorized array expression.
1548 vec ( 4): Vectorized array expression.
1555 vec ( 4): Vectorized array expression.
1556 vec ( 4): Vectorized array expression.
1556 vec ( 4): Vectorized array expression.
1557 vec ( 4): Vectorized array expression.
1558 vec ( 4): Vectorized array expression.
1559 vec ( 4): Vectorized array expression.
1560 vec ( 4): Vectorized array expression.
1561 vec ( 4): Vectorized array expression.
1561 vec ( 4): Vectorized array expression.
1562 vec ( 4): Vectorized array expression.
1562 vec ( 4): Vectorized array expression.
1563 vec ( 4): Vectorized array expression.
1564 vec ( 4): Vectorized array expression.
1564 vec ( 4): Vectorized array expression.
1565 vec ( 4): Vectorized array expression.
1565 vec ( 4): Vectorized array expression.
1566 vec ( 4): Vectorized array expression.
1566 vec ( 4): Vectorized array expression.
1580 vec ( 3): Unvectorized loop.
1580 vec ( 13): Overhead of loop division is too large.
1582 vec ( 20): Unvectorizable dependency.:isf
1594 vec ( 4): Vectorized array expression.
1596 vec ( 3): Unvectorized loop.
1597 vec ( 4): Vectorized array expression.
1602 vec ( 4): Vectorized array expression.
1603 vec ( 3): Unvectorized loop.
1604 vec ( 4): Vectorized array expression.
1616 vec ( 4): Vectorized array expression.
1627 vec ( 4): Vectorized array expression.
1633 vec ( 4): Vectorized array expression.
1635 vec ( 4): Vectorized array expression.
1635 vec ( 26): Macro operation Sum/InnerProd.
1656 vec ( 4): Vectorized array expression.
1661 opt (1593): Loop nest collapsed into one loop.
1661 vec ( 4): Vectorized array expression.
1662 vec ( 4): Vectorized array expression.
1663 vec ( 4): Vectorized array expression.
1664 vec ( 4): Vectorized array expression.
1665 vec ( 4): Vectorized array expression.
1666 opt (1593): Loop nest collapsed into one loop.
1666 vec ( 4): Vectorized array expression.
1667 opt (1593): Loop nest collapsed into one loop.
1667 vec ( 4): Vectorized array expression.
1668 vec ( 4): Vectorized array expression.
1669 opt (1593): Loop nest collapsed into one loop.
1669 vec ( 4): Vectorized array expression.
1670 opt (1593): Loop nest collapsed into one loop.
1670 vec ( 4): Vectorized array expression.
1671 opt (1593): Loop nest collapsed into one loop.
1671 vec ( 4): Vectorized array expression.
1686 vec ( 4): Vectorized array expression.
1688 vec ( 3): Unvectorized loop.
1688 vec ( 13): Overhead of loop division is too large.
1689 vec ( 4): Vectorized array expression.
1695 vec ( 4): Vectorized array expression.
1699 vec ( 3): Unvectorized loop.
1700 vec ( 4): Vectorized array expression.
1700 vec ( 4): Vectorized array expression.
1711 vec ( 4): Vectorized array expression.
1726 warn ( 82): Name "t_maint_radia" is not used.
1726 warn ( 82): Name "rpc" is not used.
1726 warn ( 82): Name "ji" is not used.
1726 warn ( 82): Name "slope" is not used.
1726 warn ( 82): Name "trans_veg" is not used.
1726 warn ( 82): Name "cvegtot" is not used.
1726 warn ( 82): Name "l" is not used.
1726 warn ( 82): Name "t_root" is not used.
1726 warn ( 82): Name "year_bissex" is not used.
1726 warn ( 82): Name "tmp_day" is not used.
1726 warn ( 82): Name "coeff_maint" is not used.
1726 warn ( 83): Dummy argument "ldrestart_read" is not used.
1726 warn ( 82): Name "tl" is not used.
1726 warn ( 82): Name "hist_days" is not used.
1726 warn ( 82): Name "lcanop" is not used.
2000 opt (1593): Loop nest collapsed into one loop.
2000 vec ( 4): Vectorized array expression.
2038 vec ( 4): Vectorized array expression.
2046 vec ( 1): Vectorized loop.
2047 opt (1592): Outer loop unrolled inside inner loop.
2053 vec ( 1): Vectorized loop.
2053 vec ( 1): Vectorized loop.
2054 opt (1592): Outer loop unrolled inside inner loop.
2059 vec ( 1): Vectorized loop.
2060 opt (1592): Outer loop unrolled inside inner loop.
2065 vec ( 1): Vectorized loop.
2065 vec ( 1): Vectorized loop.
2066 opt (1592): Outer loop unrolled inside inner loop.
2071 vec ( 1): Vectorized loop.
2071 vec ( 1): Vectorized loop.
2072 opt (1592): Outer loop unrolled inside inner loop.
2104 opt (1593): Loop nest collapsed into one loop.
2104 vec ( 4): Vectorized array expression.
2105 opt (1593): Loop nest collapsed into one loop.
2105 vec ( 4): Vectorized array expression.
2107 warn ( 82): Name "zsoil" is not used.
2107 warn ( 82): Name "zcanop" is not used.
2107 warn ( 82): Name "l" is not used.
2107 warn ( 82): Name "tmp_day" is not used.
2107 warn ( 82): Name "veget_ori_on_disk" is not used.
2348 opt (1593): Loop nest collapsed into one loop.
2348 vec ( 4): Vectorized array expression.
2349 opt (1593): Loop nest collapsed into one loop.
2349 vec ( 4): Vectorized array expression.
2350 opt (1593): Loop nest collapsed into one loop.
2350 vec ( 4): Vectorized array expression.
2351 opt (1593): Loop nest collapsed into one loop.
2351 vec ( 4): Vectorized array expression.
2352 vec ( 4): Vectorized array expression.
2387 vec ( 4): Vectorized array expression.
2388 vec ( 3): Unvectorized loop.
2388 vec ( 13): Overhead of loop division is too large.
2390 vec ( 4): Vectorized array expression.
2397 opt (1593): Loop nest collapsed into one loop.
2397 vec ( 4): Vectorized array expression.
2433 opt (1593): Loop nest collapsed into one loop.
2433 vec ( 4): Vectorized array expression.
2438 opt (1593): Loop nest collapsed into one loop.
2438 vec ( 4): Vectorized array expression.
2487 vec ( 3): Unvectorized loop.
2487 vec ( 13): Overhead of loop division is too large.
2488 vec ( 4): Vectorized array expression.
2505 opt (1593): Loop nest collapsed into one loop.
2505 vec ( 4): Vectorized array expression.
2507 vec ( 3): Unvectorized loop.
2507 vec ( 13): Overhead of loop division is too large.
2508 opt (1036): Potential feedback - use directive if OK.
2508 vec ( 4): Vectorized array expression.
2511 opt (1036): Potential feedback - use directive if OK.
2521 vec ( 4): Vectorized array expression.
2523 vec ( 3): Unvectorized loop.
2523 vec ( 13): Overhead of loop division is too large.
2525 opt (1019): Feedback of scalar value from one loop pass to another.
2525 vec ( 4): Vectorized array expression.
2527 opt (1019): Feedback of scalar value from one loop pass to another.
2532 vec ( 4): Vectorized array expression.
2537 vec ( 3): Unvectorized loop.
2537 vec ( 13): Overhead of loop division is too large.
2538 vec ( 4): Vectorized array expression.
2544 vec ( 4): Vectorized array expression.
2593 vec ( 4): Vectorized array expression.
2593 vec ( 4): Vectorized array expression.
2594 opt (1592): Outer loop unrolled inside inner loop.
2595 vec ( 3): Unvectorized loop.
2595 vec ( 13): Overhead of loop division is too large.
2596 opt (1036): Potential feedback - use directive if OK.
2596 vec ( 4): Vectorized array expression.
2598 opt (1036): Potential feedback - use directive if OK.
2601 opt (1592): Outer loop unrolled inside inner loop.
2601 vec ( 4): Vectorized array expression.
2601 vec ( 4): Vectorized array expression.
2607 vec ( 4): Vectorized array expression.
2703 opt (1593): Loop nest collapsed into one loop.
2703 vec ( 4): Vectorized array expression.
2704 opt (1593): Loop nest collapsed into one loop.
2704 vec ( 4): Vectorized array expression.
2705 opt (1593): Loop nest collapsed into one loop.
2705 vec ( 4): Vectorized array expression.
2706 opt (1593): Loop nest collapsed into one loop.
2706 vec ( 4): Vectorized array expression.
2707 opt (1593): Loop nest collapsed into one loop.
2707 vec ( 4): Vectorized array expression.
2708 opt (1593): Loop nest collapsed into one loop.
2708 vec ( 4): Vectorized array expression.
2709 opt (1593): Loop nest collapsed into one loop.
2709 vec ( 4): Vectorized array expression.
2710 opt (1593): Loop nest collapsed into one loop.
2710 vec ( 4): Vectorized array expression.
2711 opt (1593): Loop nest collapsed into one loop.
2711 vec ( 4): Vectorized array expression.
2712 opt (1593): Loop nest collapsed into one loop.
2712 vec ( 4): Vectorized array expression.
2713 opt (1593): Loop nest collapsed into one loop.
2713 vec ( 4): Vectorized array expression.
2714 opt (1593): Loop nest collapsed into one loop.
2714 vec ( 4): Vectorized array expression.
2715 opt (1593): Loop nest collapsed into one loop.
2715 vec ( 4): Vectorized array expression.
2716 opt (1593): Loop nest collapsed into one loop.
2716 vec ( 4): Vectorized array expression.
2741 vec ( 3): Unvectorized loop.
2749 vec ( 9): Vectorization obstructive statement.
2755 vec ( 3): Unvectorized loop.
2757 opt (1017): Subroutine call prevents optimization.
2757 vec ( 10): Vectorization obstructive procedure reference.:gather_r1
2763 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2764 vec ( 9): Vectorization obstructive statement.
2764 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_2d_eightbytereal
2769 vec ( 10): Vectorization obstructive procedure reference.:gather_r2
2775 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2776 vec ( 9): Vectorization obstructive statement.
2776 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_3d_eightbytereal
2781 vec ( 10): Vectorization obstructive procedure reference.:gather_r1
2787 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2788 vec ( 9): Vectorization obstructive statement.
2788 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_2d_eightbytereal
2793 vec ( 10): Vectorization obstructive procedure reference.:gather_r1
2799 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2800 vec ( 9): Vectorization obstructive statement.
2800 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_2d_eightbytereal
2805 vec ( 10): Vectorization obstructive procedure reference.:gather_r1
2811 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2812 vec ( 9): Vectorization obstructive statement.
2812 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_2d_eightbytereal
2817 vec ( 10): Vectorization obstructive procedure reference.:gather_r1
2823 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2824 vec ( 9): Vectorization obstructive statement.
2824 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_2d_eightbytereal
2829 vec ( 10): Vectorization obstructive procedure reference.:gather_r2
2835 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2836 vec ( 9): Vectorization obstructive statement.
2836 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_3d_eightbytereal
2841 vec ( 10): Vectorization obstructive procedure reference.:gather_r2
2847 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2848 vec ( 9): Vectorization obstructive statement.
2848 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_3d_eightbytereal
2853 vec ( 10): Vectorization obstructive procedure reference.:gather_r1
2859 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2860 vec ( 9): Vectorization obstructive statement.
2860 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_2d_eightbytereal
2865 vec ( 10): Vectorization obstructive procedure reference.:gather_r2
2871 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2872 vec ( 9): Vectorization obstructive statement.
2872 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_3d_eightbytereal
2877 vec ( 10): Vectorization obstructive procedure reference.:gather_r3
2883 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2884 vec ( 9): Vectorization obstructive statement.
2884 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_4d_eightbytereal
2889 vec ( 10): Vectorization obstructive procedure reference.:gather_r2
2895 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2896 vec ( 9): Vectorization obstructive statement.
2896 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_3d_eightbytereal
2901 vec ( 10): Vectorization obstructive procedure reference.:gather_r2
2907 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2908 vec ( 9): Vectorization obstructive statement.
2908 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_3d_eightbytereal
2913 vec ( 10): Vectorization obstructive procedure reference.:gather_r2
2919 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2920 vec ( 9): Vectorization obstructive statement.
2920 vec ( 10): Vectorization obstructive procedure reference.:nf90_put_var_3d_eightbytereal
2926 vec ( 4): Vectorized array expression.
2948 vec ( 2): Partially vectorized loop.
2948 vec ( 24): Iteration count is assumed. Iteration count=80000
2948 vec ( 25): Work vectors are used. Size=320000byte
2950 vec ( 4): Vectorized array expression.
2951 opt (1593): Loop nest collapsed into one loop.
2951 vec ( 4): Vectorized array expression.
2952 vec ( 4): Vectorized array expression.
2953 vec ( 4): Vectorized array expression.
2954 vec ( 4): Vectorized array expression.
2955 vec ( 4): Vectorized array expression.
2956 opt (1593): Loop nest collapsed into one loop.
2956 vec ( 4): Vectorized array expression.
2957 opt (1593): Loop nest collapsed into one loop.
2957 vec ( 4): Vectorized array expression.
2958 vec ( 4): Vectorized array expression.
2959 opt (1593): Loop nest collapsed into one loop.
2959 vec ( 4): Vectorized array expression.
2960 opt (1593): Loop nest collapsed into one loop.
2960 vec ( 4): Vectorized array expression.
2961 opt (1593): Loop nest collapsed into one loop.
2961 vec ( 4): Vectorized array expression.
2962 opt (1593): Loop nest collapsed into one loop.
2962 vec ( 4): Vectorized array expression.
2963 opt (1593): Loop nest collapsed into one loop.
2963 vec ( 4): Vectorized array expression.
2973 vec ( 3): Unvectorized loop.
2982 vec ( 9): Vectorization obstructive statement.
2990 vec ( 3): Unvectorized loop.
2997 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
2998 opt (1017): Subroutine call prevents optimization.
2998 vec ( 9): Vectorization obstructive statement.
2998 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_2d_eightbytereal
3002 vec ( 10): Vectorization obstructive procedure reference.:scatter_r1
3009 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3010 vec ( 9): Vectorization obstructive statement.
3010 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_3d_eightbytereal
3014 vec ( 10): Vectorization obstructive procedure reference.:scatter_r2
3021 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3022 vec ( 9): Vectorization obstructive statement.
3022 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_2d_eightbytereal
3026 vec ( 10): Vectorization obstructive procedure reference.:scatter_r1
3033 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3034 vec ( 9): Vectorization obstructive statement.
3034 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_2d_eightbytereal
3038 vec ( 10): Vectorization obstructive procedure reference.:scatter_r1
3045 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3046 vec ( 9): Vectorization obstructive statement.
3046 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_2d_eightbytereal
3050 vec ( 10): Vectorization obstructive procedure reference.:scatter_r1
3057 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3058 vec ( 9): Vectorization obstructive statement.
3058 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_2d_eightbytereal
3062 vec ( 10): Vectorization obstructive procedure reference.:scatter_r1
3069 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3070 vec ( 9): Vectorization obstructive statement.
3070 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_3d_eightbytereal
3074 vec ( 10): Vectorization obstructive procedure reference.:scatter_r2
3081 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3082 vec ( 9): Vectorization obstructive statement.
3082 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_3d_eightbytereal
3086 vec ( 10): Vectorization obstructive procedure reference.:scatter_r2
3093 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3094 vec ( 9): Vectorization obstructive statement.
3094 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_2d_eightbytereal
3098 vec ( 10): Vectorization obstructive procedure reference.:scatter_r1
3105 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3106 vec ( 9): Vectorization obstructive statement.
3106 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_3d_eightbytereal
3110 vec ( 10): Vectorization obstructive procedure reference.:scatter_r2
3117 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3118 vec ( 9): Vectorization obstructive statement.
3118 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_4d_eightbytereal
3122 vec ( 10): Vectorization obstructive procedure reference.:scatter_r3
3129 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3130 vec ( 9): Vectorization obstructive statement.
3130 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_3d_eightbytereal
3134 vec ( 10): Vectorization obstructive procedure reference.:scatter_r2
3141 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3142 vec ( 9): Vectorization obstructive statement.
3142 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_3d_eightbytereal
3146 vec ( 10): Vectorization obstructive procedure reference.:scatter_r2
3153 vec ( 10): Vectorization obstructive procedure reference.:nf90_inq_varid
3154 vec ( 9): Vectorization obstructive statement.
3154 vec ( 10): Vectorization obstructive procedure reference.:nf90_get_var_3d_eightbytereal
3158 vec ( 10): Vectorization obstructive procedure reference.:scatter_r2
3183 vec ( 3): Unvectorized loop.
3183 vec ( 13): Overhead of loop division is too large.
3184 opt (1592): Outer loop unrolled inside inner loop.
3184 vec ( 4): Vectorized array expression.
3248 vec ( 3): Unvectorized loop.
3248 vec ( 13): Overhead of loop division is too large.
3250 vec ( 4): Vectorized array expression.
3252 vec ( 4): Vectorized array expression.
3267 vec ( 3): Unvectorized loop.
3267 vec ( 13): Overhead of loop division is too large.
3269 vec ( 4): Vectorized array expression.
3271 vec ( 4): Vectorized array expression.
3286 vec ( 3): Unvectorized loop.
3287 opt (1592): Outer loop unrolled inside inner loop.
3287 vec ( 4): Vectorized array expression.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1036): Potential feedback - use directive if OK.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1059): Unable to determine last value of scalar temporary.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1036): Potential feedback - use directive if OK.
3296 opt (1036): Potential feedback - use directive if OK.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1037): Feedback of array elements.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
3296 opt (1592): Outer loop unrolled inside inner loop.
Linux R2.6.5-7.283-default FORTRAN90/SX Rev.360 Wed Oct 22 11:37:15 2008
FILE NAME: i.stomate.f90
PROGRAM NAME: stomate
FORMAT LIST
LINE LOOP FORTRAN STATEMENT
1: !$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate.f90,v 1.30 2007/06/13 08:04:56 ssipsl Exp $
2: !IPSL (2006)
3: ! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
4: !
5: MODULE stomate
6: !---------------------------------------------------------------------
7: ! Daily update of leaf area index etc.
8: !---------------------------------------------------------------------
9: USE netcdf
10: !-
11: USE ioipsl
12: USE defprec
13: USE constantes
14: USE constantes_veg
15: USE constantes_co2
16: USE stomate_constants
17: USE stomate_io
18: USE stomate_data
19: USE stomate_natagritot
20: USE stomate_season
21: USE stomate_lpj
22: USE stomate_assimtemp
23: USE stomate_litter
24: USE stomate_vmax
25: USE stomate_soilcarbon
26: USE stomate_resp
27: USE parallel
28: ! USE Write_field_p
29: !-
30: IMPLICIT NONE
31: PRIVATE
32: PUBLIC stomate_soil,stomate_main,stomate_clear, &
33: & pondere_nat,pondere_nat_vegfrac,pondere_vegfrac
34: !
35: INTEGER,PARAMETER :: r_typ =nf90_real4
36:
37: !
38: ! Do update of yearly variables ?
39: ! This variable must be .TRUE. once a year
40: LOGICAL, SAVE :: EndOfYear = .FALSE.
41: PUBLIC EndOfYear
42: !-
43: ! variables used inside stomate module : declaration and initialisation
44: !-
45: ! total natural space (fraction of total space)
46: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: veget_max
47: ! total natural space (fraction of total space)
48: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: space_nat
49: ! carbon pool: active, slow, or passive, natural and agricultural
50: ! (gC/(m**2 of nat/agri ground))
51: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: carbon
52: ! density of individuals (1/(m**2 of nat/agri ground))
53: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: ind
54: ! daily moisture availability
55: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: humrel_daily
56: ! daily litter humidity
57: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: litterhum_daily
58: ! daily 2 meter temperatures (K)
59: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_daily
60: ! daily minimum 2 meter temperatures (K)
61: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_min_daily
62: ! daily surface temperatures (K)
63: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: tsurf_daily
64: ! daily soil temperatures (K)
65: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: tsoil_daily
66: ! daily soil humidity
67: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: soilhum_daily
68: ! daily precipitations (mm/day) (for phenology)
69: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: precip_daily
70: ! daily gross primary productivity (gC/(m**2 of nat/agri ground)/day)
71: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: gpp_daily
72: ! daily net primary productivity (gC/(m**2 of nat/agri ground)/day)
73: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: npp_daily
74: ! Turnover rates (gC/(m**2 of nat/agri ground)/day)
75: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: turnover_daily
76: ! Probability of fire
77: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: fireindex
78: ! Longer term total litter above the ground
79: ! (gC/m**2 of nat/agri ground)
80: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: firelitter
81: ! "monthly" moisture availability
82: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: humrel_month
83: ! "weekly" moisture availability
84: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: humrel_week
85: ! "long term" 2 meter temperatures (K)
86: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_longterm
87: ! "long term" 2 meter reference temperatures (K)
88: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: tlong_ref
89: ! "monthly" 2 meter temperatures (K)
90: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_month
91: ! "weekly" 2 meter temperatures (K)
92: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_week
93: ! "monthly" soil temperatures (K)
94: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: tsoil_month
95: ! "monthly" soil humidity
96: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: soilhum_month
97: ! growing degree days, threshold -5 deg C (for phenology)
98: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: gdd_m5_dormance
99: ! growing degree days, since midwinter (for phenology)
100: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: gdd_midwinter
101: ! number of chilling days since leaves were lost (for phenology)
102: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: ncd_dormance
103: ! number of growing days, threshold -5 deg C (for phenology)
104: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: ngd_minus5
105: ! last year's maximum moisture availability
106: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxhumrel_lastyear
107: ! this year's maximum moisture availability
108: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxhumrel_thisyear
109: ! last year's minimum moisture availability
110: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: minhumrel_lastyear
111: ! this year's minimum moisture availability
112: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: minhumrel_thisyear
113: ! last year's maximum "weekly" GPP (gC/m**2 covered/day)
114: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxgppweek_lastyear
115: ! this year's maximum "weekly" GPP (gC/m**2 covered/day)
116: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxgppweek_thisyear
117: ! last year's annual GDD0
118: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: gdd0_lastyear
119: ! this year's annual GDD0
120: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: gdd0_thisyear
121: ! last year's annual precipitation (mm/year)
122: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: precip_lastyear
123: ! this year's annual precipitation (mm/year)
124: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: precip_thisyear
125: ! PFT exists (equivalent to veget > 0 for natural PFTs)
126: LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: PFTpresent
127: ! "long term" net primary productivity
128: ! (gC/(m**2 of nat/agri ground)/year)
129: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: npp_longterm
130: ! last year's maximum leaf mass, for each PFT
131: ! (gC/(m**2 of nat/agri ground))
132: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: lm_lastyearmax
133: ! this year's maximum leaf mass, for each PFT
134: ! (gC/(m**2 of nat/agri ground))
135: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: lm_thisyearmax
136: ! last year's maximum fpc for each natural PFT, on *natural* ground
137: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxfpc_lastyear
138: ! this year's maximum fpc for each PFT, on *total* ground
139: ! (see stomate_season)
140: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: maxfpc_thisyear
141: ! "long term" turnover rate (gC/(m**2 of nat/agri ground)/year)
142: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: turnover_longterm
143: ! "weekly" GPP (gC/day/(m**2 covered)
144: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: gpp_week
145: ! biomass (gC/(m**2 of nat/agri ground))
146: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: biomass
147: ! is the plant senescent?
148: ! (only for deciduous trees - carbohydrate reserve)
149: LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: senescence
150: ! how many days ago was the beginning of the growing season
151: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: when_growthinit
152: ! age (years). For trees, mean stand age.
153: ! For grasses, ears since introduction of PFT
154: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: age
155: ! Winter too cold? between 0 and 1
156: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: adapted
157: ! Winter sufficiently cold? between 0 and 1
158: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: regenerate
159: ! fraction of litter above the ground belonging to different PFTs,
160: ! separated for natural and agricultural PFTs
161: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: litterpart
162: ! metabolic and structural litter,
163: ! natural and agricultural, above and below ground
164: ! (gC/(m**2 of nat/agri ground))
165: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:):: litter
166: ! dead leaves on ground, per PFT, metabolic and structural,
167: ! in gC/(m**2 of nat/agri ground)
168: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: dead_leaves
169: ! black carbon on the ground (gC/(m**2 of total ground))
170: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: black_carbon
171: ! ratio Lignine/Carbon in structural litter,
172: ! above and below ground, natural and agricultural
173: ! (gC/(m**2 of nat/agri ground))
174: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: lignin_struc
175: ! carbon emitted into the atmosphere by fire (living and dead biomass)
176: ! (in gC/m**2 of average ground/day)
177: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: co2_fire
178: ! co2 taken up (gC/(m**2 of total ground)/day)
179: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: co2_to_bm_dgvm
180: ! heterotrophic respiration (gC/day/m**2 of total ground)
181: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_hetero
182: ! maintenance respiration (gC/day/(m**2 of total ground))
183: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_hetero_radia
184: ! maintenance respiration (gC/day/(m**2 of total ground))
185: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_maint
186: ! growth respiration (gC/day/(m**2 of total ground))
187: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_growth
188: ! vegetation fractions (on natural/agri ground)
189: ! after last light competition
190: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: veget_lastlight
191: ! is the PFT everywhere in the grid box or very localized
192: ! (after its intoduction)
193: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: everywhere
194: ! in order for this PFT to be introduced,
195: ! does it have to be present in an adjacent grid box?
196: LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: need_adjacent
197: ! leaf age (d)
198: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: leaf_age
199: ! fraction of leaves in leaf age class
200: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: leaf_frac
201: ! How much time ago was the PFT eliminated for the last time (y)
202: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: RIP_time
203: ! duration of dormance (d)
204: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: time_lowgpp
205: ! time elapsed since strongest moisture availability (d)
206: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: time_hum_min
207: ! minimum moisture during dormance
208: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: hum_min_dormance
209: ! factor that allows to transform "veget_max_x" (Sechiba)
210: ! into "veget_max" (Stomate).
211: ! veget_max_x takes into account the ice fraction,
212: ! while veget_max is defined on ice_free
213: ! land surface only. Moreover,
214: ! PFTs between Sechiba and Stomate are not necessarily identical.
215: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: fvm
216: ! factor that allows to transform
217: ! "veget_x" (Sechiba) into "veget" (Stomate) [see "fvm"].
218: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: fv
219: ! time constant of probability of a leaf to be eaten
220: ! by a herbivore (days)
221: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: herbivores
222: ! npp total written for forcesoil...
223: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: npp_equil
224: ! npp total ...
225: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: npp_tot
226: ! moisture control of heterotrophic respiration
227: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: control_moist
228: ! temperature control of heterotrophic respiration, above and below
229: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: control_temp
230: ! quantity of carbon going into carbon pools from litter decomposition
231: ! (gC/(m**2 of nat/agri ground)/day)
232: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) :: soilcarbon_input
233: ! times at which soil forcing file is written
234: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: times
235: ! how many states were calculated for a given soil forcing time step
236: ! turnover time of leaves
237: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: turnover_time
238: ! daily total CO2 flux (gC/m**2/day)
239: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: co2_flux_daily
240: ! monthly total CO2 flux (gC/m**2)
241: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: co2_flux_monthly
242: ! conversion of biomass to litter (gC/(m**2 of nat/agri ground))/day
243: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: bm_to_litter
244:
245: INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: nforce
246:
247: ! forcing data in memory
248: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: clay_fm
249: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: humrel_daily_x_fm
250: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: litterhum_daily_fm
251: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: t2m_daily_fm
252: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: t2m_min_daily_fm
253: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: tsurf_daily_fm
254: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: tsoil_daily_fm
255: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: soilhum_daily_fm
256: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: precip_fm
257: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: gpp_daily_x_fm
258: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: resp_maint_part_x_fm
259: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: veget_x_fm
260: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: veget_max_x_fm
261: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: lai_x_fm
262:
263: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: clay_fm_g
264: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: humrel_daily_x_fm_g
265: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: litterhum_daily_fm_g
266: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: t2m_daily_fm_g
267: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: t2m_min_daily_fm_g
268: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: tsurf_daily_fm_g
269: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: tsoil_daily_fm_g
270: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: soilhum_daily_fm_g
271: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: precip_fm_g
272: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: gpp_daily_x_fm_g
273: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: resp_maint_part_x_fm_g
274: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: veget_x_fm_g
275: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: veget_max_x_fm_g
276: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: lai_x_fm_g
277:
278: INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: isf
279: LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:) :: nf_written
280: INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: nf_cumul
281: ! first call
282: LOGICAL,SAVE :: l_first_stomate = .TRUE.
283: ! flag for cumul of forcing if teststomate
284: LOGICAL,SAVE :: cumul_forcing=.FALSE.
285: !
286: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: resp_maint_part_radia
287: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: resp_maint_part
288: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: resp_maint_radia
289:
290: ! deforestation variables
291: ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
292: ! (10 or 100 + 1 : input from year of deforestation)
293: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: prod10
294: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: prod100
295: ! annual release from the 10/100 year-turnover pool compartments
296: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: flux10
297: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: flux100
298: ! new total natural space (fraction of total space)
299: REAL(r_std),ALLOCATABLE,SAVE, DIMENSION(:) :: space_nat_new
300: ! new "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
301: REAL(r_std),ALLOCATABLE,SAVE, DIMENSION(:,:) :: veget_max_new
302: ! release during first year following deforestation
303: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: convflux
304: ! total annual release from the 10/100 year-turnover pool
305: REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:) :: cflux_prod10, cflux_prod100
306: ! deforestation (land cover change) flag
307: LOGICAL,SAVE :: defor
308:
309: CONTAINS
310: !
311: !=
312: !
313: SUBROUTINE stomate_main &
314: & (kjit, kjpij, kjpindex, dtradia, dt_slow, &
315: & ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
316: & index, lalo, neighbours, resolution, contfrac, fraction_nobio, clay, &
317: & t2m, t2m_min, temp_sol, stempdiag, &
318: & humrel_x, shumdiag, litterhumdiag, precip_rain, precip_snow, &
319: & gpp_x, deadleaf_cover, assim_param_x, &
320: & lai_x, height_x, veget_x, veget_max_x, qsintmax, &
321: & hist_id, hist2_id, rest_id_stom, hist_id_stom, &
322: & co2_flux,resp_maint_x,resp_hetero_x,resp_growth_x)
323: !---------------------------------------------------------------------
324: !
325: ! 0 interface description
326: !
327: ! 0.1 input
328: !
329: ! 0.1.1 input scalar
330: !
331: ! Time step number
332: INTEGER(i_std),INTENT(in) :: kjit
333: ! Domain size
334: INTEGER(i_std),INTENT(in) :: kjpindex
335: ! Total size of the un-compressed grid
336: INTEGER(i_std),INTENT(in) :: kjpij
337: ! Time step of SECHIBA
338: REAL(r_std),INTENT(in) :: dtradia
339: ! Time step of STOMATE
340: REAL(r_std),INTENT(in) :: dt_slow
341: ! Logical for _restart_ file to read
342: LOGICAL,INTENT(in) :: ldrestart_read
343: ! Logical for _restart_ file to write
344: LOGICAL,INTENT(in) :: ldrestart_write
345: ! Logical for _forcing_ file to write
346: LOGICAL,INTENT(in) :: ldforcing_write
347: ! Logical for _carbon_forcing_ file to write
348: LOGICAL,INTENT(in) :: ldcarbon_write
349: ! SECHIBA's _history_ file identifier
350: INTEGER(i_std),INTENT(in) :: hist_id
351: ! SECHIBA's _history_ file 2 identifier
352: INTEGER(i_std),INTENT(in) :: hist2_id
353: ! STOMATE's _Restart_ file file identifier
354: INTEGER(i_std),INTENT(in) :: rest_id_stom
355: ! STOMATE's _history_ file file identifier
356: INTEGER(i_std),INTENT(in) :: hist_id_stom
357: !
358: ! 0.1.2 input fields
359: !
360: ! Indeces of the points on the map
361: INTEGER(i_std),DIMENSION(kjpindex),INTENT(in) :: index
362: ! Geogr. coordinates (latitude,longitude) (degrees)
363: REAL(r_std),DIMENSION(kjpindex,2),INTENT(in) :: lalo
364: ! neighoring grid points if land
365: INTEGER(i_std),DIMENSION(kjpindex,8),INTENT(in) :: neighbours
366: ! size in x an y of the grid (m)
367: REAL(r_std),DIMENSION(kjpindex,2),INTENT(in) :: resolution
368: ! fraction of continent in the grid
369: REAL(r_std),DIMENSION (kjpindex), INTENT (in) :: contfrac
370: ! fraction of grid cell covered by lakes, land ice, cities, ...
371: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: fraction_nobio
372: ! clay fraction
373: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: clay
374: ! Relative humidity ("moisture availability")
375: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in) :: humrel_x
376: ! 2 m air temperature (K)
377: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: t2m
378: ! min. 2 m air temp. during forcing time step (K)
379: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: t2m_min
380: ! Surface temperature
381: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: temp_sol
382: ! Soil temperature
383: REAL(r_std),DIMENSION(kjpindex,nbdl),INTENT(in) :: stempdiag
384: ! Relative soil moisture
385: REAL(r_std),DIMENSION(kjpindex,nbdl),INTENT(in) :: shumdiag
386: ! Litter humidity
387: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: litterhumdiag
388: ! Rain precipitation
389: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: precip_rain
390: ! Snow precipitation
391: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: precip_snow
392: ! GPP (gC/(m**2 of total ground)/time step)
393: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in) :: gpp_x
394: !
395: ! 0.2 output
396: !
397: ! 0.2.1 output scalar
398: !
399: ! 0.2.2 output fields
400: !
401: ! CO2 flux in gC/m**2 of average ground/dt
402: REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: co2_flux
403: ! autotrophic respiration in gC/m**2 of surface/dt
404: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out) :: resp_maint_x
405: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out) :: resp_growth_x
406: REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: resp_hetero_x
407: !
408: ! 0.3 modified
409: !
410: ! 0.3.1 modified scalar
411: ! 0.3.2 modified fields
412: !
413: ! Surface foliere
414: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: lai_x
415: ! Fraction of vegetation type from hydrological module.
416: ! Takes into account ice etc.
417: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: veget_x
418: ! Maximum fraction of vegetation type from hydrological module.
419: ! Takes into account ice etc.
420: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: veget_max_x
421: ! height (m)
422: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: height_x
423: ! min+max+opt temps & vmax for photosynthesis
424: REAL(r_std),DIMENSION(kjpindex,nvm,npco2),INTENT(inout):: assim_param_x
425: ! fraction of soil covered by dead leaves
426: REAL(r_std),DIMENSION(kjpindex),INTENT(inout) :: deadleaf_cover
427: ! Maximum water on vegetation for interception
428: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: qsintmax
429: !
430: ! 0.4 local declaration
431: !
432: ! 0.4.1 variables defined on nvm in SECHIBA, npft in STOMATE/LPJ
433: !
434: ! moisture availability
435: REAL(r_std),DIMENSION(kjpindex,npft) :: humrel
436: ! gross primary productivity (gC/(m**2 of total ground)/day)
437: REAL(r_std),DIMENSION(kjpindex,npft) :: gpp
438: ! fractional coverage: actually covered space,
439: ! taking into account LAI (= grid scale fpc).
440: ! Fraction of nat/agri ground.
441: REAL(r_std),DIMENSION(kjpindex,npft) :: veget
442: !
443: ! 0.4.2 other
444: !
445: ! time step of STOMATE in days
446: REAL(r_std),SAVE :: dt_days
447: ! to check
448: REAL(r_std),SAVE :: day_counter
449: ! date (d)
450: INTEGER(i_std),SAVE :: date
451: ! soil level used for LAI
452: INTEGER(i_std),SAVE :: lcanop
453: ! STOMATE time step read in restart file
454: REAL(r_std) :: dt_days_read
455: ! Maximum STOMATE time step (days)
456: REAL(r_std),PARAMETER :: max_dt_days = 5.
457: ! is it time for Stomate or update of LAI etc. ?
458: LOGICAL :: do_slow
459: ! Writing frequency for history file (d)
460: REAL(r_std) :: hist_days
461: ! precipitation (mm/day)
462: REAL(r_std),DIMENSION(kjpindex) :: precip
463: ! Maximum rate of carboxylation
464: REAL(r_std),DIMENSION(kjpindex,npft) :: vcmax
465: ! Maximum rate of RUbp regeneration
466: REAL(r_std),DIMENSION(kjpindex,npft) :: vjmax
467: ! Min temperature for photosynthesis (deg C)
468: REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_min
469: ! Opt temperature for photosynthesis (deg C)
470: REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_opt
471: ! Max temperature for photosynthesis (deg C)
472: REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_max
473: ! leaf area index
474: REAL(r_std),DIMENSION(kjpindex,npft) :: lai
475: ! total autotrophic respiration (gC/day/(m**2 of total ground))
476: REAL(r_std),DIMENSION(kjpindex) :: resp_auto_tot
477: ! total photosynthesis (gC/day/(m**2 of total ground))
478: REAL(r_std),DIMENSION(kjpindex) :: gpp_tot
479: ! -- LOOP
480: REAL(r_std) :: net_co2_flux_monthly, net_co2_flux_monthly_sum
481: INTEGER :: ios
482: ! for forcing file: "daily" moisture availability
483: REAL(r_std),DIMENSION(kjpindex,nvm) :: humrel_daily_x
484: ! for forcing file: "daily" gpp
485: REAL(r_std),DIMENSION(kjpindex,nvm) :: gpp_daily_x
486: ! for forcing file: "daily" auto resp
487: REAL(r_std),DIMENSION(kjpindex,nvm,nparts) :: resp_maint_part_x
488: ! total "vegetation" cover
489: REAL(r_std),DIMENSION(kjpindex) :: cvegtot
490: ! height of vegetation (m)
491: REAL(r_std),DIMENSION(kjpindex,npft) :: height
492: INTEGER(i_std) :: ji, jv, i, j
493: REAL(r_std) :: trans_veg
494: REAL(r_std) :: tmp_day(1)
495: !
496:
497: INTEGER(i_std) :: ier
498: ! moisture control of heterotrophic respiration
499: REAL(r_std),DIMENSION(kjpindex,nlevs) :: control_moist_inst
500: ! temperature control of heterotrophic respiration, above and below
501: REAL(r_std),DIMENSION(kjpindex,nlevs) :: control_temp_inst
502: ! quantity of carbon going into carbon pools from litter decomposition
503: ! (gC/(m**2 of nat/agri ground)/day)
504: REAL(r_std),DIMENSION(kjpindex,ncarb,nvegtypes):: soilcarbon_input_inst
505: ! time step of soil forcing file (in days)
506: REAL(r_std),SAVE :: dt_forcesoil
507: INTEGER(i_std),SAVE :: nparan
508: INTEGER(i_std),SAVE :: nbyear
509: INTEGER(i_std),PARAMETER :: nparanmax=36
510: REAL(r_std) :: sf_time
511: INTEGER(i_std),SAVE :: iatt=1
512: INTEGER(i_std) :: max_totsize, totsize_1step,totsize_tmp
513: REAL(r_std) :: xn
514: INTEGER(i_std),SAVE :: nsfm, nsft
515: INTEGER(i_std),SAVE :: iisf
516: !-
517: CHARACTER(LEN=100), SAVE :: forcing_name,Cforcing_name
518: INTEGER(i_std),SAVE :: Cforcing_id
519: INTEGER(i_std),PARAMETER :: ndm = 10
520: INTEGER(i_std) :: vid
521: INTEGER(i_std) :: nneigh,direct
522: INTEGER(i_std),DIMENSION(ndm) :: d_id
523:
524:
525: ! root temperature (convolution of root and soil temperature profiles)
526: REAL(r_std),DIMENSION(kjpindex,npft) :: t_root
527: REAL(r_std),DIMENSION(kjpindex,npft,nparts) :: coeff_maint
528: ! temperature which is pertinent for maintenance respiration (K)
529: REAL(r_std),DIMENSION(kjpindex,nparts) :: t_maint_radia
530: ! integration constant for root profile
531: REAL(r_std),DIMENSION(kjpindex) :: rpc
532: ! long term annual mean temperature, C
533: REAL(r_std),DIMENSION(kjpindex) :: tl
534: ! slope of maintenance respiration coefficient (1/K)
535: REAL(r_std),DIMENSION(kjpindex) :: slope
536: ! soil levels (m)
537: REAL(r_std),DIMENSION(0:nbdl) :: z_soil
538: ! root depth. This will, one day, be a prognostic variable.
539: ! It will be calculated by
540: ! STOMATE (save in restart file & give to hydrology module!),
541: ! probably somewhere
542: ! in the allocation routine. For the moment, it is prescribed.
543: REAL(r_std),DIMENSION(kjpindex,npft) :: rprof
544: INTEGER(i_std) :: l,k
545: ! litter heterotrophic respiration (gC/day/m**2 of total ground)
546: REAL(r_std),DIMENSION(kjpindex,nvegtypes) :: resp_hetero_litter
547: ! soil heterotrophic respiration (gC/day/m**2 of total ground)
548: REAL(r_std),DIMENSION(kjpindex,nvegtypes) :: resp_hetero_soil
549: INTEGER(i_std) :: iyear
550: ! for deforestation data reading loop
551: INTEGER(i_std) :: jyear
552: ! to be returned by IOIPSL
553: INTEGER(i_std) :: year, month, day
554: REAL(r_std) :: sec
555: ! calendar stuff not provided by IOIPSL
556: INTEGER(i_std) :: month_len
557: LOGICAL :: year_bissex
558:
559: REAL(r_std),DIMENSION(nbp_glo) :: clay_g
560: REAL(r_std),DIMENSION(nbp_glo) :: space_nat_g
561: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: soilcarbon_input_g
562: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: control_moist_g
563: REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:) :: control_temp_g
564: REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: npp_equil_g
565:
566: !---------------------------------------------------------------------
567: ! first of all: store time step in common value
568: itime = kjit
569: CALL itau2ymds(itime, dtradia, year, month, day, sec)
570: ! ask for the calendar
571: CALL ioget_calendar(one_year, one_day)
572:
573: month_len = ioget_mon_len (year,month)
574:
575: ! Height of vegetation must be initialized to height_x at each time step
576: +------> DO j=1,npft
577: |V===== height(:,j)=height_x(:,j+1)
578: +------ ENDDO
579: z_soil(0) = 0.
580: V====== z_soil(1:nbdl) = diaglev(1:nbdl)
581: +------> DO j=1,npft
582: |V===== rprof(:,j) = 1./humcste(ipft_sechiba(j))
583: +------ ENDDO
584: !-
585: ! 1 do initialisation
586: !-
587: W+===== resp_growth_x=0
588: IF (l_first_stomate) THEN
589: IF (long_print) THEN
590: WRITE (numout,*) ' l_first_stomate : call stomate_init'
591: ENDIF
592: !
593: ! 1.1 allocation, file definitions. Set flags.
594: !
595: CALL stomate_init (kjpij, kjpindex, index, ldforcing_write, lalo, &
596: rest_id_stom, hist_id_stom)
597:
598: V====== co2_flux_monthly(:) = 0.0
599: !
600: ! 1.2 read PFT data
601: !
602: CALL data (kjpindex, lalo)
603: !
604: ! 1.3 read STOMATE's start file
605: !
606: CALL readstart &
607: & (kjpindex, index, lalo, resolution, &
608: day_counter, dt_days_read, date, &
609: ind, adapted, regenerate, &
610: humrel_daily, litterhum_daily, &
611: t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
612: soilhum_daily, precip_daily, &
613: gpp_daily, npp_daily, turnover_daily, &
614: humrel_month, humrel_week, t2m_longterm, &
615: tlong_ref, t2m_month, t2m_week, &
616: tsoil_month, soilhum_month, fireindex, firelitter, &
617: maxhumrel_lastyear, maxhumrel_thisyear, &
618: minhumrel_lastyear, minhumrel_thisyear, &
619: maxgppweek_lastyear, maxgppweek_thisyear, &
620: gdd0_lastyear, gdd0_thisyear, &
621: precip_lastyear, precip_thisyear, &
622: gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
623: PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
624: maxfpc_lastyear, maxfpc_thisyear, &
625: turnover_longterm, gpp_week, biomass, resp_maint_part, &
626: fvm, fv, leaf_age, leaf_frac, &
627: senescence, when_growthinit, age, &
628: resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
629: veget_lastlight, everywhere, need_adjacent, &
630: RIP_time, time_lowgpp, &
631: time_hum_min, hum_min_dormance, &
632: litterpart, litter, dead_leaves, &
633: carbon, black_carbon, lignin_struc,turnover_time,&
634: prod10,prod100,flux10, flux100)
635: ! deforestation variables added as arguments
636:
637: ! 1.4 read the boundary conditions
638: !
639: CALL readbc (kjpindex, lalo, resolution, tlong_ref)
640: !
641: ! 1.5 check time step
642: !
643: ! 1.5.1 allow STOMATE's time step to change
644: ! although this is dangerous
645: !
646: dt_days = dt_slow/one_day
647: IF (dt_days /= dt_days_read) THEN
648: WRITE(numout,*) 'slow_processes: STOMATE time step changes:', &
649: dt_days_read,' -> ',dt_days
650: ENDIF
651:
652: ! 1.5.2 time step has to be a multiple of a full day
653:
654: IF ( ( dt_days-REAL(NINT(dt_days),r_std) ) > min_stomate ) THEN
655: WRITE(numout,*) 'slow_processes: STOMATE time step is wrong:', &
656: & dt_days,' days.'
657: STOP
658: ENDIF
659:
660: ! 1.5.3 upper limit to STOMATE's time step
661:
662: IF ( dt_days > max_dt_days ) THEN
663: WRITE(numout,*) 'slow_processes: STOMATE time step too large:', &
664: & dt_days,' days.'
665: STOP
666: ENDIF
667:
668: ! 1.5.4 STOMATE time step must not be less than the forcing time step
669:
670: IF ( dtradia > dt_days*one_day ) THEN
671: WRITE(numout,*) &
672: & 'slow_processes: STOMATE time step smaller than forcing time step.'
673: STOP
674: ENDIF
675:
676: ! 1.5.5 some more messages
677:
678: WRITE(numout,*) 'slow_processes, STOMATE time step (d): ', dt_days
679:
680: !
681: ! 1.6 write forcing file for stomate?
682: !
683: IF (ldforcing_write) THEN
684:
685: !Config Key = STOMATE_FORCING_NAME
686: !Config Desc = Name of STOMATE's forcing file
687: !Config Def = NONE
688: !Config Help = Name that will be given
689: !Config to STOMATE's offline forcing file
690: !-
691: forcing_name = stomate_forcing_name ! compatibilité avec driver Nicolas
692: CALL getin_p('STOMATE_FORCING_NAME',forcing_name)
693:
694: IF ( TRIM(forcing_name) /= 'NONE' ) THEN
695: IF (is_root_prc) CALL SYSTEM ('rm -f '//TRIM(forcing_name))
696: WRITE(numout,*) 'writing a forcing file for STOMATE.'
697:
698: !Config Key = STOMATE_FORCING_MEMSIZE
699: !Config Desc = Size of STOMATE forcing data in memory (MB)
700: !Config Def = 50
701: !Config Help = This variable determines how many
702: !Config forcing states will be kept in memory.
703: !Config Must be a compromise between memory
704: !Config use and frequeny of disk access.
705:
706: max_totsize = 50
707: CALL getin_p('STOMATE_FORCING_MEMSIZE', max_totsize)
708: max_totsize = max_totsize*1000000
709:
710: totsize_1step = &
711: & SIZE(clay)*KIND(clay) &
712: & +SIZE(humrel_daily_x)*KIND(humrel_daily_x) &
713: & +SIZE(litterhum_daily)*KIND(litterhum_daily) &
714: & +SIZE(t2m_daily)*KIND(t2m_daily) &
715: & +SIZE(t2m_min_daily)*KIND(t2m_min_daily) &
716: & +SIZE(tsurf_daily)*KIND(tsurf_daily) &
717: & +SIZE(tsoil_daily)*KIND(tsoil_daily) &
718: & +SIZE(soilhum_daily)*KIND(soilhum_daily) &
719: & +SIZE(precip_daily)*KIND(precip_daily) &
720: & +SIZE(gpp_daily_x)*KIND(gpp_daily_x) &
721: & +SIZE(resp_maint_part_x)*KIND(resp_maint_part_x) &
722: & +SIZE(veget_x)*KIND(veget_x) &
723: & +SIZE(veget_max_x)*KIND(veget_max_x) &
724: & +SIZE(lai_x)*KIND(lai_x)
725:
726: CALL reduce_sum(totsize_1step,totsize_tmp)
727: CALL bcast(totsize_tmp)
728: totsize_1step=totsize_tmp
729: ! total number of forcing steps
730: nsft = INT(one_year/(dt_slow/one_day))
731:
732: ! number of forcing steps in memory
733: nsfm = MIN(nsft, &
734: & MAX(1,NINT( REAL(max_totsize,r_std) &
735: & /REAL(totsize_1step,r_std))))
736:
737: CALL init_forcing (kjpindex,nsfm,nsft)
738:
739: V====== isf(:) = (/ (i,i=1,nsfm) /)
740: V====== nf_written(:) = .FALSE.
741: V====== nf_cumul(:) = 0
742:
743: iisf = 0
744:
745: !-
746: IF (is_root_prc) THEN
747: ier = NF90_CREATE (TRIM(forcing_name),NF90_SHARE,forcing_id)
748: ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL,'dtradia',dtradia)
749: ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL,'dt_slow',dt_slow)
750: ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL, &
751: & 'nsft',REAL(nsft,r_std))
752: ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL, &
753: & 'kjpij',REAL(iim_g*jjm_g,r_std))
754: ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL, &
755: & 'kjpindex',REAL(nbp_glo,r_std))
756: !-
757: ier = NF90_DEF_DIM (forcing_id,'points',nbp_glo,d_id(1))
758: ier = NF90_DEF_DIM (forcing_id,'layers',nbdl,d_id(2))
759: ier = NF90_DEF_DIM (forcing_id,'pft',nvm,d_id(3))
760: direct=2
761: ier = NF90_DEF_DIM (forcing_id,'direction',direct,d_id(4))
762: nneigh=8
763: ier = NF90_DEF_DIM (forcing_id,'nneigh',nneigh,d_id(5))
764: ier = NF90_DEF_DIM (forcing_id,'time',nsft,d_id(6))
765: ier = NF90_DEF_DIM (forcing_id,'nbparts',nparts,d_id(7))
766: !-
767: ier = NF90_DEF_VAR (forcing_id,'points', r_typ,d_id(1),vid)
768: ier = NF90_DEF_VAR (forcing_id,'layers', r_typ,d_id(2),vid)
769: ier = NF90_DEF_VAR (forcing_id,'pft', r_typ,d_id(3),vid)
770: ier = NF90_DEF_VAR (forcing_id,'direction', r_typ,d_id(4),vid)
771: ier = NF90_DEF_VAR (forcing_id,'nneigh', r_typ,d_id(5),vid)
772: ier = NF90_DEF_VAR (forcing_id,'time', r_typ,d_id(6),vid)
773: ier = NF90_DEF_VAR (forcing_id,'nbparts', r_typ,d_id(7),vid)
774: ier = NF90_DEF_VAR (forcing_id,'index', r_typ,d_id(1),vid)
775: ier = NF90_DEF_VAR (forcing_id,'contfrac', r_typ,d_id(1),vid)
776: ier = NF90_DEF_VAR (forcing_id,'lalo', &
777: & r_typ,(/ d_id(1),d_id(4) /),vid)
778: ier = NF90_DEF_VAR (forcing_id,'neighbours', &
779: & r_typ,(/ d_id(1),d_id(5) /),vid)
780: ier = NF90_DEF_VAR (forcing_id,'resolution', &
781: & r_typ,(/ d_id(1),d_id(4) /),vid)
782: ier = NF90_DEF_VAR (forcing_id,'clay', &
783: & r_typ,(/ d_id(1),d_id(6) /),vid)
784: ier = NF90_DEF_VAR (forcing_id,'humrel', &
785: & r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
786: ier = NF90_DEF_VAR (forcing_id,'litterhum', &
787: & r_typ,(/ d_id(1),d_id(6) /),vid)
788: ier = NF90_DEF_VAR (forcing_id,'t2m', &
789: & r_typ,(/ d_id(1),d_id(6) /),vid)
790: ier = NF90_DEF_VAR (forcing_id,'t2m_min', &
791: & r_typ,(/ d_id(1),d_id(6) /),vid)
792: ier = NF90_DEF_VAR (forcing_id,'tsurf', &
793: & r_typ,(/ d_id(1),d_id(6) /),vid)
794: ier = NF90_DEF_VAR (forcing_id,'tsoil', &
795: & r_typ,(/ d_id(1),d_id(2),d_id(6) /),vid)
796: ier = NF90_DEF_VAR (forcing_id,'soilhum', &
797: & r_typ,(/ d_id(1),d_id(2),d_id(6) /),vid)
798: ier = NF90_DEF_VAR (forcing_id,'precip', &
799: & r_typ,(/ d_id(1),d_id(6) /),vid)
800: ier = NF90_DEF_VAR (forcing_id,'gpp', &
801: & r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
802: ier = NF90_DEF_VAR (forcing_id,'veget', &
803: & r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
804: ier = NF90_DEF_VAR (forcing_id,'veget_max', &
805: & r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
806: ier = NF90_DEF_VAR (forcing_id,'lai', &
807: & r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
808: ier = NF90_DEF_VAR (forcing_id,'resp_maint_part', &
809: & r_typ,(/ d_id(1),d_id(3),d_id(6),d_id(7) /),vid)
810: ier = NF90_ENDDEF (forcing_id)
811: !-
812: ier = NF90_INQ_VARID (forcing_id,'points',vid)
813: V====== ier = NF90_PUT_VAR (forcing_id,vid, &
814: & (/(REAL(i,r_std),i=1,nbp_glo) /))
815: ier = NF90_INQ_VARID (forcing_id,'layers',vid)
816: V====== ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nbdl)/))
817: ier = NF90_INQ_VARID (forcing_id,'pft',vid)
818: V====== ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nvm)/))
819: ier = NF90_INQ_VARID (forcing_id,'direction',vid)
820: +====== ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,2)/))
821: ier = NF90_INQ_VARID (forcing_id,'nneigh',vid)
822: V====== ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,8)/))
823: ier = NF90_INQ_VARID (forcing_id,'time',vid)
824: V====== ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nsft)/))
825: ier = NF90_INQ_VARID (forcing_id,'index',vid)
826: V====== ier = NF90_PUT_VAR (forcing_id,vid,REAL(index_g,r_std))
827: ier = NF90_INQ_VARID (forcing_id,'contfrac',vid)
828: V====== ier = NF90_PUT_VAR (forcing_id,vid,REAL(contfrac_g,r_std))
829: ier = NF90_INQ_VARID (forcing_id,'lalo',vid)
830: ier = NF90_PUT_VAR (forcing_id,vid,lalo_g)
831: !ym attention a neighbours, a modifier plus tard
832: ier = NF90_INQ_VARID (forcing_id,'neighbours',vid)
833: +V===== ier = NF90_PUT_VAR (forcing_id,vid,REAL(neighbours_g,r_std))
834: ier = NF90_INQ_VARID (forcing_id,'resolution',vid)
835: ier = NF90_PUT_VAR (forcing_id,vid,resolution_g)
836: ENDIF
837: ENDIF
838: ENDIF
839: !
840: ! 1.7 write forcing file for the soil?
841: !
842: IF (ldcarbon_write) THEN
843: !
844: !Config Key = STOMATE_CFORCING_NAME
845: !Config Desc = Name of STOMATE's carbon forcing file
846: !Config Def = NONE
847: !Config Help = Name that will be given to STOMATE's carbon
848: !Config offline forcing file
849: !-
850: Cforcing_name = stomate_Cforcing_name ! compatibilité avec driver Nicolas
851: CALL getin_p('STOMATE_CFORCING_NAME',Cforcing_name)
852:
853: IF ( TRIM(Cforcing_name) /= 'NONE' ) THEN
854: IF (is_root_prc) CALL SYSTEM ('rm -f '//TRIM(Cforcing_name))
855: !
856: ! time step of forcesoil
857: !
858: !Config Key = FORCESOIL_STEP_PER_YEAR
859: !Config Desc = Number of time steps per year for carbon spinup
860: !Config Def = 12
861: !Config Help = Number of time steps per year for carbon spinup
862: nparan = 12
863: CALL getin_p('FORCESOIL_STEP_PER_YEAR', nparan)
864:
865: IF ( nparan < 1 ) nparan = 1
866:
867: !Config Key = FORCESOIL_NB_YEAR
868: !Config Desc = ??
869: !Config Def = 1
870: !Config Help = ??
871: nbyear=1
872: CALL getin_p('FORCESOIL_NB_YEAR', nbyear)
873: dt_forcesoil = 0.
874: nparan = nparan+1
875: +------> DO WHILE (dt_forcesoil < dt_slow/one_day)
876: | nparan = nparan-1
877: | IF (nparan < 1) THEN
878: | STOP 'Problem 1 with number of soil forcing time steps.'
879: | ENDIF
880: | dt_forcesoil = one_year/REAL(nparan,r_std)
881: +------ ENDDO
882:
883: IF ( nparan > nparanmax ) THEN
884: STOP 'Problem 2 with number of soil forcing time steps.'
885: ENDIF
886:
887: WRITE(numout,*) 'time step of soil forcing (d): ',dt_forcesoil
888:
889: ALLOCATE(times(0:nparan))
890: V====== times(:) = (/ ((REAL(i,r_std)*dt_forcesoil),i=0,nparan*nbyear) /)
891:
892: ALLOCATE( nforce(nparan*nbyear))
893: V====== nforce(:) = 0
894:
895: ALLOCATE(control_moist(kjpindex,nlevs,nparan*nbyear))
896: ALLOCATE(npp_equil(kjpindex,nparan*nbyear))
897: ALLOCATE(npp_tot(kjpindex))
898: ALLOCATE(control_temp(kjpindex,nlevs,nparan*nbyear))
899: ALLOCATE(soilcarbon_input(kjpindex,ncarb,nvegtypes,nparan*nbyear))
900:
901: W+===== npp_equil(:,:) = zero
902: V====== npp_tot(:) = zero
903: WWW==== control_moist(:,:,:) = zero
904: ***==== control_temp(:,:,:) = zero
905: ****=== soilcarbon_input(:,:,:,:) = zero
906: ENDIF
907: ENDIF
908: !
909: ! 1.8 calculate STOMATE's vegetation fractions
910: ! from veget_x, veget_max_x, fv, and fvm
911: !
912: CALL stomate_vegconvert (kjpindex,'in',fraction_nobio, &
913: veget_max_x,veget_x,veget_max,veget,fvm,fv)
914: !
915: ! 1.9 initialize some variables
916: ! STOMATE diagnoses some variables for SECHIBA :
917: ! assim_param, deadleaf_cover, etc.
918: ! These variables can be recalculated easily
919: ! from STOMATE's prognostic variables.
920: ! height is saved in Sechiba.
921: !
922: IF (control%ok_stomate) THEN
923: CALL stomate_var_init &
924: & (kjpindex, veget, veget_max, leaf_age, leaf_frac, &
925: & tlong_ref, t2m_month, dead_leaves, &
926: & veget_x, lai_x, qsintmax, deadleaf_cover, assim_param_x,&
927: & prod10, prod100, flux10, flux100, &
928: & convflux,cflux_prod10, cflux_prod100)
929: ! deforestation variables added as arguments
930: ENDIF
931: !
932: ! 1.10 reset flag
933: !
934: l_first_stomate = .FALSE.
935: !
936: ! 1.11 return
937: !
938: RETURN
939: ENDIF ! first call
940: IF (bavard >= 4) THEN
941: WRITE(*,*) 'DATE ',date,' ymds', year, month, day, sec, '-- stp --', itime
942: ENDIF
943: !-
944: ! 2 prepares restart file for the next simulation
945: !-
946: IF (ldrestart_write) THEN
947: IF (long_print) THEN
948: WRITE (numout,*) &
949: & ' we have to complete restart file with STOMATE variables'
950: ENDIF
951: CALL writerestart &
952: & (kjpindex, index, &
953: & day_counter, dt_days, date, &
954: & ind, adapted, regenerate, &
955: & humrel_daily, litterhum_daily, &
956: & t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
957: & soilhum_daily, precip_daily, &
958: & gpp_daily, npp_daily, turnover_daily, &
959: & humrel_month, humrel_week, t2m_longterm, &
960: & tlong_ref, t2m_month, t2m_week, &
961: & tsoil_month, soilhum_month, fireindex, firelitter, &
962: & maxhumrel_lastyear, maxhumrel_thisyear, &
963: & minhumrel_lastyear, minhumrel_thisyear, &
964: & maxgppweek_lastyear, maxgppweek_thisyear, &
965: & gdd0_lastyear, gdd0_thisyear, &
966: & precip_lastyear, precip_thisyear, &
967: & gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
968: & PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
969: & maxfpc_lastyear, maxfpc_thisyear, &
970: & turnover_longterm, gpp_week, biomass, resp_maint_part, &
971: & fvm, fv, leaf_age, leaf_frac, &
972: & senescence, when_growthinit, age, &
973: & resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
974: & veget_lastlight, everywhere, need_adjacent, &
975: & RIP_time, time_lowgpp, &
976: & time_hum_min, hum_min_dormance, &
977: & litterpart, litter, dead_leaves, &
978: & carbon, black_carbon, lignin_struc,turnover_time,&
979: & prod10,prod100,flux10, flux100)
980: ! deforestation variables added as arguments
981:
982: IF (ldforcing_write .AND. TRIM(forcing_name) /= 'NONE' ) THEN
983: CALL forcing_write(forcing_id,1,iisf)
984: !
985: IF (is_root_prc) ier = NF90_CLOSE (forcing_id)
986: forcing_id=-1
987: ENDIF
988:
989: IF (ldcarbon_write .AND. TRIM(Cforcing_name) /= 'NONE' ) THEN
990: WRITE(numout,*) &
991: & 'stomate: writing the forcing file for carbon spinup'
992: !
993: +------> DO iatt = 1, nparan*nbyear
994: | IF ( nforce(iatt) > 0 ) THEN
995: |WWW=== soilcarbon_input(:,:,:,iatt) = &
996: | & soilcarbon_input(:,:,:,iatt)/REAL(nforce(iatt),r_std)
997: |++==== control_moist(:,:,iatt) = &
998: | & control_moist(:,:,iatt)/REAL(nforce(iatt),r_std)
999: |++==== control_temp(:,:,iatt) = &
1000: | & control_temp(:,:,iatt)/REAL(nforce(iatt),r_std)
1001: |V===== npp_equil(:,iatt) = &
1002: | & npp_equil(:,iatt)/REAL(nforce(iatt),r_std)
1003: | ELSE
1004: | WRITE(numout,*) &
1005: | & 'We have no soil carbon forcing data for this time step:', &
1006: | & iatt
1007: | WRITE(numout,*) ' -> we set them to zero'
1008: |WWW=== soilcarbon_input(:,:,:,iatt) = zero
1009: |++==== control_moist(:,:,iatt) = zero
1010: |++==== control_temp(:,:,iatt) = zero
1011: |V===== npp_equil(:,iatt) = zero
1012: | ENDIF
1013: +------ ENDDO
1014:
1015: !-
1016: IF (is_root_prc) THEN
1017: ier = NF90_CREATE (TRIM(Cforcing_name),NF90_WRITE,Cforcing_id)
1018: ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
1019: & 'kjpindex',REAL(nbp_glo,r_std))
1020: ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
1021: & 'nparan',REAL(nparan,r_std))
1022: ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
1023: & 'nbyear',REAL(nbyear,r_std))
1024: ier = NF90_DEF_DIM (Cforcing_id,'points',nbp_glo,d_id(1))
1025: ier = NF90_DEF_DIM (Cforcing_id,'carbtype',ncarb,d_id(2))
1026: ier = NF90_DEF_DIM (Cforcing_id,'vegtype',nvegtypes,d_id(3))
1027: ier = NF90_DEF_DIM (Cforcing_id,'level',nlevs,d_id(4))
1028: ier = NF90_DEF_DIM (Cforcing_id,'time_step',nparan*nbyear,d_id(5))
1029: !-
1030: ier = NF90_DEF_VAR (Cforcing_id,'points', r_typ,d_id(1),vid)
1031: ier = NF90_DEF_VAR (Cforcing_id,'carbtype', r_typ,d_id(2),vid)
1032: ier = NF90_DEF_VAR (Cforcing_id,'vegtype', r_typ,d_id(3),vid)
1033: ier = NF90_DEF_VAR (Cforcing_id,'level', r_typ,d_id(4),vid)
1034: ier = NF90_DEF_VAR (Cforcing_id,'time_step', r_typ,d_id(5),vid)
1035: ier = NF90_DEF_VAR (Cforcing_id,'index', r_typ,d_id(1),vid)
1036: ier = NF90_DEF_VAR (Cforcing_id,'clay', r_typ,d_id(1),vid)
1037: ier = NF90_DEF_VAR (Cforcing_id,'space_nat', r_typ,d_id(1),vid)
1038: ier = NF90_DEF_VAR (Cforcing_id,'soilcarbon_input',r_typ, &
1039: & (/ d_id(1),d_id(2),d_id(3),d_id(5) /),vid)
1040: ier = NF90_DEF_VAR (Cforcing_id,'control_moist',r_typ, &
1041: & (/ d_id(1),d_id(4),d_id(5) /),vid)
1042: ier = NF90_DEF_VAR (Cforcing_id,'control_temp',r_typ, &
1043: & (/ d_id(1),d_id(4),d_id(5) /),vid)
1044: ier = NF90_DEF_VAR (Cforcing_id,'npp_equil',r_typ, &
1045: & (/ d_id(1),d_id(5) /),vid)
1046: ier = NF90_ENDDEF (Cforcing_id)
1047: !-
1048: ier = NF90_INQ_VARID (Cforcing_id,'points',vid)
1049: V====== ier = NF90_PUT_VAR (Cforcing_id,vid, &
1050: & (/(REAL(i,r_std),i=1,nbp_glo)/))
1051: ier = NF90_INQ_VARID (Cforcing_id,'carbtype',vid)
1052: +====== ier = NF90_PUT_VAR (Cforcing_id,vid, &
1053: & (/(REAL(i,r_std),i=1,ncarb)/))
1054: ier = NF90_INQ_VARID (Cforcing_id,'vegtype',vid)
1055: +====== ier = NF90_PUT_VAR (Cforcing_id,vid, &
1056: & (/(REAL(i,r_std),i=1,nvegtypes)/))
1057: ier = NF90_INQ_VARID (Cforcing_id,'level',vid)
1058: +====== ier = NF90_PUT_VAR (Cforcing_id,vid, &
1059: & (/(REAL(i,r_std),i=1,nlevs)/))
1060: ier = NF90_INQ_VARID (Cforcing_id,'time_step',vid)
1061: V====== ier = NF90_PUT_VAR (Cforcing_id,vid, &
1062: & (/(REAL(i,r_std),i=1,nparan*nbyear)/))
1063: ier = NF90_INQ_VARID (Cforcing_id,'index',vid)
1064: V====== ier = NF90_PUT_VAR (Cforcing_id,vid, REAL(index_g,r_std) )
1065: ier = NF90_INQ_VARID (Cforcing_id,'clay',vid)
1066: ier = NF90_PUT_VAR (Cforcing_id,vid, clay_g )
1067: ier = NF90_INQ_VARID (Cforcing_id,'space_nat',vid)
1068: ier = NF90_PUT_VAR (Cforcing_id,vid, space_nat_g )
1069: ALLOCATE(soilcarbon_input_g(nbp_glo,ncarb,nvegtypes,nparan*nbyear))
1070: ier = NF90_INQ_VARID (Cforcing_id,'soilcarbon_input',vid)
1071: ier = NF90_PUT_VAR (Cforcing_id,vid, soilcarbon_input_g )
1072: ALLOCATE(control_moist_g(nbp_glo,nlevs,nparan*nbyear))
1073: ier = NF90_INQ_VARID (Cforcing_id,'control_moist',vid)
1074: ier = NF90_PUT_VAR (Cforcing_id,vid, control_moist_g )
1075: ALLOCATE(control_temp_g(nbp_glo,nlevs,nparan*nbyear))
1076: ier = NF90_INQ_VARID (Cforcing_id,'control_temp',vid)
1077: ier = NF90_PUT_VAR (Cforcing_id,vid, control_temp_g )
1078: ALLOCATE(npp_equil_g(nbp_glo,nparan*nbyear))
1079: ier = NF90_INQ_VARID (Cforcing_id,'npp_equil',vid)
1080: ier = NF90_PUT_VAR (Cforcing_id,vid, npp_equil_g )
1081: !-
1082: ier = NF90_CLOSE (Cforcing_id)
1083: Cforcing_id = -1
1084: ENDIF
1085:
1086: CALL gather(clay,clay_g)
1087: CALL gather(space_nat,space_nat_g)
1088: CALL gather(soilcarbon_input,soilcarbon_input_g)
1089: CALL gather(control_moist,control_moist_g)
1090: CALL gather(control_temp,control_temp_g)
1091: CALL gather(npp_equil,npp_equil_g)
1092:
1093: IF (is_root_prc) THEN
1094: DEALLOCATE(soilcarbon_input_g)
1095: DEALLOCATE(control_moist_g)
1096: DEALLOCATE(control_temp_g)
1097: DEALLOCATE(npp_equil_g)
1098: ENDIF
1099: ENDIF
1100: RETURN
1101: ENDIF ! write restart-files
1102: !-
1103: ! 3 Here's where the serious things begin -
1104: ! Check whether stomate and dgvm have to be called
1105: !-
1106: !
1107: ! 3.1 update day counter
1108: !
1109: day_counter = day_counter+dtradia
1110:
1111:
1112: IF (NINT(day_counter) >= NINT(dt_slow)) THEN
1113: !
1114: ! 3.2 we have to call STOMATE
1115: ! (or daily update of vegetation characteristics)?
1116: !
1117: ! reset counter
1118: day_counter = zero
1119: do_slow = .TRUE.
1120: !
1121: ! 3.3 is one year over?
1122: ! EndOfYear must be true once per year
1123: ! during a call of stomate_season.
1124: !
1125: ! increase date
1126: dt_days = dt_slow/one_day
1127:
1128: ! compilation bug : nint added
1129: date = date+nint(dt_days)
1130:
1131: IF ( ((date-NINT(date/one_year)*one_year) < .0 ) &
1132: & .AND.((date-NINT(date/one_year)*one_year) >= -dt_days) ) THEN
1133: EndOfYear = .TRUE.
1134:
1135: IF ( (bavard >= 2).AND.EndOfYear.AND.do_slow) THEN
1136: WRITE(numout,*) 'stomate: EndOfYear'
1137: ENDIF
1138: ELSE
1139: EndOfYear = .FALSE.
1140:
1141: ENDIF
1142:
1143: ELSE
1144: do_slow = .FALSE.
1145: EndOfYear = .FALSE.
1146:
1147: ENDIF
1148: IF ( (ldcarbon_write) .AND. TRIM(Cforcing_name) /= 'NONE' &
1149: & .AND.((date-NINT(date/one_year)*one_year) == dt_days) ) THEN
1150: WWW==== control_moist(:,:,:) = zero
1151: +++==== control_temp(:,:,:) = zero
1152: ++++=== soilcarbon_input(:,:,:,:) = zero
1153: V====== nforce=0
1154: ENDIF
1155: !
1156: ! 4 Special treatment for some input arrays.
1157: !
1158: !
1159: ! 4.1 Sum of liquid and solid precipitation
1160: !
1161: V====== precip = ( precip_rain+precip_snow )*one_day/dtradia
1162: !
1163: ! 4.2 Transform from dimension nvm to dimension npft.
1164: ! In SECHIBA, some variables are defined
1165: ! for all PFTs AND on bare ground -> nvm
1166: ! In STOMATE/LPJ, we do not treat bare ground.
1167: ! The same variable need not be
1168: ! defined on bare ground in STOMATE/LPJ -> npft
1169: ! Moreover, several Stomate-PFTs can be aggregated
1170: ! to one single PFT in Sechiba.
1171: ! This is not used for the moment, but it might be used
1172: ! once an age structure is introduced in Stomate.
1173: ! In that case, the different age groups of a PFT may
1174: ! be treated separately in Stomate,
1175: ! but as a single PFT in Sechiba.
1176: ! The corresponding variables exchanged with the rest
1177: ! of SECHIBA are tagged _x.
1178: ! XXX_x(:,ibare_sechiba) is the bare soil part.
1179: ! ipft_sechiba(j) is the Sechiba PFT index corresponding
1180: ! to the Stomate PFT index j.
1181: !
1182: ! 4.2.1 calculate STOMATE's vegetation fractions
1183: ! from veget_x, veget_max_x, fv, and fvm
1184: !
1185: CALL stomate_vegconvert (kjpindex,'in',fraction_nobio, &
1186: veget_max_x,veget_x,veget_max,veget,fvm,fv)
1187: +------> DO j=1,npft
1188: |
1189: | ! 4.2.2 GPP
1190: | ! gpp in gC/m**2 of total ground/day
1191: |V-----> WHERE (veget_max_x(:,ipft_sechiba(j)) > 0.0)
1192: || gpp(:,j) = gpp_x(:,ipft_sechiba(j))*one_day/dtradia &
1193: || & *(veget_max(:,j)/veget_max_x(:,ipft_sechiba(j)))
1194: || ELSEWHERE
1195: |V----- gpp(:,j) = 0.0
1196: | ENDWHERE
1197: |
1198: | ! 4.2.3 moisture availability
1199: |V===== humrel(:,j) = humrel_x(:,ipft_sechiba(j))
1200: |
1201: +------ ENDDO
1202:
1203: V====== space_nat(:) = 1.0
1204: +------> DO j=1,npft
1205: | IF (.NOT.natural(j) ) THEN
1206: |V===== space_nat(:) = space_nat(:)-veget_max(:,j)
1207: | ENDIF
1208: +------ ENDDO
1209: !
1210: ! 5 "daily" variables
1211: ! Note: If dt_days /= 1, then xx_daily are not daily variables,
1212: ! but that is not really a problem.
1213: !
1214: !
1215: ! 5.1 accumulate instantaneous variables
1216: ! and eventually calculate daily mean value
1217: !
1218: CALL stomate_accu (kjpindex, npft, dt_slow, dtradia, &
1219: & do_slow, humrel, humrel_daily)
1220: CALL stomate_accu (kjpindex, 1, dt_slow, dtradia, &
1221: & do_slow, litterhumdiag, litterhum_daily)
1222: CALL stomate_accu (kjpindex, 1, dt_slow, dtradia, &
1223: & do_slow, t2m, t2m_daily)
1224: CALL stomate_accu (kjpindex, 1, dt_slow, dtradia, &
1225: & do_slow, temp_sol, tsurf_daily)
1226: CALL stomate_accu (kjpindex, nbdl, dt_slow, dtradia, &
1227: & do_slow, stempdiag, tsoil_daily)
1228: CALL stomate_accu (kjpindex, nbdl, dt_slow, dtradia, &
1229: & do_slow, shumdiag, soilhum_daily)
1230: CALL stomate_accu (kjpindex, 1, dt_slow, dtradia, &
1231: & do_slow, precip, precip_daily)
1232: CALL stomate_accu (kjpindex, npft, dt_slow, dtradia, &
1233: & do_slow, gpp, gpp_daily)
1234: !
1235: ! 5.2 daily minimum temperature
1236: !
1237: V====== t2m_min_daily(:) = MIN( t2m_min(:), t2m_min_daily(:) )
1238: !
1239: ! 5.3 calculate respiration (NV 14/5/2002)
1240: !
1241: ! 5.3.1 calculate maintenance respiration
1242: !
1243: CALL maint_respiration &
1244: & (kjpindex,dtradia,t2m,tlong_ref,stempdiag,height,veget_max,space_nat, &
1245: & rprof,biomass,resp_maint_part_radia)
1246:
1247: W*===== resp_maint_radia(:,:) = zero
1248: +------> DO j=1,npft
1249: |+-----> DO k= 1, nparts
1250: ||V==== resp_maint_radia(:,j) = resp_maint_radia(:,j) &
1251: || & +resp_maint_part_radia(:,j,k)
1252: |+----- ENDDO
1253: +------ ENDDO
1254: ++V==== resp_maint_part(:,:,:)= resp_maint_part(:,:,:) &
1255: & +resp_maint_part_radia(:,:,:)
1256: !
1257: ! 5.3.2 the whole litter stuff:
1258: ! litter update, lignin content, PFT parts, litter decay,
1259: ! litter heterotrophic respiration, dead leaf soil cover.
1260: ! No vertical discretisation in the soil for litter decay.
1261: !
1262: ++V==== CALL littercalc (kjpindex, dtradia/one_day, space_nat, &
1263: turnover_daily*dtradia/one_day, bm_to_litter*dtradia/one_day, &
1264: temp_sol, stempdiag, shumdiag, litterhumdiag, &
1265: litterpart, litter, dead_leaves, lignin_struc, &
1266: deadleaf_cover, resp_hetero_litter, &
1267: soilcarbon_input_inst, control_temp_inst, control_moist_inst)
1268: +V===== resp_hetero_litter=resp_hetero_litter*dtradia/one_day
1269: !
1270: ! 5.3.3 soil carbon dynamics: heterotrophic respiration from the soil.
1271: ! For the moment, no vertical discretisation.
1272: ! We might later introduce a vertical discretisation.
1273: ! However, in that case, we would have to treat the vertical
1274: ! exchanges of carbon between the different levels.
1275: !
1276: CALL soilcarbon (kjpindex, dtradia/one_day, clay, space_nat, &
1277: soilcarbon_input_inst, control_temp_inst, control_moist_inst, &
1278: carbon, resp_hetero_soil)
1279: *V-----> resp_hetero_soil=resp_hetero_soil*dtradia/one_day
1280: || resp_hetero_radia = resp_hetero_litter+resp_hetero_soil
1281: *V----- resp_hetero= resp_hetero+resp_hetero_radia
1282: !
1283: ! 6 Daily processes
1284: !
1285: IF (do_slow) THEN
1286:
1287: ! update veget_max_new and space_nat_new by reading data file
1288: defor = .FALSE.
1289:
1290: CALL getin_p('DEFOR', defor)
1291:
1292: IF(defor) then
1293:
1294: IF(EndOfYear) then
1295:
1296: IF (is_root_prc) THEN
1297: open(10,file='veget_defor.dat')
1298: read(10,*)jyear,veget_max_new
1299: ENDIF
1300: CALL bcast(jyear)
1301: CALL bcast(veget_max_new)
1302:
1303: V====== space_nat_new(:) = 1.0
1304:
1305: +------> DO j = 1, npft
1306: | IF ( .NOT. natural(j) ) THEN
1307: |V===== space_nat_new(:) = space_nat_new(:) - veget_max_new(:,j)
1308: | ENDIF
1309: +------ ENDDO
1310: CALL natagritot (kjpindex, ito_natagri, space_nat_new, veget_max_new)
1311:
1312: ENDIF
1313: ENDIF
1314: !
1315: ! 6.1 total natural space
1316: !
1317: !
1318: ! 6.2 Calculate longer-term "meteorological" and biological parameters
1319: !
1320: CALL season &
1321: & (kjpindex, dt_days, EndOfYear, space_nat, &
1322: & veget, veget_max, &
1323: & humrel_daily, t2m_daily, tsoil_daily, soilhum_daily, &
1324: & precip_daily, npp_daily, biomass, &
1325: & turnover_daily, gpp_daily, when_growthinit, &
1326: & maxhumrel_lastyear, maxhumrel_thisyear, &
1327: & minhumrel_lastyear, minhumrel_thisyear, &
1328: & maxgppweek_lastyear, maxgppweek_thisyear, &
1329: & gdd0_lastyear, gdd0_thisyear, &
1330: & precip_lastyear, precip_thisyear, &
1331: & lm_lastyearmax, lm_thisyearmax, &
1332: & maxfpc_lastyear, maxfpc_thisyear, &
1333: & humrel_month, humrel_week, t2m_longterm, &
1334: & tlong_ref, t2m_month, t2m_week, tsoil_month, soilhum_month, &
1335: & npp_longterm, turnover_longterm, gpp_week, &
1336: & gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
1337: & time_lowgpp, time_hum_min, hum_min_dormance, herbivores)
1338: !
1339: ! 6.3 transform GPP from gC/(m**2 of total ground)/day to
1340: ! gC/(m**2 of nat/agri ground)/day
1341: !
1342: CALL natagritot (kjpindex, ito_natagri, space_nat, gpp_daily)
1343: !
1344: ! 6.4 STOMATE: allocation, phenology, etc.
1345: !
1346: IF (control%ok_stomate) THEN
1347:
1348: ! 6.4.1.a transform spatial fractions from fraction
1349: ! of total space to fraction of natural/agricultural space
1350:
1351: CALL natagritot (kjpindex, ito_natagri, space_nat, veget)
1352: CALL natagritot (kjpindex, ito_natagri, space_nat, veget_max)
1353:
1354: ! 6.4.1.b update lai
1355: IF (control%ok_pheno) THEN ! lai from stomate
1356: +------> DO j = 1, npft
1357: |V-----> WHERE ( veget_max(:,j) .GT. min_sechiba )
1358: || lai(:,j) = biomass(:,j,ileaf)/veget_max(:,j)*sla(j)
1359: || ELSEWHERE
1360: |V----- lai(:,j) = 0.0
1361: | ENDWHERE
1362: +------ ENDDO
1363: ELSE
1364: CALL setlai(kjpindex,lai) ! lai prescribed
1365: ENDIF
1366:
1367: ! 6.4.2 call stomate
1368:
1369: CALL StomateLpj &
1370: & (kjpindex, dt_days, EndOfYear, &
1371: & neighbours, resolution, space_nat, &
1372: & clay, herbivores, &
1373: & tsurf_daily, tsoil_daily, t2m_daily, t2m_min_daily, &
1374: & litterhum_daily, soilhum_daily, &
1375: & maxhumrel_lastyear, minhumrel_lastyear, &
1376: & gdd0_lastyear, precip_lastyear, &
1377: & humrel_month, humrel_week, tlong_ref, t2m_month, t2m_week, &
1378: & tsoil_month, soilhum_month, &
1379: & gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
1380: & turnover_longterm, gpp_daily, time_lowgpp, &
1381: & time_hum_min, maxfpc_lastyear, resp_maint_part,&
1382: & PFTpresent, age, fireindex, firelitter, &
1383: & leaf_age, leaf_frac, biomass, ind, adapted, regenerate, &
1384: & senescence, when_growthinit, litterpart, litter, &
1385: & dead_leaves, carbon, black_carbon, lignin_struc, &
1386: & veget_max, veget, npp_longterm, lm_lastyearmax, &
1387: & veget_lastlight, everywhere, need_adjacent, RIP_time, &
1388: & lai, rprof,npp_daily, turnover_daily, turnover_time,&
1389: & control_moist_inst, control_temp_inst, soilcarbon_input_inst, &
1390: & co2_to_bm_dgvm, co2_fire, resp_hetero, resp_maint, &
1391: & resp_growth, height, deadleaf_cover, vcmax, vjmax, &
1392: & t_photo_min, t_photo_opt, t_photo_max,bm_to_litter,&
1393: & prod10, prod100, flux10, flux100, space_nat_new, veget_max_new,&
1394: & convflux, cflux_prod10, cflux_prod100, defor)
1395: ! deforestation variables added as arguments + EndOfYear
1396:
1397: ! 6.4.3 transform spatial fractions from fraction
1398: ! of natural/agricultural space to fraction of total space
1399:
1400: CALL natagritot (kjpindex, ito_total, space_nat, veget)
1401: CALL natagritot (kjpindex, ito_total, space_nat, veget_max)
1402: !
1403: ! 6.5 output: transform from dimension npft to dimension nvm
1404: ! Several Stomate-PFTs may correspond
1405: ! to a single Sechiba-PFT (see 4.2).
1406: ! We sum up the vegetation cover over these Stomate-PFTs.
1407: ! Mean LAI, height, and Vmax is calculated
1408: ! by ponderating with (maximum) vegetation cover.
1409: !
1410: ! 6.5.1 calculate veget_x, veget_max_x,
1411: ! fv and fvm from veget and veget_max
1412: !
1413: CALL stomate_vegconvert &
1414: & (kjpindex,'out',fraction_nobio, &
1415: & veget_max_x,veget_x,veget_max,veget,fvm,fv)
1416:
1417: ! 6.5.2 lai and height
1418:
1419: CALL stomate_var_xout (kjpindex,lai,veget_max,zero,lai_x)
1420: CALL stomate_var_xout (kjpindex,height,veget_max,zero,height_x)
1421:
1422: ! 6.5.3 photosynthesis parameters
1423:
1424: CALL stomate_var_xout &
1425: & (kjpindex,vcmax,veget,zero,assim_param_x(:,:,ivcmax))
1426: CALL stomate_var_xout &
1427: & (kjpindex,vjmax,veget,zero,assim_param_x(:,:,ivjmax))
1428:
1429: CALL stomate_var_xout &
1430: & (kjpindex,t_photo_min,veget,zero,assim_param_x(:,:,itmin))
1431: CALL stomate_var_xout &
1432: & (kjpindex,t_photo_opt,veget,zero,assim_param_x(:,:,itopt))
1433: CALL stomate_var_xout &
1434: & (kjpindex,t_photo_max,veget,zero,assim_param_x(:,:,itmax))
1435: !
1436: ! 6.6 update forcing variables for soil carbon
1437: !
1438: IF (ldcarbon_write .AND. TRIM(Cforcing_name) /= 'NONE') THEN
1439: !
1440: ! determime the carbon soil time step we are falling into
1441: !
1442: ! where are we within the current year?
1443: sf_time = date &
1444: & -FLOOR(date/(one_year*REAL(nbyear,r_std)))*one_year*nbyear
1445: +------> DO WHILE ( sf_time > one_year )
1446: | sf_time = sf_time-one_year
1447: +------ ENDDO
1448: +------> DO WHILE ( sf_time < 0. )
1449: | sf_time = sf_time+one_year
1450: +------ ENDDO
1451: iyear=1
1452: IF (iatt > nparan) iatt=1
1453: IF ( (times(iatt-1) > sf_time ) &
1454: & .OR.(times(iatt) <= sf_time ) ) THEN
1455: iatt = nparan
1456: ! look for corresponding time step
1457: V------> DO i = nparan, 1, -1
1458: | IF ( times(i) > sf_time ) iatt = i
1459: V------ ENDDO
1460: ENDIF ! otherwise, iatt was already OK!
1461:
1462: ! we know now what soil forcing time step we are talking about.
1463: ! Increase counter for this soil carbon time step
1464: ! and update "mean" forcing variables.
1465:
1466: nforce(iatt) = nforce(iatt)+1
1467:
1468: ++V==== soilcarbon_input(:,:,:,iatt+(iyear-1)*nparan) = &
1469: & soilcarbon_input(:,:,:,iatt+(iyear-1)*nparan) &
1470: & +soilcarbon_input_inst(:,:,:)
1471: *V-----> control_moist(:,:,iatt+(iyear-1)*nparan) = &
1472: || & control_moist(:,:,iatt+(iyear-1)*nparan) &
1473: || & +control_moist_inst(:,:)
1474: *V----- control_temp(:,:,iatt+(iyear-1)*nparan) = &
1475: & control_temp(:,:,iatt+(iyear-1)*nparan) &
1476: & +control_temp_inst(:,:)
1477: V====== npp_equil(:,iatt+(iyear-1)*nparan) = &
1478: & npp_equil(:,iatt+(iyear-1)*nparan) &
1479: & +npp_tot(:)
1480: ! nforce(iatt) = 1
1481: ! soilcarbon_input(:,:,:,iatt) = soilcarbon_input_inst(:,:,:)
1482: ! control_moist(:,:,iatt) = control_moist_inst(:,:)
1483: ! control_temp(:,:,iatt) = control_temp_inst(:,:)
1484: ! npp_equil(:,iatt) = npp_tot(:)
1485: ENDIF
1486: !
1487: ! 6.7 updates qsintmax
1488: !
1489: +V===== qsintmax(:,:) = qsintcst*veget_x(:,:)*lai_x(:,:)
1490: ENDIF
1491: !
1492: ! 6.8 write forcing file?
1493: ! ldforcing_write should only be .TRUE.
1494: ! if STOMATE is run in coupled mode.
1495: ! In stand-alone mode, the forcing file is read!
1496: !
1497: IF ( ldforcing_write .AND. TRIM(forcing_name) /= 'NONE' ) THEN
1498: CALL natagritot (kjpindex, ito_total, space_nat, gpp_daily)
1499: +V===== gpp_daily_x(:,:) = 0.0
1500: ++V==== resp_maint_part_x(:,:,:) = 0.0
1501: +------> DO j = 1, npft
1502: | ! don't worry about weightings. humrel is not modified in STOMATE.
1503: |V-----> humrel_daily_x(:,ipft_sechiba(j)) = humrel_daily(:,j)
1504: |V----- gpp_daily_x(:,ipft_sechiba(j)) = &
1505: | & gpp_daily_x(:,ipft_sechiba(j)) &
1506: | & +gpp_daily(:,j)*dt_slow/one_day
1507: |+V==== resp_maint_part_x(:,ipft_sechiba(j),:) = &
1508: | & resp_maint_part_x(:,ipft_sechiba(j),:) &
1509: | & +resp_maint_part(:,j,:)*dt_slow/one_day
1510: +------ ENDDO
1511: !
1512: ! bare soil moisture availability has not been treated
1513: ! in STOMATE (doesn't matter)
1514: !
1515: V====== humrel_daily_x(:,ibare_sechiba) = humrel_x(:,ibare_sechiba)
1516:
1517: ! next forcing step in memory
1518: iisf = iisf+1
1519:
1520: ! how many times have we treated this forcing state
1521: xn = REAL(nf_cumul(isf(iisf)),r_std)
1522:
1523: ! cumulate. be careful :
1524: ! precipitation is multiplied by dt_slow/one_day
1525: IF (cumul_forcing) THEN
1526: V====== clay_fm(:,iisf) = (xn*clay_fm(:,iisf)+clay(:))/(xn+1.)
1527: +V===== humrel_daily_x_fm(:,:,iisf) = &
1528: & (xn*humrel_daily_x_fm(:,:,iisf)+humrel_daily_x(:,:))/(xn+1.)
1529: V====== litterhum_daily_fm(:,iisf) = &
1530: & (xn*litterhum_daily_fm(:,iisf)+litterhum_daily(:))/(xn+1.)
1531: V====== t2m_daily_fm(:,iisf) = &
1532: & (xn*t2m_daily_fm(:,iisf)+t2m_daily(:))/(xn+1.)
1533: V====== t2m_min_daily_fm(:,iisf) = &
1534: & (xn*t2m_min_daily_fm(:,iisf)+t2m_min_daily(:))/(xn+1.)
1535: V====== tsurf_daily_fm(:,iisf) = &
1536: & (xn*tsurf_daily_fm(:,iisf)+tsurf_daily(:))/(xn+1.)
1537: +V===== tsoil_daily_fm(:,:,iisf) = &
1538: & (xn*tsoil_daily_fm(:,:,iisf)+tsoil_daily(:,:))/(xn+1.)
1539: +V===== soilhum_daily_fm(:,:,iisf) = &
1540: & (xn*soilhum_daily_fm(:,:,iisf)+soilhum_daily(:,:))/(xn+1.)
1541: V====== precip_fm(:,iisf) = &
1542: & (xn*precip_fm(:,iisf)+precip_daily(:)*dt_slow/one_day)/(xn+1.)
1543: +V===== gpp_daily_x_fm(:,:,iisf) = &
1544: & (xn*gpp_daily_x_fm(:,:,iisf)+gpp_daily_x(:,:))/(xn+1.)
1545: ++V==== resp_maint_part_x_fm(:,:,:,iisf) = &
1546: & ( xn*resp_maint_part_x_fm(:,:,:,iisf) &
1547: & +resp_maint_part_x(:,:,:) )/(xn+1.)
1548: *V----->S veget_x_fm(:,:,iisf) = &
1549: || S & (xn*veget_x_fm(:,:,iisf)+veget_x(:,:) )/(xn+1.)
1550: || S veget_max_x_fm(:,:,iisf) = &
1551: || S & (xn*veget_max_x_fm(:,:,iisf)+veget_max_x(:,:) )/(xn+1.)
1552: *V----- S lai_x_fm(:,:,iisf) = &
1553: & (xn*lai_x_fm(:,:,iisf)+lai_x(:,:) )/(xn+1.)
1554: ELSE
1555: V====== clay_fm(:,iisf) = clay(:)
1556: +V===== humrel_daily_x_fm(:,:,iisf) = humrel_daily_x(:,:)
1557: V====== litterhum_daily_fm(:,iisf) = +litterhum_daily(:)
1558: V====== t2m_daily_fm(:,iisf) = t2m_daily(:)
1559: V====== t2m_min_daily_fm(:,iisf) =t2m_min_daily(:)
1560: V====== tsurf_daily_fm(:,iisf) = tsurf_daily(:)
1561: +V===== tsoil_daily_fm(:,:,iisf) =tsoil_daily(:,:)
1562: +V===== soilhum_daily_fm(:,:,iisf) =soilhum_daily(:,:)
1563: V====== precip_fm(:,iisf) = precip_daily(:)
1564: +V===== gpp_daily_x_fm(:,:,iisf) =gpp_daily_x(:,:)
1565: ++V==== resp_maint_part_x_fm(:,:,:,iisf) = resp_maint_part_x(:,:,:)
1566: *V-----> veget_x_fm(:,:,iisf) = veget_x(:,:)
1567: || veget_max_x_fm(:,:,iisf) =veget_max_x(:,:)
1568: *V----- lai_x_fm(:,:,iisf) =lai_x(:,:)
1569: ENDIF
1570: nf_cumul(isf(iisf)) = nf_cumul(isf(iisf))+1
1571:
1572: ! do we have to write the forcing states?
1573: IF (iisf == nsfm) THEN
1574:
1575: ! write these forcing states
1576: CALL forcing_write(forcing_id,1,nsfm)
1577: ! determine which forcing states must be read
1578: isf(1) = isf(nsfm)+1
1579: IF ( isf(1) > nsft ) isf(1) = 1
1580: +------> DO iisf = 2, nsfm
1581: | isf(iisf) = isf(iisf-1)+1
1582: | IF (isf(iisf) > nsft) isf(iisf) = 1
1583: +------ ENDDO
1584:
1585: ! read them
1586: CALL forcing_read(forcing_id,nsfm)
1587:
1588: iisf = 0
1589:
1590: ENDIF
1591:
1592: ENDIF
1593: ! 6.9 compute daily co2_flux
1594: V====== resp_auto_tot(:) = 0.0
1595:
1596: +------> DO j=1,npft
1597: |V===== resp_auto_tot(:) = resp_auto_tot(:) &
1598: | & +resp_maint(:,j)+resp_growth(:,j)
1599: +------ ENDDO
1600:
1601: ! total photosynthesis (in gC/m**2/day)
1602: V====== gpp_tot(:) = 0.0
1603: +------> DO j=1,npft
1604: |V===== gpp_tot(:) = gpp_tot(:)+gpp_daily(:,j)
1605: +------ ENDDO
1606:
1607: ! CO2 flux in gC/m**2/sec
1608: ! (positive towards the atmosphere) is sum of:
1609: ! 1/ heterotrophic respiration from natural and agricultural ground
1610: ! 2/ maintenance respiration from the plants
1611: ! 3/ growth respiration from the plants
1612: ! 4/ co2 created by fire
1613: ! 5/ - co2 taken up in the DGVM to establish saplings.
1614: ! 6/ - co2 taken up by photosyntyhesis
1615:
1616: V====== co2_flux_daily(:) = ( resp_hetero(:,inat) &
1617: & +resp_hetero(:,iagri) &
1618: & +resp_auto_tot(:) &
1619: & +co2_fire(:)-co2_to_bm_dgvm(:)-gpp_tot(:) )
1620: CALL histwrite (hist_id, 'CO2FLUX', itime, &
1621: co2_flux_daily, kjpindex, index)
1622: IF ( hist2_id > 0 ) THEN
1623: CALL histwrite (hist2_id, 'CO2FLUX', itime, &
1624: co2_flux_daily, kjpindex, index)
1625: ENDIF
1626: !
1627: V====== co2_flux_monthly(:) = co2_flux_monthly(:) + co2_flux_daily(:)
1628: IF ( (day .EQ. month_len) .AND. (INT(sec) .EQ. 0) ) THEN
1629: IF ( control%ok_stomate ) THEN
1630: CALL histwrite (hist_id_stomate, 'CO2FLUX_MONTHLY', itime, &
1631: co2_flux_monthly, kjpindex, hori_index)
1632: ENDIF
1633: V====== co2_flux_monthly(:) = co2_flux_monthly(:)* &
1634: resolution(:,1)*resolution(:,2)*contfrac(:)
1635: V====== net_co2_flux_monthly = sum(co2_flux_monthly)
1636:
1637: WRITE(numout,*) 'net_co2_flux_monthly = ',net_co2_flux_monthly
1638:
1639: CALL reduce_sum(net_co2_flux_monthly,net_co2_flux_monthly_sum)
1640: IF (is_root_prc) THEN
1641: OPEN( unit=39, &
1642: file="stomate_co2flux.data", &
1643: action="write", &
1644: position="append", &
1645: iostat=ios )
1646: IF ( ios /= 0 ) THEN
1647: STOP "Erreur lors de la lecture/ecriture du fichier stomate_co2flux.data"
1648: ELSE
1649: WRITE(numout,*)
1650: WRITE(numout,*) "Ecriture du fichier stomate_co2flux.data"
1651: WRITE(numout,*)
1652: END IF
1653: WRITE(39,*) net_co2_flux_monthly_sum*1e-15
1654: CLOSE( unit=39 )
1655: ENDIF
1656: V====== co2_flux_monthly(:) = 0.0
1657: ENDIF
1658: !
1659: ! 6.10 reset daily variables
1660: !
1661: W+===== humrel_daily(:,:) = 0.0
1662: V====== litterhum_daily(:) = 0.0
1663: V====== t2m_daily(:) = 0.0
1664: V====== t2m_min_daily(:) = large_value
1665: V====== tsurf_daily(:) = 0.0
1666: WW===== tsoil_daily(:,:) = 0.0
1667: ++===== soilhum_daily(:,:) = 0.0
1668: V====== precip_daily(:) = 0.0
1669: WW===== gpp_daily(:,:) = 0.0
1670: W++==== resp_maint_part(:,:,:)=0.0
1671: ++===== resp_hetero=0.0
1672: IF (bavard >= 3) THEN
1673: WRITE(numout,*) 'stomate_main: daily processes done'
1674: ENDIF
1675:
1676: ENDIF ! daily processes?
1677:
1678: !
1679: ! 7 Outputs from Stomate
1680: ! co2_flux is assigned a value only if STOMATE is activated.
1681: ! Otherwise, the calling hydrological module must do this itself.
1682: !
1683: IF ( control%ok_stomate ) THEN
1684:
1685: ! total autotrophic respiration
1686: V====== resp_auto_tot(:) = 0.0
1687:
1688: +------> DO j = 1, npft
1689: |V-----> resp_auto_tot(:) = resp_auto_tot(:) &
1690: || & +resp_maint_radia(:,j) &
1691: || & +resp_growth(:,j)*dtradia/one_day
1692: || resp_maint_x(:,j+1) = resp_maint_radia(:,j)
1693: |V----- resp_growth_x(:,j+1)= resp_growth(:,j)*dtradia/one_day
1694: +------ ENDDO
1695: V------> resp_hetero_x=resp_hetero_radia(:,inat)+resp_hetero_radia(:,iagri)
1696: | resp_maint_x(:,1) = 0.0
1697: | ! total photosynthesis (in gC/m**2/day)
1698: V------ gpp_tot(:) = 0.0
1699: +------> DO jv=1,nvm
1700: |V===== gpp_tot(:) = gpp_tot(:)+gpp_x(:,jv)
1701: +------ ENDDO
1702:
1703: ! CO2 flux in gC/m**2/sec (positive towards the atmosphere) is sum of:
1704: ! 1/ heterotrophic respiration from natural and agricultural ground
1705: ! 2/ maintenance respiration from the plants
1706: ! 3/ growth respiration from the plants
1707: ! 4/ co2 created by fire
1708: ! 5/ - co2 taken up in the DGVM to establish saplings.
1709: ! 6/ - co2 taken up by photosyntyhesis
1710:
1711: V====== co2_flux(:) = resp_hetero_radia(:,inat) &
1712: & +resp_hetero_radia(:,iagri) &
1713: & +(co2_fire(:)-co2_to_bm_dgvm(:))*dtradia/one_day &
1714: & +resp_auto_tot(:)-gpp_tot(:)
1715:
1716: ENDIF
1717: !
1718: ! 8 message
1719: !
1720: IF ( (bavard >= 2).AND.EndOfYear.AND.do_slow) THEN
1721: WRITE(numout,*) 'stomate: EndOfYear'
1722: ENDIF
1723: IF (bavard >= 4) WRITE(numout,*) 'Leaving stomate_main'
1724: IF (long_print) WRITE (numout,*) ' stomate_main done '
1725: !--------------------------
1726: END SUBROUTINE stomate_main
1727: !
1728: !=
1729: !
1730: SUBROUTINE stomate_init &
1731: & (kjpij, kjpindex, index, ldforcing_write, lalo, &
1732: & rest_id_stom, hist_id_stom)
1733: !---------------------------------------------------------------------
1734: ! interface description
1735: ! input scalar
1736: ! Total size of the un-compressed grid
1737: INTEGER(i_std),INTENT(in) :: kjpij
1738: ! Domain size
1739: INTEGER(i_std),INTENT(in) :: kjpindex
1740: ! Logical for _forcing_ file to write
1741: LOGICAL,INTENT(in) :: ldforcing_write
1742: ! Geogr. coordinates (latitude,longitude) (degrees)
1743: REAL(r_std),DIMENSION(kjpindex,2),INTENT(in) :: lalo
1744: ! STOMATE's _Restart_ file file identifier
1745: INTEGER(i_std),INTENT(in) :: rest_id_stom
1746: ! STOMATE's _history_ file file identifier
1747: INTEGER(i_std),INTENT(in) :: hist_id_stom
1748: ! input fields
1749: ! Indeces of the points on the map
1750: INTEGER(i_std),DIMENSION(kjpindex),INTENT(in) :: index
1751: ! local declaration
1752: REAL(r_std) :: tmp_day(1)
1753: ! soil depth taken for canopy
1754: REAL(r_std) :: zcanop
1755: ! soil depths at diagnostic levels
1756: REAL(r_std),DIMENSION(nbdl) :: zsoil
1757: ! Index
1758: INTEGER(i_std) :: l
1759: ! allocation error
1760: LOGICAL :: l_error
1761: ! Global world fraction of vegetation type map
1762: REAL(r_std),DIMENSION(360,180,nvm) :: veget_ori_on_disk
1763: INTEGER(i_std) :: ier
1764: ! indices
1765: INTEGER(i_std) :: ji,j,ipd
1766: !---------------------------------------------------------------------
1767: !
1768: ! 1 online diagnostics
1769: ! (by default, "bavard" is set to 1 in stomate_constants)
1770: !
1771: !Config Key = BAVARD
1772: !Config Desc = level of online diagnostics in STOMATE (0-4)
1773: !Config Def = 1
1774: !Config Help = With this variable, you can determine
1775: !Config how much online information STOMATE
1776: !Config gives during the run. 0 means
1777: !Config virtually no info.
1778: !
1779: bavard = 1
1780: CALL getin_p('BAVARD', bavard)
1781:
1782: IF ( kjpindex > 0 ) THEN
1783: !
1784: !Config Key = STOMATE_DIAGPT
1785: !Config Desc = Index of grid point for online diagnostics
1786: !Config Def = 1
1787: !Config Help = This is the index of the grid point which
1788: ! will be used for online diagnostics.
1789: ipd = 1
1790: CALL getin_p('STOMATE_DIAGPT',ipd)
1791: ipd = MIN( ipd, kjpindex )
1792: WRITE(numout,*) 'Stomate: '
1793: WRITE(numout,*) ' Index of grid point for online diagnostics: ',ipd
1794: WRITE(numout,*) ' Lon, lat:',lalo(ipd,2),lalo(ipd,1)
1795: WRITE(numout,*) ' Index of this point on GCM grid: ',index(ipd)
1796: !
1797: ENDIF
1798: !
1799: ! 2 check consistency of flags
1800: !
1801: IF ( ( .NOT. control%ok_stomate ) .AND. control%ok_dgvm ) THEN
1802: WRITE(numout,*) 'Cannot do dynamical vegetation without STOMATE.'
1803: WRITE(numout,*) 'We stop.'
1804: STOP
1805: ENDIF
1806:
1807: IF ((.NOT.control%ok_co2).AND.control%ok_stomate) THEN
1808: WRITE(numout,*) 'Cannot call STOMATE without GPP.'
1809: WRITE(numout,*) 'We stop.'
1810: STOP
1811: ENDIF
1812:
1813: IF ( ( .NOT. control%ok_co2 ) .AND. ldforcing_write ) THEN
1814: WRITE(numout,*) &
1815: & 'Cannot write forcing file if photosynthesis is not activated'
1816: WRITE(numout,*) 'We stop.'
1817: STOP
1818: ENDIF
1819: !
1820: ! 3 messages
1821: !
1822: WRITE(numout,*) 'stomate: first call'
1823: WRITE(numout,*) ' Photosynthesis: ', control%ok_co2
1824: WRITE(numout,*) ' STOMATE: ', control%ok_stomate
1825: WRITE(numout,*) ' LPJ: ', control%ok_dgvm
1826: !
1827: ! 4 allocation of STOMATE's variables
1828: !
1829: l_error = .FALSE.
1830: ALLOCATE(veget_max(kjpindex,npft),stat=ier)
1831: l_error = l_error .OR. (ier /= 0)
1832: ALLOCATE(space_nat(kjpindex),stat=ier)
1833: l_error = l_error .OR. (ier /= 0)
1834: ALLOCATE(ind(kjpindex,npft),stat=ier)
1835: l_error = l_error .OR. (ier /= 0)
1836: ALLOCATE(adapted(kjpindex,npft),stat=ier)
1837: l_error = l_error .OR. (ier /= 0)
1838: ALLOCATE(regenerate(kjpindex,npft),stat=ier)
1839: l_error = l_error .OR. (ier /= 0)
1840: ALLOCATE(humrel_daily(kjpindex,npft),stat=ier)
1841: l_error = l_error .OR. (ier /= 0)
1842: ALLOCATE(litterhum_daily(kjpindex),stat=ier)
1843: l_error = l_error .OR. (ier /= 0)
1844: ALLOCATE(t2m_daily(kjpindex),stat=ier)
1845: l_error = l_error .OR. (ier /= 0)
1846: ALLOCATE(t2m_min_daily(kjpindex),stat=ier)
1847: l_error = l_error .OR. (ier /= 0)
1848: ALLOCATE(tsurf_daily(kjpindex),stat=ier)
1849: l_error = l_error .OR. (ier /= 0)
1850: ALLOCATE(tsoil_daily(kjpindex,nbdl),stat=ier)
1851: l_error = l_error .OR. (ier /= 0)
1852: ALLOCATE(soilhum_daily(kjpindex,nbdl),stat=ier)
1853: l_error = l_error .OR. (ier /= 0)
1854: ALLOCATE(precip_daily(kjpindex),stat=ier)
1855: l_error = l_error .OR. (ier /= 0)
1856: ALLOCATE(gpp_daily(kjpindex,npft),stat=ier)
1857: l_error = l_error .OR. (ier /= 0)
1858: ALLOCATE(npp_daily(kjpindex,npft),stat=ier)
1859: l_error = l_error .OR. (ier /= 0)
1860: ALLOCATE(turnover_daily(kjpindex,npft,nparts),stat=ier)
1861: l_error = l_error .OR. (ier /= 0)
1862: ALLOCATE(humrel_month(kjpindex,npft),stat=ier)
1863: l_error = l_error .OR. (ier /= 0)
1864: ALLOCATE(humrel_week(kjpindex,npft),stat=ier)
1865: l_error = l_error .OR. (ier /= 0)
1866: ALLOCATE(t2m_longterm(kjpindex),stat=ier)
1867: l_error = l_error .OR. (ier /= 0)
1868: ALLOCATE(tlong_ref(kjpindex),stat=ier)
1869: l_error = l_error .OR. (ier /= 0)
1870: ALLOCATE(t2m_month(kjpindex),stat=ier)
1871: l_error = l_error .OR. (ier /= 0)
1872: ALLOCATE(t2m_week(kjpindex),stat=ier)
1873: l_error = l_error .OR. (ier /= 0)
1874: ALLOCATE(tsoil_month(kjpindex,nbdl),stat=ier)
1875: l_error = l_error .OR. (ier /= 0)
1876: ALLOCATE(soilhum_month(kjpindex,nbdl),stat=ier)
1877: l_error = l_error .OR. (ier /= 0)
1878: ALLOCATE(fireindex(kjpindex,nvegtypes),stat=ier)
1879: l_error = l_error .OR. (ier /= 0)
1880: ALLOCATE(firelitter(kjpindex,nvegtypes),stat=ier)
1881: l_error = l_error .OR. (ier /= 0)
1882: ALLOCATE(maxhumrel_lastyear(kjpindex,npft),stat=ier)
1883: l_error = l_error .OR. (ier /= 0)
1884: ALLOCATE(maxhumrel_thisyear(kjpindex,npft),stat=ier)
1885: l_error = l_error .OR. (ier /= 0)
1886: ALLOCATE(minhumrel_lastyear(kjpindex,npft),stat=ier)
1887: l_error = l_error .OR. (ier /= 0)
1888: ALLOCATE(minhumrel_thisyear(kjpindex,npft),stat=ier)
1889: l_error = l_error .OR. (ier /= 0)
1890: ALLOCATE(maxgppweek_lastyear(kjpindex,npft),stat=ier)
1891: l_error = l_error .OR. (ier /= 0)
1892: ALLOCATE(maxgppweek_thisyear(kjpindex,npft),stat=ier)
1893: l_error = l_error .OR. (ier /= 0)
1894: ALLOCATE(gdd0_lastyear(kjpindex),stat=ier)
1895: l_error = l_error .OR. (ier /= 0)
1896: ALLOCATE(gdd0_thisyear(kjpindex),stat=ier)
1897: l_error = l_error .OR. (ier /= 0)
1898: ALLOCATE(precip_lastyear(kjpindex),stat=ier)
1899: l_error = l_error .OR. (ier /= 0)
1900: ALLOCATE(precip_thisyear(kjpindex),stat=ier)
1901: l_error = l_error .OR. (ier /= 0)
1902: ALLOCATE(gdd_m5_dormance(kjpindex,npft),stat=ier)
1903: l_error = l_error .OR. (ier /= 0)
1904: ALLOCATE(gdd_midwinter(kjpindex,npft),stat=ier)
1905: l_error = l_error .OR. (ier /= 0)
1906: ALLOCATE(ncd_dormance(kjpindex,npft),stat=ier)
1907: l_error = l_error .OR. (ier /= 0)
1908: ALLOCATE(ngd_minus5(kjpindex,npft),stat=ier)
1909: l_error = l_error .OR. (ier /= 0)
1910: ALLOCATE(PFTpresent(kjpindex,npft),stat=ier)
1911: l_error = l_error .OR. (ier /= 0)
1912: ALLOCATE(npp_longterm(kjpindex,npft),stat=ier)
1913: l_error = l_error .OR. (ier /= 0)
1914: ALLOCATE(lm_lastyearmax(kjpindex,npft),stat=ier)
1915: l_error = l_error .OR. (ier /= 0)
1916: ALLOCATE(lm_thisyearmax(kjpindex,npft),stat=ier)
1917: l_error = l_error .OR. (ier /= 0)
1918: ALLOCATE(maxfpc_lastyear(kjpindex,npft),stat=ier)
1919: l_error = l_error .OR. (ier /= 0)
1920: ALLOCATE(maxfpc_thisyear(kjpindex,npft),stat=ier)
1921: l_error = l_error .OR. (ier /= 0)
1922: ALLOCATE(turnover_longterm(kjpindex,npft,nparts),stat=ier)
1923: l_error = l_error .OR. (ier /= 0)
1924: ALLOCATE(gpp_week(kjpindex,npft),stat=ier)
1925: l_error = l_error .OR. (ier /= 0)
1926: ALLOCATE(biomass(kjpindex,npft,nparts),stat=ier)
1927: l_error = l_error .OR. (ier /= 0)
1928: ALLOCATE(senescence(kjpindex,npft),stat=ier)
1929: l_error = l_error .OR. (ier /= 0)
1930: ALLOCATE(when_growthinit(kjpindex,npft),stat=ier)
1931: l_error = l_error .OR. (ier /= 0)
1932: ALLOCATE(age(kjpindex,npft),stat=ier)
1933: l_error = l_error .OR. (ier /= 0)
1934: ALLOCATE(resp_hetero(kjpindex,nvegtypes),stat=ier)
1935: l_error = l_error .OR. (ier /= 0)
1936: ALLOCATE(resp_hetero_radia(kjpindex,nvegtypes),stat=ier)
1937: l_error = l_error .OR. (ier /= 0)
1938: ALLOCATE(resp_maint(kjpindex,npft),stat=ier)
1939: l_error = l_error .OR. (ier /= 0)
1940: ALLOCATE(resp_growth(kjpindex,npft),stat=ier)
1941: l_error = l_error .OR. (ier /= 0)
1942: ALLOCATE(co2_fire(kjpindex),stat=ier)
1943: l_error = l_error .OR. (ier /= 0)
1944: ALLOCATE(co2_to_bm_dgvm(kjpindex),stat=ier)
1945: l_error = l_error .OR. (ier /= 0)
1946: ALLOCATE(veget_lastlight(kjpindex,npft),stat=ier)
1947: l_error = l_error .OR. (ier /= 0)
1948: ALLOCATE(everywhere(kjpindex,npft),stat=ier)
1949: l_error = l_error .OR. (ier /= 0)
1950: ALLOCATE(need_adjacent(kjpindex,npft),stat=ier)
1951: l_error = l_error .OR. (ier /= 0)
1952: ALLOCATE(leaf_age(kjpindex,npft,nleafages),stat=ier)
1953: l_error = l_error .OR. (ier /= 0)
1954: ALLOCATE(leaf_frac(kjpindex,npft,nleafages),stat=ier)
1955: l_error = l_error .OR. (ier /= 0)
1956: ALLOCATE(RIP_time(kjpindex,npft),stat=ier)
1957: l_error = l_error .OR. (ier /= 0)
1958: ALLOCATE(time_lowgpp(kjpindex,npft),stat=ier)
1959: l_error = l_error .OR. (ier /= 0)
1960: ALLOCATE(time_hum_min(kjpindex,npft),stat=ier)
1961: l_error = l_error .OR. (ier /= 0)
1962: ALLOCATE(hum_min_dormance(kjpindex,npft),stat=ier)
1963: l_error = l_error .OR. (ier /= 0)
1964: ALLOCATE(fvm(kjpindex,npft),stat=ier)
1965: l_error = l_error .OR. (ier /= 0)
1966: ALLOCATE(fv(kjpindex,npft),stat=ier)
1967: l_error = l_error .OR. (ier /= 0)
1968: ALLOCATE(litterpart(kjpindex,npft,nlitt),stat=ier)
1969: l_error = l_error .OR. (ier /= 0)
1970: ALLOCATE(litter(kjpindex,nlitt,nvegtypes,nlevs),stat=ier)
1971: l_error = l_error .OR. (ier /= 0)
1972: ALLOCATE(dead_leaves(kjpindex,npft,nlitt),stat=ier)
1973: l_error = l_error .OR. (ier /= 0)
1974: ALLOCATE(carbon(kjpindex,ncarb,nvegtypes),stat=ier)
1975: l_error = l_error .OR. (ier /= 0)
1976: ALLOCATE(black_carbon(kjpindex),stat=ier)
1977: l_error = l_error .OR. (ier /= 0)
1978: ALLOCATE(lignin_struc(kjpindex,nvegtypes,nlevs),stat=ier)
1979: l_error = l_error .OR. (ier /= 0)
1980: ALLOCATE(turnover_time(kjpindex,npft),stat=ier)
1981: l_error = l_error .OR. (ier /= 0)
1982: ALLOCATE(co2_flux_daily(kjpindex),stat=ier)
1983: l_error = l_error .OR. (ier /= 0)
1984: ALLOCATE(co2_flux_monthly(kjpindex),stat=ier)
1985: l_error = l_error .OR. (ier /= 0)
1986: ALLOCATE(bm_to_litter(kjpindex,npft,nparts),stat=ier)
1987: l_error = l_error .OR. (ier /= 0)
1988: ALLOCATE(herbivores(kjpindex,npft),stat=ier)
1989: l_error = l_error .OR. (ier /= 0)
1990: ALLOCATE(hori_index(kjpindex),stat=ier)
1991: l_error = l_error .OR. (ier /= 0)
1992: ALLOCATE(horipft_index(kjpindex*npft),stat=ier)
1993: l_error = l_error .OR. (ier /= 0)
1994: ALLOCATE(resp_maint_part_radia(kjpindex,npft,nparts),stat=ier)
1995: l_error = l_error .OR. (ier /= 0)
1996: ALLOCATE(resp_maint_radia(kjpindex,npft),stat=ier)
1997: l_error = l_error .OR. (ier /= 0)
1998: ALLOCATE(resp_maint_part(kjpindex,npft,nparts),stat=ier)
1999: l_error = l_error .OR. (ier /= 0)
2000: W++==== resp_maint_part(:,:,:)=0.0
2001:
2002: ! allocation for deforestation variables
2003: ALLOCATE (veget_max_new(kjpindex,npft), stat=ier)
2004: l_error = l_error .OR. (ier.NE.0)
2005: ALLOCATE (space_nat_new(kjpindex), stat=ier)
2006: l_error = l_error .OR. (ier.NE.0)
2007: ALLOCATE (horip10_index(kjpindex*10), stat=ier)
2008: l_error = l_error .OR. (ier.NE.0)
2009: ALLOCATE (horip100_index(kjpindex*100), stat=ier)
2010: l_error = l_error .OR. (ier.NE.0)
2011: ALLOCATE (horip11_index(kjpindex*11), stat=ier)
2012: l_error = l_error .OR. (ier.NE.0)
2013: ALLOCATE (horip101_index(kjpindex*101), stat=ier)
2014: l_error = l_error .OR. (ier.NE.0)
2015: ALLOCATE (prod10(kjpindex,0:10), stat=ier)
2016: l_error = l_error .OR. (ier.NE.0)
2017: ALLOCATE (prod100(kjpindex,0:100), stat=ier)
2018: l_error = l_error .OR. (ier.NE.0)
2019: ALLOCATE (flux10(kjpindex,10), stat=ier)
2020: l_error = l_error .OR. (ier.NE.0)
2021: ALLOCATE (flux100(kjpindex,100), stat=ier)
2022: l_error = l_error .OR. (ier.NE.0)
2023: ALLOCATE (convflux(kjpindex), stat=ier)
2024: l_error = l_error .OR. (ier.NE.0)
2025: ALLOCATE (cflux_prod10(kjpindex), stat=ier)
2026: l_error = l_error .OR. (ier.NE.0)
2027: ALLOCATE (cflux_prod100(kjpindex), stat=ier)
2028: l_error = l_error .OR. (ier.NE.0)
2029: !
2030: IF (l_error) THEN
2031: STOP 'stomate_init: error in memory allocation'
2032: ENDIF
2033: !
2034: ! 5 file definitions: stored in common variables
2035: !
2036: hist_id_stomate = hist_id_stom
2037: rest_id_stomate = rest_id_stom
2038: V====== hori_index(:) = index(:)
2039:
2040: ! Get the indexing table for the vegetation fields.
2041: ! In STOMATE we work on
2042: ! reduced grids but to store in the full 3D filed vegetation variable
2043: ! we need another index table : indexpft
2044:
2045: +------> DO j = 1, npft
2046: |V-----> DO ji = 1, kjpindex
2047: || horipft_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
2048: |V----- ENDDO
2049: +------ ENDDO
2050:
2051: ! indexing tables added for deforestation fields
2052: +------> DO j = 1, 10
2053: |V-----> DO ji = 1, kjpindex
2054: || horip10_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
2055: |V----- ENDDO
2056: +------ ENDDO
2057:
2058: +------> DO j = 1, 100
2059: |V-----> DO ji = 1, kjpindex
2060: || horip100_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
2061: |V----- ENDDO
2062: +------ ENDDO
2063:
2064: +------> DO j = 1, 11
2065: |V-----> DO ji = 1, kjpindex
2066: || horip11_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
2067: |V----- ENDDO
2068: +------ ENDDO
2069:
2070: +------> DO j = 1, 101
2071: |V-----> DO ji = 1, kjpindex
2072: || horip101_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
2073: |V----- ENDDO
2074: +------ ENDDO
2075: !
2076: ! 6 some flags
2077: !
2078: !
2079: !Config Key = HERBIVORES
2080: !Config Desc = herbivores allowed?
2081: !Config Def = n
2082: !Config Help = With this variable, you can determine
2083: !Config if herbivores are activated
2084: !
2085: ok_herbivores = .FALSE.
2086: CALL getin_p('HERBIVORES', ok_herbivores)
2087: !
2088: WRITE(numout,*) 'herbivores activated: ',ok_herbivores
2089: !
2090: !Config Key = TREAT_EXPANSION
2091: !Config Desc = treat expansion of PFTs across a grid cell?
2092: !Config Def = n
2093: !Config Help = With this variable, you can determine
2094: !Config whether we treat expansion of PFTs across a
2095: !Config grid cell.
2096: !
2097: treat_expansion = .FALSE.
2098: CALL getin_p('TREAT_EXPANSION', treat_expansion)
2099: !
2100: WRITE(numout,*) &
2101: & 'expansion across a grid cell is treated: ',treat_expansion
2102:
2103: !
2104: WWW==== bm_to_litter=zero
2105: WW===== resp_hetero=zero
2106: !--------------------------
2107: END SUBROUTINE stomate_init
2108: !
2109: !=
2110: !
2111: SUBROUTINE stomate_clear
2112: !---------------------------------------------------------------------
2113: ! 1. Deallocate all dynamics variables
2114: IF (ALLOCATED(veget_max)) DEALLOCATE(veget_max)
2115: IF (ALLOCATED(space_nat)) DEALLOCATE(space_nat)
2116: IF (ALLOCATED(ind)) DEALLOCATE(ind)
2117: IF (ALLOCATED(adapted)) DEALLOCATE(adapted)
2118: IF (ALLOCATED(regenerate)) DEALLOCATE(regenerate)
2119: IF (ALLOCATED(humrel_daily)) DEALLOCATE(humrel_daily)
2120: IF (ALLOCATED(litterhum_daily)) DEALLOCATE(litterhum_daily)
2121: IF (ALLOCATED(t2m_daily)) DEALLOCATE(t2m_daily)
2122: IF (ALLOCATED(t2m_min_daily)) DEALLOCATE(t2m_min_daily)
2123: IF (ALLOCATED(tsurf_daily)) DEALLOCATE(tsurf_daily)
2124: IF (ALLOCATED(tsoil_daily)) DEALLOCATE(tsoil_daily)
2125: IF (ALLOCATED(soilhum_daily)) DEALLOCATE(soilhum_daily)
2126: IF (ALLOCATED(precip_daily)) DEALLOCATE(precip_daily)
2127: IF (ALLOCATED(gpp_daily)) DEALLOCATE(gpp_daily)
2128: IF (ALLOCATED(npp_daily)) DEALLOCATE(npp_daily)
2129: IF (ALLOCATED(turnover_daily)) DEALLOCATE(turnover_daily)
2130: IF (ALLOCATED(humrel_month)) DEALLOCATE(humrel_month)
2131: IF (ALLOCATED(humrel_week)) DEALLOCATE(humrel_week)
2132: IF (ALLOCATED(t2m_longterm)) DEALLOCATE(t2m_longterm)
2133: IF (ALLOCATED(tlong_ref)) DEALLOCATE(tlong_ref)
2134: IF (ALLOCATED(t2m_month)) DEALLOCATE(t2m_month)
2135: IF (ALLOCATED(t2m_week)) DEALLOCATE(t2m_week)
2136: IF (ALLOCATED(tsoil_month)) DEALLOCATE(tsoil_month)
2137: IF (ALLOCATED(soilhum_month)) DEALLOCATE(soilhum_month)
2138: IF (ALLOCATED(fireindex)) DEALLOCATE(fireindex)
2139: IF (ALLOCATED(firelitter)) DEALLOCATE(firelitter)
2140: IF (ALLOCATED(maxhumrel_lastyear)) DEALLOCATE(maxhumrel_lastyear)
2141: IF (ALLOCATED(maxhumrel_thisyear)) DEALLOCATE(maxhumrel_thisyear)
2142: IF (ALLOCATED(minhumrel_lastyear)) DEALLOCATE(minhumrel_lastyear)
2143: IF (ALLOCATED(minhumrel_thisyear)) DEALLOCATE(minhumrel_thisyear)
2144: IF (ALLOCATED(maxgppweek_lastyear)) DEALLOCATE(maxgppweek_lastyear)
2145: IF (ALLOCATED(maxgppweek_thisyear)) DEALLOCATE(maxgppweek_thisyear)
2146: IF (ALLOCATED(gdd0_lastyear)) DEALLOCATE(gdd0_lastyear)
2147: IF (ALLOCATED(gdd0_thisyear)) DEALLOCATE(gdd0_thisyear)
2148: IF (ALLOCATED(precip_lastyear)) DEALLOCATE(precip_lastyear)
2149: IF (ALLOCATED(precip_thisyear)) DEALLOCATE(precip_thisyear)
2150: IF (ALLOCATED(gdd_m5_dormance)) DEALLOCATE(gdd_m5_dormance)
2151: IF (ALLOCATED(gdd_midwinter)) DEALLOCATE(gdd_midwinter)
2152: IF (ALLOCATED(ncd_dormance)) DEALLOCATE(ncd_dormance)
2153: IF (ALLOCATED(ngd_minus5)) DEALLOCATE(ngd_minus5)
2154: IF (ALLOCATED(PFTpresent)) DEALLOCATE(PFTpresent)
2155: IF (ALLOCATED(npp_longterm)) DEALLOCATE(npp_longterm)
2156: IF (ALLOCATED(lm_lastyearmax)) DEALLOCATE(lm_lastyearmax)
2157: IF (ALLOCATED(lm_thisyearmax)) DEALLOCATE(lm_thisyearmax)
2158: IF (ALLOCATED(maxfpc_lastyear)) DEALLOCATE(maxfpc_lastyear)
2159: IF (ALLOCATED(maxfpc_thisyear)) DEALLOCATE(maxfpc_thisyear)
2160: IF (ALLOCATED(turnover_longterm)) DEALLOCATE(turnover_longterm)
2161: IF (ALLOCATED(gpp_week)) DEALLOCATE(gpp_week)
2162: IF (ALLOCATED(biomass)) DEALLOCATE(biomass)
2163: IF (ALLOCATED(senescence)) DEALLOCATE(senescence)
2164: IF (ALLOCATED(when_growthinit)) DEALLOCATE(when_growthinit)
2165: IF (ALLOCATED(age)) DEALLOCATE(age)
2166: IF (ALLOCATED(resp_hetero)) DEALLOCATE(resp_hetero)
2167: IF (ALLOCATED(resp_hetero_radia)) DEALLOCATE(resp_hetero_radia)
2168: IF (ALLOCATED(resp_maint)) DEALLOCATE(resp_maint)
2169: IF (ALLOCATED(resp_growth)) DEALLOCATE(resp_growth)
2170: IF (ALLOCATED(co2_fire)) DEALLOCATE(co2_fire)
2171: IF (ALLOCATED(co2_to_bm_dgvm)) DEALLOCATE(co2_to_bm_dgvm)
2172: IF (ALLOCATED(veget_lastlight)) DEALLOCATE(veget_lastlight)
2173: IF (ALLOCATED(everywhere)) DEALLOCATE(everywhere)
2174: IF (ALLOCATED(need_adjacent)) DEALLOCATE(need_adjacent)
2175: IF (ALLOCATED(leaf_age)) DEALLOCATE(leaf_age)
2176: IF (ALLOCATED(leaf_frac)) DEALLOCATE(leaf_frac)
2177: IF (ALLOCATED(RIP_time)) DEALLOCATE(RIP_time)
2178: IF (ALLOCATED(time_lowgpp)) DEALLOCATE(time_lowgpp)
2179: IF (ALLOCATED(time_hum_min)) DEALLOCATE(time_hum_min)
2180: IF (ALLOCATED(hum_min_dormance)) DEALLOCATE(hum_min_dormance)
2181: IF (ALLOCATED(fvm)) DEALLOCATE(fvm)
2182: IF (ALLOCATED(fv)) DEALLOCATE(fv)
2183: IF (ALLOCATED(litterpart)) DEALLOCATE(litterpart)
2184: IF (ALLOCATED(litter)) DEALLOCATE(litter)
2185: IF (ALLOCATED(dead_leaves)) DEALLOCATE(dead_leaves)
2186: IF (ALLOCATED(carbon)) DEALLOCATE(carbon)
2187: IF (ALLOCATED(black_carbon)) DEALLOCATE(black_carbon)
2188: IF (ALLOCATED(lignin_struc)) DEALLOCATE(lignin_struc)
2189: IF (ALLOCATED(turnover_time)) DEALLOCATE(turnover_time)
2190: IF (ALLOCATED(co2_flux_daily)) DEALLOCATE(co2_flux_daily)
2191: IF (ALLOCATED(co2_flux_monthly)) DEALLOCATE(co2_flux_monthly)
2192: IF (ALLOCATED(bm_to_litter)) DEALLOCATE(bm_to_litter)
2193: IF (ALLOCATED(herbivores)) DEALLOCATE(herbivores)
2194: IF (ALLOCATED(resp_maint_part_radia)) DEALLOCATE(resp_maint_part_radia)
2195: IF (ALLOCATED(resp_maint_radia)) DEALLOCATE(resp_maint_radia)
2196: IF (ALLOCATED(resp_maint_part)) DEALLOCATE(resp_maint_part)
2197: IF (ALLOCATED(hori_index)) DEALLOCATE(hori_index)
2198: IF (ALLOCATED(horipft_index)) DEALLOCATE(horipft_index)
2199: IF (ALLOCATED(clay_fm)) DEALLOCATE(clay_fm)
2200: IF (ALLOCATED(humrel_daily_x_fm)) DEALLOCATE(humrel_daily_x_fm)
2201: IF (ALLOCATED(litterhum_daily_fm)) DEALLOCATE(litterhum_daily_fm)
2202: IF (ALLOCATED(t2m_daily_fm)) DEALLOCATE(t2m_daily_fm)
2203: IF (ALLOCATED(t2m_min_daily_fm)) DEALLOCATE(t2m_min_daily_fm)
2204: IF (ALLOCATED(tsurf_daily_fm)) DEALLOCATE(tsurf_daily_fm)
2205: IF (ALLOCATED(tsoil_daily_fm)) DEALLOCATE(tsoil_daily_fm)
2206: IF (ALLOCATED(soilhum_daily_fm)) DEALLOCATE(soilhum_daily_fm)
2207: IF (ALLOCATED(precip_fm)) DEALLOCATE(precip_fm)
2208: IF (ALLOCATED(gpp_daily_x_fm)) DEALLOCATE(gpp_daily_x_fm)
2209: IF (ALLOCATED(resp_maint_part_x_fm)) DEALLOCATE(resp_maint_part_x_fm)
2210: IF (ALLOCATED(veget_x_fm)) DEALLOCATE(veget_x_fm)
2211: IF (ALLOCATED(veget_max_x_fm)) DEALLOCATE(veget_max_x_fm)
2212: IF (ALLOCATED(lai_x_fm)) DEALLOCATE(lai_x_fm)
2213:
2214: IF (is_root_prc) THEN
2215: IF (ALLOCATED(clay_fm_g)) DEALLOCATE(clay_fm_g)
2216: IF (ALLOCATED(humrel_daily_x_fm_g)) DEALLOCATE(humrel_daily_x_fm_g)
2217: IF (ALLOCATED(litterhum_daily_fm_g)) DEALLOCATE(litterhum_daily_fm_g)
2218: IF (ALLOCATED(t2m_daily_fm_g)) DEALLOCATE(t2m_daily_fm_g)
2219: IF (ALLOCATED(t2m_min_daily_fm_g)) DEALLOCATE(t2m_min_daily_fm_g)
2220: IF (ALLOCATED(tsurf_daily_fm_g)) DEALLOCATE(tsurf_daily_fm_g)
2221: IF (ALLOCATED(tsoil_daily_fm_g)) DEALLOCATE(tsoil_daily_fm_g)
2222: IF (ALLOCATED(soilhum_daily_fm_g)) DEALLOCATE(soilhum_daily_fm_g)
2223: IF (ALLOCATED(precip_fm_g)) DEALLOCATE(precip_fm_g)
2224: IF (ALLOCATED(gpp_daily_x_fm_g)) DEALLOCATE(gpp_daily_x_fm_g)
2225: IF (ALLOCATED(resp_maint_part_x_fm_g)) DEALLOCATE(resp_maint_part_x_fm_g)
2226: IF (ALLOCATED(veget_x_fm_g)) DEALLOCATE(veget_x_fm_g)
2227: IF (ALLOCATED(veget_max_x_fm_g)) DEALLOCATE(veget_max_x_fm_g)
2228: IF (ALLOCATED(lai_x_fm_g)) DEALLOCATE(lai_x_fm_g)
2229: ENDIF
2230:
2231: IF (ALLOCATED(isf)) DEALLOCATE(isf)
2232: IF (ALLOCATED(nf_written)) DEALLOCATE(nf_written)
2233: IF (ALLOCATED(nf_cumul)) DEALLOCATE(nf_cumul)
2234: IF (ALLOCATED(times)) DEALLOCATE(times)
2235: IF (ALLOCATED(nforce)) DEALLOCATE(nforce)
2236: IF (ALLOCATED(control_moist)) DEALLOCATE(control_moist)
2237: IF (ALLOCATED(control_temp)) DEALLOCATE(control_temp)
2238: IF (ALLOCATED(soilcarbon_input)) DEALLOCATE(soilcarbon_input)
2239: ! for deforestation variables
2240: IF ( ALLOCATED (veget_max_new)) DEALLOCATE (veget_max_new)
2241: IF ( ALLOCATED (space_nat_new)) DEALLOCATE (space_nat_new)
2242: IF ( ALLOCATED (horip10_index)) DEALLOCATE (horip10_index)
2243: IF ( ALLOCATED (horip100_index)) DEALLOCATE (horip100_index)
2244: IF ( ALLOCATED (horip11_index)) DEALLOCATE (horip11_index)
2245: IF ( ALLOCATED (horip101_index)) DEALLOCATE (horip101_index)
2246: IF ( ALLOCATED (prod10)) DEALLOCATE (prod10)
2247: IF ( ALLOCATED (prod100)) DEALLOCATE (prod100)
2248: IF ( ALLOCATED (flux10)) DEALLOCATE (flux10)
2249: IF ( ALLOCATED (flux100)) DEALLOCATE (flux100)
2250: IF ( ALLOCATED (convflux)) DEALLOCATE (convflux)
2251: IF ( ALLOCATED (cflux_prod10)) DEALLOCATE (cflux_prod10)
2252: IF ( ALLOCATED (cflux_prod100)) DEALLOCATE (cflux_prod100)
2253:
2254: ! 2. reset l_first
2255: l_first_stomate=.TRUE.
2256: ! 3. call to clear functions
2257: CALL get_reftemp_clear
2258: CALL season_clear
2259: CALL stomatelpj_clear
2260: CALL littercalc_clear
2261: CALL vmax_clear
2262: !---------------------------
2263: END SUBROUTINE stomate_clear
2264: !
2265: !=
2266: !
2267: SUBROUTINE stomate_var_init &
2268: & (kjpindex, veget, veget_max, leaf_age, leaf_frac, &
2269: & tlong_ref, t2m_month, dead_leaves, &
2270: & veget_x, lai_x, qsintmax, deadleaf_cover, assim_param_x, &
2271: & prod10, prod100, flux10, flux100, &
2272: & convflux,cflux_prod10, cflux_prod100)
2273: ! deforestation variables added as arguments
2274:
2275: !---------------------------------------------------------------------
2276: ! this subroutine outputs values of assim_param etc.
2277: ! only if ok_stomate = .TRUE.
2278: ! otherwise,the calling procedure must do it itself.
2279: !
2280: ! interface description
2281: ! input scalar
2282: ! Domain size
2283: INTEGER(i_std),INTENT(in) :: kjpindex
2284: ! input fields
2285: ! fractional coverage: actually covered space
2286: REAL(r_std),DIMENSION(kjpindex,npft),INTENT(in) :: veget
2287: ! fractional coverage: maximum covered space
2288: REAL(r_std),DIMENSION(kjpindex,npft),INTENT(in) :: veget_max
2289: ! "long term" 2 meter reference temperatures (K)
2290: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: tlong_ref
2291: ! "monthly" 2 meter temperatures (K)
2292: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: t2m_month
2293: ! dead leaves on ground, per PFT, metabolic and structural,
2294: ! in gC/(m**2 of nat/agri ground)
2295: REAL(r_std),DIMENSION(kjpindex,npft,nlitt),INTENT(in) :: dead_leaves
2296: ! Fraction of vegetation type
2297: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in) :: veget_x
2298: ! Surface foliere
2299: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in) :: lai_x
2300: ! modified fields (actually NOT modified)
2301: ! leaf age (d)
2302: REAL(r_std),DIMENSION(kjpindex,npft,nleafages),INTENT(inout) :: &
2303: & leaf_age
2304: ! fraction of leaves in leaf age class
2305: REAL(r_std),DIMENSION(kjpindex,npft,nleafages),INTENT(inout) :: &
2306: & leaf_frac
2307: ! output scalar
2308: ! output fields
2309: ! Maximum water on vegetation for interception
2310: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out) :: qsintmax
2311: ! fraction of soil covered by dead leaves
2312: REAL(r_std),DIMENSION(kjpindex), INTENT (out) :: deadleaf_cover
2313: ! min+max+opt temps & vmax for photosynthesis
2314: REAL(r_std),DIMENSION(kjpindex,nvm,npco2),INTENT(out) :: assim_param_x
2315:
2316: ! deforestation variables
2317: ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
2318: ! (10 or 100 + 1 : input from year of deforestation)
2319: REAL(r_std),DIMENSION(kjpindex,0:10), INTENT (out) :: prod10
2320: REAL(r_std),DIMENSION(kjpindex,0:100), INTENT (out) :: prod100
2321: ! annual release from the 10/100 year-turnover pool compartments
2322: REAL(r_std),DIMENSION(kjpindex,10), INTENT (out) :: flux10
2323: REAL(r_std),DIMENSION(kjpindex,100), INTENT (out) :: flux100
2324: ! release during first year following deforestation
2325: REAL(r_std),DIMENSION(kjpindex), INTENT (out) :: convflux
2326: ! total annual release from the 10/100 year-turnover pool
2327: REAL(r_std),DIMENSION(kjpindex), INTENT (out) :: cflux_prod10, cflux_prod100
2328: !-
2329: ! local declaration
2330: !-
2331: ! dummy time step, must be zero
2332: REAL(r_std),PARAMETER :: dt_0 = 0.
2333: REAL(r_std),DIMENSION(kjpindex,nvm) :: vcmax
2334: REAL(r_std),DIMENSION(kjpindex,nvm) :: vjmax
2335: ! Min temperature for photosynthesis (deg C)
2336: REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_min
2337: ! Opt temperature for photosynthesis (deg C)
2338: REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_opt
2339: ! Max temperature for photosynthesis (deg C)
2340: REAL(r_std),DIMENSION(kjpindex,npft) :: t_photo_max
2341: ! Fraction of space that is natural
2342: REAL(r_std),DIMENSION(kjpindex) :: space_nat
2343: ! Index
2344: INTEGER(i_std) :: j
2345: !---------------------------------------------------------------------
2346:
2347: ! initialisation of deforestation variables
2348: W*===== prod10(:,:) = 0.
2349: **===== prod100(:,:) = 0.
2350: **===== flux10(:,:) = 0.
2351: **===== flux100(:,:) = 0.
2352: V------> convflux(:) = 0.
2353: | cflux_prod10(:) = 0.
2354: V------ cflux_prod100(:) = 0.
2355:
2356: IF (control%ok_stomate) THEN
2357: !
2358: ! 1 photosynthesis parameters
2359: !
2360: !
2361: ! 1.1 vcmax
2362: ! only if STOMATE is activated
2363: !
2364: CALL vmax (kjpindex, dt_0, leaf_age, leaf_frac, vcmax, vjmax)
2365: !
2366: ! 1.2 assimilation temperatures
2367: !
2368: CALL assim_temp(kjpindex, tlong_ref, t2m_month, &
2369: t_photo_min, t_photo_opt, t_photo_max)
2370: !
2371: ! 1.3 transform into nvm vegetation types
2372: !
2373: CALL stomate_var_xout &
2374: & (kjpindex,vcmax,veget,zero,assim_param_x(:,:,ivcmax))
2375: CALL stomate_var_xout &
2376: & (kjpindex,vjmax,veget,zero,assim_param_x(:,:,ivjmax))
2377: CALL stomate_var_xout &
2378: & (kjpindex,t_photo_min,veget,zero,assim_param_x(:,:,itmin))
2379: CALL stomate_var_xout &
2380: & (kjpindex,t_photo_opt,veget,zero,assim_param_x(:,:,itopt))
2381: CALL stomate_var_xout &
2382: & (kjpindex,t_photo_max,veget,zero,assim_param_x(:,:,itmax))
2383: !
2384: ! 2 dead leaf cover
2385: !
2386: ! first recalculate fraction of natural space
2387: V====== space_nat(:) = 1.0
2388: +------> DO j = 1, npft
2389: | IF (.NOT.natural(j)) THEN
2390: |V===== space_nat(:) = space_nat(:)-veget_max(:,j)
2391: | ENDIF
2392: +------ ENDDO
2393: CALL deadleaf (kjpindex, space_nat, dead_leaves, deadleaf_cover)
2394: !
2395: ! 3 qsintmax
2396: !
2397: WW===== qsintmax(:,:) = qsintcst*veget_x(:,:)*lai_x(:,:)
2398: ENDIF ! ok_stomate = .TRUE.
2399: !--------------------------------
2400: END SUBROUTINE stomate_var_init
2401: !
2402: !=
2403: !
2404: SUBROUTINE stomate_accu &
2405: & (npts, n_dim2, dt_tot, dt, ldmean, field_in, field_out)
2406: !---------------------------------------------------------------------
2407: !
2408: ! 0 declarations
2409: !
2410: ! 0.1 input
2411: !
2412: ! Domain size
2413: INTEGER(i_std),INTENT(in) :: npts
2414: ! 2nd dimension (1 or npft)
2415: INTEGER(i_std),INTENT(in) :: n_dim2
2416: ! Time step of STOMATE (days)
2417: REAL(r_std),INTENT(in) :: dt_tot
2418: ! Time step in days
2419: REAL(r_std),INTENT(in) :: dt
2420: ! Calculate mean ?
2421: LOGICAL,INTENT(in) :: ldmean
2422: ! Daily field
2423: REAL(r_std),DIMENSION(npts,n_dim2),INTENT(in) :: field_in
2424: !
2425: ! 0.2 modified field
2426: !
2427: ! Annual field
2428: REAL(r_std),DIMENSION(npts,n_dim2),INTENT(inout) :: field_out
2429: !---------------------------------------------------------------------
2430: !
2431: ! 1 accumulation
2432: !
2433: W*===== field_out(:,:) = field_out(:,:)+field_in(:,:)*dt
2434: !
2435: ! 2 mean fields
2436: !
2437: IF (ldmean) THEN
2438: **===== field_out(:,:) = field_out(:,:)/dt_tot
2439: ENDIF
2440: !---------------------------------------------------------------------
2441: END SUBROUTINE stomate_accu
2442: !
2443: !=
2444: !
2445: SUBROUTINE stomate_vegconvert &
2446: & (kjpindex,which_way,fraction_nobio, &
2447: & veget_max_x,veget_x,veget_max,veget,fvm,fv)
2448: !---------------------------------------------------------------------
2449: !
2450: ! 0 declarations
2451: !
2452: !
2453: ! 0.1 input
2454: !
2455: ! 0.1.1 input scalar
2456: !
2457: ! Domain size
2458: INTEGER(i_std),INTENT(in) :: kjpindex
2459: ! veget -> veget_x ('out') or veget_x -> veget ('in') ?
2460: CHARACTER(LEN=*),INTENT(in) :: which_way
2461: ! Fraction of land covered by lakes, land ice, cities, ...
2462: REAL(r_std),DIMENSION(kjpindex),INTENT(in) :: fraction_nobio
2463: !
2464: ! 0.2 modified
2465: !
2466: ! Max vegetation fraction of hydrological module
2467: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: veget_max_x
2468: ! Vegetation fraction of hydrological module
2469: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: veget_x
2470: ! Max vegetation fraction of STOMATE
2471: REAL(r_std),DIMENSION(kjpindex,npft),INTENT(inout) :: veget_max
2472: ! Vegetation fraction of STOMATE
2473: REAL(r_std),DIMENSION(kjpindex,npft),INTENT(inout) :: veget
2474: ! factor that converts veget_max_x into veget_max
2475: REAL(r_std),DIMENSION(kjpindex,npft),INTENT(inout) :: fvm
2476: ! factor that converts veget_x into veget
2477: REAL(r_std),DIMENSION(kjpindex,npft),INTENT(inout) :: fv
2478: !
2479: ! 0.3 local
2480: !
2481: INTEGER(i_std) :: j,jv
2482: !---------------------------------------------------------------------
2483: IF (which_way == 'in') THEN
2484: !
2485: ! 1 Convert veget_x into veget
2486: !
2487: +------> DO j = 1, npft
2488: |V-----> WHERE ((1.-fraction_nobio(:)) > 0.0)
2489: || veget(:,j) = veget_x(:,ipft_sechiba(j)) &
2490: || & *fv(:,j)/(1.-fraction_nobio(:))
2491: || veget_max(:,j) = veget_max_x(:,ipft_sechiba(j)) &
2492: || & *fvm(:,j)/(1.-fraction_nobio(:))
2493: || ELSEWHERE
2494: || veget(:,j) = 0.
2495: |V----- veget_max(:,j) = 0.
2496: | ENDWHERE
2497: +------ ENDDO
2498: ELSEIF (which_way == 'out') THEN
2499: !
2500: ! 2 Convert veget into veget_x
2501: ! and calculate fv and fvm for next time step
2502: !
2503: ! 2.1 vegetation
2504: !
2505: *W-----> veget_x(:,:) = 0.0
2506: *W----- veget_max_x(:,:) = 0.0
2507: +------> DO j = 1, npft
2508: |V-----> veget_x(:,ipft_sechiba(j)) = &
2509: || & veget_x(:,ipft_sechiba(j)) &
2510: || & +veget(:,j)*(1.-fraction_nobio(:))
2511: |V----- veget_max_x(:,ipft_sechiba(j)) = &
2512: | & veget_max_x(:,ipft_sechiba(j)) &
2513: | & +veget_max(:,j)*(1.-fraction_nobio(:))
2514: +------ ENDDO
2515: !
2516: ! 2.2 bare soil
2517: ! for bare soil, veget_max is actually the potential minimum, as
2518: ! it is calculated using the potential maximum vegetation cover.
2519: ! veget_max has no real physical meaning anyway.
2520: !
2521: V------> veget_max_x(:,ibare_sechiba) = 1.-fraction_nobio(:)
2522: V------ veget_x(:,ibare_sechiba) = 1.-fraction_nobio(:)
2523: +------> DO jv = 1, nvm
2524: | IF (jv /= ibare_sechiba) THEN
2525: |V-----> veget_max_x(:,ibare_sechiba) = veget_max_x(:,ibare_sechiba) &
2526: || & -veget_max_x(:,jv)
2527: |V----- veget_x(:,ibare_sechiba) = veget_x(:,ibare_sechiba) &
2528: | & -veget_x(:,jv)
2529: | ENDIF
2530: +------ ENDDO
2531: ! potential minimum bare soil cover cannot be less than 0
2532: V====== veget_max_x(:,ibare_sechiba) = &
2533: & MAX(veget_max_x(:,ibare_sechiba),0._r_std)
2534: !
2535: ! 2.3 calculate fv and fvm
2536: !
2537: +------> DO j=1,npft
2538: |V-----> WHERE (veget_max_x(:,ipft_sechiba(j)) > 0.)
2539: || fvm(:,j) = veget_max(:,j)/veget_max_x(:,ipft_sechiba(j)) &
2540: || & *(1.-fraction_nobio(:))
2541: || ELSEWHERE
2542: |V----- fvm(:,j) = 0.0
2543: | ENDWHERE
2544: |V-----> WHERE (veget_x(:,ipft_sechiba(j)) > 0.)
2545: || fv(:,j) = veget(:,j)/veget_x(:,ipft_sechiba(j)) &
2546: || & *(1.-fraction_nobio(:))
2547: || ELSEWHERE
2548: |V----- fv(:,j) = 0.0
2549: | ENDWHERE
2550: +------ ENDDO
2551: ELSE
2552: WRITE(numout,*) 'stomate_vegconvert: which_way = ', which_way
2553: STOP 'Cannot go this way.'
2554: ENDIF
2555: !--------------------------------
2556: END SUBROUTINE stomate_vegconvert
2557: !
2558: !=
2559: !
2560: SUBROUTINE stomate_var_xout (kjpindex,var,vfrac,bare_val,var_x)
2561: !---------------------------------------------------------------------
2562: ! this subroutine outputs a variable (e.g. lai_x) on nvm vegetation
2563: ! types given an input (e.g. lai) on npft vegetation types.
2564: ! Ponderation is done using vfrac (= veget or veget_max)
2565: !
2566: ! 0 declarations
2567: !
2568: ! 0.1 input
2569: !
2570: ! 0.1.1 input scalar
2571: !
2572: ! Domain size
2573: INTEGER(i_std),INTENT(in) :: kjpindex
2574: ! variable defined on npft
2575: REAL(r_std),DIMENSION(kjpindex,npft),INTENT(in) :: var
2576: ! vegetation fraction
2577: REAL(r_std),DIMENSION(kjpindex,npft),INTENT(in) :: vfrac
2578: ! value for bare ground
2579: REAL(r_std),INTENT(in) :: bare_val
2580: !
2581: ! 0.2 output
2582: ! variable defined on nvm
2583: REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out) :: var_x
2584: !
2585: ! 0.3 local
2586: !
2587: INTEGER(i_std) :: j
2588: REAL(r_std),DIMENSION(kjpindex,nvm) :: vfracsum
2589: !---------------------------------------------------------------------
2590: !
2591: ! 1 Calculate ponderated value for vegetation types
2592: !
2593: *V-----> var_x(:,:) = 0.0
2594: *V----- vfracsum(:,:) = 0.0
2595: +------> DO j = 1, npft
2596: |V-----> var_x(:,ipft_sechiba(j)) = var_x(:,ipft_sechiba(j)) &
2597: || & +var(:,j)*vfrac(:,j)
2598: |V----- vfracsum(:,ipft_sechiba(j)) = vfracsum(:,ipft_sechiba(j)) &
2599: | & +vfrac(:,j)
2600: +------ ENDDO
2601: *V-----> WHERE (vfracsum(:,:) > 0.0)
2602: *V----- var_x(:,:) = var_x(:,:)/vfracsum(:,:)
2603: ENDWHERE
2604: !
2605: ! 2 impose a value for bare soil
2606: !
2607: V====== var_x(:,ibare_sechiba) = bare_val
2608: !------------------------------
2609: END SUBROUTINE stomate_var_xout
2610: !
2611: !=
2612: !
2613: SUBROUTINE init_forcing (kjpindex,nsfm,nsft)
2614: !---------------------------------------------------------------------
2615: INTEGER(i_std),INTENT(in) :: kjpindex
2616: INTEGER(i_std),INTENT(in) :: nsfm
2617: INTEGER(i_std),INTENT(in) :: nsft
2618: !
2619: LOGICAL :: l_error
2620: INTEGER(i_std) :: ier
2621: !---------------------------------------------------------------------
2622: l_error = .FALSE.
2623: !
2624: ALLOCATE(clay_fm(kjpindex,nsfm),stat=ier)
2625: l_error = l_error .OR. (ier /= 0)
2626: ALLOCATE(humrel_daily_x_fm(kjpindex,nvm,nsfm),stat=ier)
2627: l_error = l_error .OR. (ier /= 0)
2628: ALLOCATE(litterhum_daily_fm(kjpindex,nsfm),stat=ier)
2629: l_error = l_error .OR. (ier /= 0)
2630: ALLOCATE(t2m_daily_fm(kjpindex,nsfm),stat=ier)
2631: l_error = l_error .OR. (ier /= 0)
2632: ALLOCATE(t2m_min_daily_fm(kjpindex,nsfm),stat=ier)
2633: l_error = l_error .OR. (ier /= 0)
2634: ALLOCATE(tsurf_daily_fm(kjpindex,nsfm),stat=ier)
2635: l_error = l_error .OR. (ier /= 0)
2636: ALLOCATE(tsoil_daily_fm(kjpindex,nbdl,nsfm),stat=ier)
2637: l_error = l_error .OR. (ier /= 0)
2638: ALLOCATE(soilhum_daily_fm(kjpindex,nbdl,nsfm),stat=ier)
2639: l_error = l_error .OR. (ier /= 0)
2640: ALLOCATE(precip_fm(kjpindex,nsfm),stat=ier)
2641: l_error = l_error .OR. (ier /= 0)
2642: ALLOCATE(gpp_daily_x_fm(kjpindex,nvm,nsfm),stat=ier)
2643: l_error = l_error .OR. (ier /= 0)
2644: ALLOCATE(resp_maint_part_x_fm(kjpindex,nvm,nparts,nsfm),stat=ier)
2645: l_error = l_error .OR. (ier /= 0)
2646: ALLOCATE(veget_x_fm(kjpindex,nvm,nsfm),stat=ier)
2647: l_error = l_error .OR. (ier /= 0)
2648: ALLOCATE(veget_max_x_fm(kjpindex,nvm,nsfm),stat=ier)
2649: l_error = l_error .OR. (ier /= 0)
2650: ALLOCATE(lai_x_fm(kjpindex,nvm,nsfm),stat=ier)
2651: l_error = l_error .OR. (ier /= 0)
2652: ALLOCATE(isf(nsfm),stat=ier)
2653: l_error = l_error .OR. (ier /= 0)
2654: ALLOCATE(nf_written(nsft),stat=ier)
2655: l_error = l_error .OR. (ier /= 0)
2656: ALLOCATE(nf_cumul(nsft),stat=ier)
2657: l_error = l_error .OR. (ier /= 0)
2658:
2659: IF (is_root_prc) THEN
2660: ALLOCATE(clay_fm_g(nbp_glo,nsfm),stat=ier)
2661: l_error = l_error .OR. (ier /= 0)
2662: ALLOCATE(humrel_daily_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
2663: l_error = l_error .OR. (ier /= 0)
2664: ALLOCATE(litterhum_daily_fm_g(nbp_glo,nsfm),stat=ier)
2665: l_error = l_error .OR. (ier /= 0)
2666: ALLOCATE(t2m_daily_fm_g(nbp_glo,nsfm),stat=ier)
2667: l_error = l_error .OR. (ier /= 0)
2668: ALLOCATE(t2m_min_daily_fm_g(nbp_glo,nsfm),stat=ier)
2669: l_error = l_error .OR. (ier /= 0)
2670: ALLOCATE(tsurf_daily_fm_g(nbp_glo,nsfm),stat=ier)
2671: l_error = l_error .OR. (ier /= 0)
2672: ALLOCATE(tsoil_daily_fm_g(nbp_glo,nbdl,nsfm),stat=ier)
2673: l_error = l_error .OR. (ier /= 0)
2674: ALLOCATE(soilhum_daily_fm_g(nbp_glo,nbdl,nsfm),stat=ier)
2675: l_error = l_error .OR. (ier /= 0)
2676: ALLOCATE(precip_fm_g(nbp_glo,nsfm),stat=ier)
2677: l_error = l_error .OR. (ier /= 0)
2678: ALLOCATE(gpp_daily_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
2679: l_error = l_error .OR. (ier /= 0)
2680: ALLOCATE(resp_maint_part_x_fm_g(nbp_glo,nvm,nparts,nsfm),stat=ier)
2681: l_error = l_error .OR. (ier /= 0)
2682: ALLOCATE(veget_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
2683: l_error = l_error .OR. (ier /= 0)
2684: ALLOCATE(veget_max_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
2685: l_error = l_error .OR. (ier /= 0)
2686: ALLOCATE(lai_x_fm_g(nbp_glo,nvm,nsfm),stat=ier)
2687: l_error = l_error .OR. (ier /= 0)
2688: ENDIF
2689: !
2690: IF (l_error) THEN
2691: WRITE(numout,*) 'Problem with memory allocation: forcing variables'
2692: STOP 'init_forcing'
2693: ENDIF
2694: !
2695: CALL forcing_zero
2696: !--------------------------
2697: END SUBROUTINE init_forcing
2698: !
2699: !=
2700: !
2701: SUBROUTINE forcing_zero
2702: !---------------------------------------------------------------------
2703: WW===== clay_fm(:,:) = 0.0
2704: WWW==== humrel_daily_x_fm(:,:,:) = 0.0
2705: WW===== litterhum_daily_fm(:,:) = 0.0
2706: WW===== t2m_daily_fm(:,:) = 0.0
2707: WW===== t2m_min_daily_fm(:,:) = 0.0
2708: WW===== tsurf_daily_fm(:,:) = 0.0
2709: W**==== tsoil_daily_fm(:,:,:) = 0.0
2710: ***==== soilhum_daily_fm(:,:,:) = 0.0
2711: **===== precip_fm(:,:) = 0.0
2712: ***==== gpp_daily_x_fm(:,:,:) = 0.0
2713: ****=== resp_maint_part_x_fm(:,:,:,:)=0.0
2714: ***==== veget_x_fm(:,:,:) = 0.0
2715: ***==== veget_max_x_fm(:,:,:) = 0.0
2716: ***==== lai_x_fm(:,:,:) = 0.0
2717: !--------------------------------
2718: END SUBROUTINE forcing_zero
2719: !
2720: !=
2721: !
2722: SUBROUTINE forcing_write(forcing_id,ibeg,iend)
2723: !---------------------------------------------------------------------
2724: INTEGER(i_std),INTENT(in) :: forcing_id
2725: INTEGER(i_std),INTENT(in) :: ibeg, iend
2726: !
2727: INTEGER(i_std) :: iisf, iblocks, nblocks
2728: INTEGER(i_std) :: ier
2729: INTEGER(i_std),DIMENSION(0:2) :: ifirst, ilast
2730: INTEGER(i_std),PARAMETER :: ndm = 10
2731: INTEGER(i_std),DIMENSION(ndm) :: start, count
2732: INTEGER(i_std) :: ndim, vid
2733: !---------------------------------------------------------------------
2734: !
2735: ! determine blocks of forcing states that are contiguous in memory
2736: !
2737: nblocks = 0
2738: *------> ifirst(:) = 1
2739: *------ ilast(:) = 1
2740: !
2741: +------> DO iisf = ibeg, iend
2742: | IF ( (nblocks /= 0) &
2743: | & .AND.(isf(iisf) == isf(ilast(nblocks))+1)) THEN
2744: | ! element is contiguous with last element found
2745: | ilast(nblocks) = iisf
2746: | ELSE
2747: | ! found first element of new block
2748: | nblocks = nblocks+1
2749: | IF (nblocks > 2) STOP 'Problem in forcing_write'
2750: | ifirst(nblocks) = iisf
2751: | ilast(nblocks) = iisf
2752: | ENDIF
2753: +------ ENDDO
2754: !
2755: +------> DO iblocks = 1, nblocks
2756: | IF (ifirst(iblocks) /= ilast(iblocks)) THEN
2757: | CALL gather(clay_fm,clay_fm_g)
2758: | IF (is_root_prc) THEN
2759: | ndim = 2
2760: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2761: | count(1:ndim) = SHAPE(clay_fm_g)
2762: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2763: | ier = NF90_INQ_VARID (forcing_id,'clay',vid)
2764: | ier = NF90_PUT_VAR (forcing_id,vid, &
2765: | & clay_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
2766: | & start=start(1:ndim), count=count(1:ndim))
2767: | ENDIF
2768: |
2769: | CALL gather(humrel_daily_x_fm,humrel_daily_x_fm_g)
2770: | IF (is_root_prc) THEN
2771: | ndim = 3;
2772: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2773: | count(1:ndim) = SHAPE(humrel_daily_x_fm_g)
2774: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2775: | ier = NF90_INQ_VARID (forcing_id,'humrel',vid)
2776: | ier = NF90_PUT_VAR (forcing_id, vid, &
2777: | & humrel_daily_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
2778: | & start=start(1:ndim), count=count(1:ndim))
2779: | ENDIF
2780: |
2781: | CALL gather(litterhum_daily_fm,litterhum_daily_fm_g)
2782: | IF (is_root_prc) THEN
2783: | ndim = 2;
2784: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2785: | count(1:ndim) = SHAPE(litterhum_daily_fm_g)
2786: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2787: | ier = NF90_INQ_VARID (forcing_id,'litterhum',vid)
2788: | ier = NF90_PUT_VAR (forcing_id, vid, &
2789: | & litterhum_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
2790: | & start=start(1:ndim), count=count(1:ndim))
2791: | ENDIF
2792: |
2793: | CALL gather(t2m_daily_fm,t2m_daily_fm_g)
2794: | IF (is_root_prc) THEN
2795: | ndim = 2;
2796: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2797: | count(1:ndim) = SHAPE(t2m_daily_fm_g)
2798: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2799: | ier = NF90_INQ_VARID (forcing_id,'t2m',vid)
2800: | ier = NF90_PUT_VAR (forcing_id, vid, &
2801: | & t2m_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
2802: | & start=start(1:ndim), count=count(1:ndim))
2803: | ENDIF
2804: |
2805: | CALL gather(t2m_min_daily_fm,t2m_min_daily_fm_g)
2806: | IF (is_root_prc) THEN
2807: | ndim = 2;
2808: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2809: | count(1:ndim) = SHAPE(t2m_min_daily_fm_g)
2810: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2811: | ier = NF90_INQ_VARID (forcing_id,'t2m_min',vid)
2812: | ier = NF90_PUT_VAR (forcing_id, vid, &
2813: | & t2m_min_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
2814: | & start=start(1:ndim), count=count(1:ndim))
2815: | ENDIF
2816: |
2817: | CALL gather(tsurf_daily_fm,tsurf_daily_fm_g)
2818: | IF (is_root_prc) THEN
2819: | ndim = 2;
2820: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2821: | count(1:ndim) = SHAPE(tsurf_daily_fm_g)
2822: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2823: | ier = NF90_INQ_VARID (forcing_id,'tsurf',vid)
2824: | ier = NF90_PUT_VAR (forcing_id, vid, &
2825: | & tsurf_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
2826: | & start=start(1:ndim), count=count(1:ndim))
2827: | ENDIF
2828: |
2829: | CALL gather(tsoil_daily_fm,tsoil_daily_fm_g)
2830: | IF (is_root_prc) THEN
2831: | ndim = 3;
2832: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2833: | count(1:ndim) = SHAPE(tsoil_daily_fm_g)
2834: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2835: | ier = NF90_INQ_VARID (forcing_id,'tsoil',vid)
2836: | ier = NF90_PUT_VAR (forcing_id, vid, &
2837: | & tsoil_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
2838: | & start=start(1:ndim), count=count(1:ndim))
2839: | ENDIF
2840: |
2841: | CALL gather(soilhum_daily_fm,soilhum_daily_fm_g)
2842: | IF (is_root_prc) THEN
2843: | ndim = 3;
2844: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2845: | count(1:ndim) = SHAPE(soilhum_daily_fm_g)
2846: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2847: | ier = NF90_INQ_VARID (forcing_id,'soilhum',vid)
2848: | ier = NF90_PUT_VAR (forcing_id, vid, &
2849: | & soilhum_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
2850: | & start=start(1:ndim), count=count(1:ndim))
2851: | ENDIF
2852: |
2853: | CALL gather(precip_fm,precip_fm_g)
2854: | IF (is_root_prc) THEN
2855: | ndim = 2;
2856: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2857: | count(1:ndim) = SHAPE(precip_fm)
2858: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2859: | ier = NF90_INQ_VARID (forcing_id,'precip',vid)
2860: | ier = NF90_PUT_VAR (forcing_id, vid, &
2861: | & precip_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
2862: | & start=start(1:ndim), count=count(1:ndim))
2863: | ENDIF
2864: |
2865: | CALL gather(gpp_daily_x_fm,gpp_daily_x_fm_g)
2866: | IF (is_root_prc) THEN
2867: | ndim = 3;
2868: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2869: | count(1:ndim) = SHAPE(gpp_daily_x_fm_g)
2870: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2871: | ier = NF90_INQ_VARID (forcing_id,'gpp',vid)
2872: | ier = NF90_PUT_VAR (forcing_id, vid, &
2873: | & gpp_daily_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
2874: | & start=start(1:ndim), count=count(1:ndim))
2875: | ENDIF
2876: |
2877: | CALL gather(resp_maint_part_x_fm,resp_maint_part_x_fm_g)
2878: | IF (is_root_prc) THEN
2879: | ndim = 4;
2880: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2881: | count(1:ndim)=SHAPE(resp_maint_part_x_fm_g)
2882: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2883: | ier = NF90_INQ_VARID (forcing_id,'resp_maint_part',vid)
2884: | ier = NF90_PUT_VAR (forcing_id,vid, &
2885: | & resp_maint_part_x_fm_g(:,:,:,ifirst(iblocks):ilast(iblocks)), &
2886: | & start=start(1:ndim), count=count(1:ndim))
2887: | ENDIF
2888: |
2889: | CALL gather(veget_x_fm,veget_x_fm_g)
2890: | IF (is_root_prc) THEN
2891: | ndim = 3;
2892: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2893: | count(1:ndim) = SHAPE(veget_x_fm_g)
2894: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2895: | ier = NF90_INQ_VARID (forcing_id,'veget',vid)
2896: | ier = NF90_PUT_VAR (forcing_id, vid, &
2897: | & veget_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
2898: | & start=start(1:ndim), count=count(1:ndim))
2899: | ENDIF
2900: |
2901: | CALL gather(veget_max_x_fm,veget_max_x_fm_g)
2902: | IF (is_root_prc) THEN
2903: | ndim = 3;
2904: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2905: | count(1:ndim) = SHAPE(veget_max_x_fm_g)
2906: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2907: | ier = NF90_INQ_VARID (forcing_id,'veget_max',vid)
2908: | ier = NF90_PUT_VAR (forcing_id, vid, &
2909: | & veget_max_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
2910: | & start=start(1:ndim), count=count(1:ndim))
2911: | ENDIF
2912: |
2913: | CALL gather(lai_x_fm,lai_x_fm_g)
2914: | IF (is_root_prc) THEN
2915: | ndim = 3;
2916: |+===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2917: | count(1:ndim) = SHAPE(lai_x_fm_g)
2918: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2919: | ier = NF90_INQ_VARID (forcing_id,'lai',vid)
2920: | ier = NF90_PUT_VAR (forcing_id, vid, &
2921: | lai_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
2922: | & start=start(1:ndim), count=count(1:ndim))
2923: | ENDIF
2924: | ENDIF
2925: +------ ENDDO
2926: V====== nf_written(isf(:)) = .TRUE.
2927: !---------------------------
2928: END SUBROUTINE forcing_write
2929: !
2930: !=
2931: !
2932: SUBROUTINE forcing_read(forcing_id,nsfm)
2933: !---------------------------------------------------------------------
2934: INTEGER(i_std),INTENT(in) :: forcing_id
2935: INTEGER(i_std),INTENT(in) :: nsfm
2936: !
2937: INTEGER(i_std) :: iisf, iblocks, nblocks
2938: INTEGER(i_std) :: ier
2939: INTEGER(i_std),DIMENSION(0:2) :: ifirst, ilast
2940: INTEGER(i_std),PARAMETER :: ndm = 10
2941: INTEGER(i_std),DIMENSION(ndm) :: start, count
2942: INTEGER(i_std) :: ndim, vid
2943: !---------------------------------------------------------------------
2944: !
2945: ! set to zero if the corresponding forcing state
2946: ! has not yet been written into the file
2947: !
2948: V------> DO iisf = 1, nsfm
2949: | S IF (.NOT.nf_written(isf(iisf))) THEN
2950: |V===== clay_fm(:,iisf) = 0.0
2951: |W+==== humrel_daily_x_fm(:,:,iisf) = 0.0
2952: |V===== litterhum_daily_fm(:,iisf) = 0.0
2953: |V===== t2m_daily_fm(:,iisf) = 0.0
2954: |V===== t2m_min_daily_fm(:,iisf) = 0.0
2955: |V===== tsurf_daily_fm(:,iisf) = 0.0
2956: |WW==== tsoil_daily_fm(:,:,iisf) = 0.0
2957: |++==== soilhum_daily_fm(:,:,iisf) = 0.0
2958: |V===== precip_fm(:,iisf) = 0.0
2959: |WW==== gpp_daily_x_fm(:,:,iisf) = 0.0
2960: |WWW=== resp_maint_part_x_fm(:,:,:,iisf) = 0.0
2961: |**==== veget_x_fm(:,:,iisf) = 0.0
2962: |**==== veget_max_x_fm(:,:,iisf) = 0.0
2963: |**==== lai_x_fm(:,:,iisf) = 0.0
2964: | ENDIF
2965: V------ ENDDO
2966: !
2967: ! determine blocks of forcing states that are contiguous in memory
2968: !
2969: nblocks = 0
2970: *------> ifirst(:) = 1
2971: *------ ilast(:) = 1
2972: !
2973: +------> DO iisf = 1, nsfm
2974: | IF (nf_written(isf(iisf))) THEN
2975: | IF ( (nblocks /= 0) &
2976: | & .AND.(isf(iisf) == isf(ilast(nblocks))+1)) THEN
2977: | ! element is contiguous with last element found
2978: | ilast(nblocks) = iisf
2979: | ELSE
2980: | ! found first element of new block
2981: | nblocks = nblocks+1
2982: | IF (nblocks > 2) STOP 'Problem in forcing_read'
2983: | !
2984: | ifirst(nblocks) = iisf
2985: | ilast(nblocks) = iisf
2986: | ENDIF
2987: | ENDIF
2988: +------ ENDDO
2989: !
2990: +------> DO iblocks = 1, nblocks
2991: | IF (ifirst(iblocks) /= ilast(iblocks)) THEN
2992: | IF (is_root_prc) THEN
2993: | ndim = 2;
2994: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
2995: | count(1:ndim) = SHAPE(clay_fm_g)
2996: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
2997: | ier = NF90_INQ_VARID (forcing_id,'clay',vid)
2998: | ier = NF90_GET_VAR (forcing_id, vid, &
2999: | & clay_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
3000: | & start=start(1:ndim), count=count(1:ndim))
3001: | ENDIF
3002: | CALL scatter(clay_fm_g,clay_fm)
3003: |
3004: | IF (is_root_prc) THEN
3005: | ndim = 3;
3006: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3007: | count(1:ndim) = SHAPE(humrel_daily_x_fm_g)
3008: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3009: | ier = NF90_INQ_VARID (forcing_id,'humrel',vid)
3010: | ier = NF90_GET_VAR (forcing_id, vid, &
3011: | & humrel_daily_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
3012: | & start=start(1:ndim), count=count(1:ndim))
3013: | ENDIF
3014: | CALL scatter(humrel_daily_x_fm_g,humrel_daily_x_fm)
3015: |
3016: | IF (is_root_prc) THEN
3017: | ndim = 2;
3018: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3019: | count(1:ndim) = SHAPE(litterhum_daily_fm_g)
3020: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3021: | ier = NF90_INQ_VARID (forcing_id,'litterhum',vid)
3022: | ier = NF90_GET_VAR (forcing_id, vid, &
3023: | & litterhum_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
3024: | & start=start(1:ndim), count=count(1:ndim))
3025: | ENDIF
3026: | CALL scatter(litterhum_daily_fm_g,litterhum_daily_fm)
3027: |
3028: | IF (is_root_prc) THEN
3029: | ndim = 2;
3030: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3031: | count(1:ndim) = SHAPE(t2m_daily_fm_g)
3032: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3033: | ier = NF90_INQ_VARID (forcing_id,'t2m',vid)
3034: | ier = NF90_GET_VAR (forcing_id, vid, &
3035: | & t2m_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
3036: | & start=start(1:ndim), count=count(1:ndim))
3037: | ENDIF
3038: | CALL scatter(t2m_daily_fm_g,t2m_daily_fm)
3039: |
3040: | IF (is_root_prc) THEN
3041: | ndim = 2;
3042: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3043: | count(1:ndim) = SHAPE(t2m_min_daily_fm_g)
3044: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3045: | ier = NF90_INQ_VARID (forcing_id,'t2m_min',vid)
3046: | ier = NF90_GET_VAR (forcing_id, vid, &
3047: | & t2m_min_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
3048: | & start=start(1:ndim), count=count(1:ndim))
3049: | ENDIF
3050: | CALL scatter(t2m_min_daily_fm_g,t2m_min_daily_fm)
3051: |
3052: | IF (is_root_prc) THEN
3053: | ndim = 2;
3054: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3055: | count(1:ndim) = SHAPE(tsurf_daily_fm_g)
3056: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3057: | ier = NF90_INQ_VARID (forcing_id,'tsurf',vid)
3058: | ier = NF90_GET_VAR (forcing_id, vid, &
3059: | & tsurf_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
3060: | & start=start(1:ndim), count=count(1:ndim))
3061: | ENDIF
3062: | CALL scatter(tsurf_daily_fm_g,tsurf_daily_fm)
3063: |
3064: | IF (is_root_prc) THEN
3065: | ndim = 3;
3066: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3067: | count(1:ndim) = SHAPE(tsoil_daily_fm_g)
3068: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3069: | ier = NF90_INQ_VARID (forcing_id,'tsoil',vid)
3070: | ier = NF90_GET_VAR (forcing_id, vid, &
3071: | & tsoil_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
3072: | & start=start(1:ndim), count=count(1:ndim))
3073: | ENDIF
3074: | CALL scatter(tsoil_daily_fm_g,tsoil_daily_fm)
3075: |
3076: | IF (is_root_prc) THEN
3077: | ndim = 3;
3078: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3079: | count(1:ndim) = SHAPE(soilhum_daily_fm_g)
3080: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3081: | ier = NF90_INQ_VARID (forcing_id,'soilhum',vid)
3082: | ier = NF90_GET_VAR (forcing_id, vid, &
3083: | & soilhum_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
3084: | & start=start(1:ndim), count=count(1:ndim))
3085: | ENDIF
3086: | CALL scatter(soilhum_daily_fm_g,soilhum_daily_fm)
3087: |
3088: | IF (is_root_prc) THEN
3089: | ndim = 2;
3090: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3091: | count(1:ndim) = SHAPE(precip_fm_g)
3092: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3093: | ier = NF90_INQ_VARID (forcing_id,'precip',vid)
3094: | ier = NF90_GET_VAR (forcing_id, vid, &
3095: | & precip_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
3096: | & start=start(1:ndim), count=count(1:ndim))
3097: | ENDIF
3098: | CALL scatter(precip_fm_g,precip_fm)
3099: |
3100: | IF (is_root_prc) THEN
3101: | ndim = 3;
3102: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3103: | count(1:ndim) = SHAPE(gpp_daily_x_fm_g)
3104: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3105: | ier = NF90_INQ_VARID (forcing_id,'gpp',vid)
3106: | ier = NF90_GET_VAR (forcing_id, vid, &
3107: | & gpp_daily_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
3108: | & start=start(1:ndim), count=count(1:ndim))
3109: | ENDIF
3110: | CALL scatter(gpp_daily_x_fm_g,gpp_daily_x_fm)
3111: |
3112: | IF (is_root_prc) THEN
3113: | ndim = 4;
3114: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3115: | count(1:ndim)=SHAPE(resp_maint_part_x_fm_g)
3116: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3117: | ier = NF90_INQ_VARID (forcing_id,'resp_maint_part',vid)
3118: | ier = NF90_GET_VAR (forcing_id,vid, &
3119: | & resp_maint_part_x_fm_g(:,:,:,ifirst(iblocks):ilast(iblocks)), &
3120: | & start=start(1:ndim), count=count(1:ndim))
3121: | ENDIF
3122: | CALL scatter(resp_maint_part_x_fm_g,resp_maint_part_x_fm)
3123: |
3124: | IF (is_root_prc) THEN
3125: | ndim = 3;
3126: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3127: | count(1:ndim) = SHAPE(veget_x_fm_g)
3128: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3129: | ier = NF90_INQ_VARID (forcing_id,'veget',vid)
3130: | ier = NF90_GET_VAR (forcing_id, vid, &
3131: | & veget_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
3132: | & start=start(1:ndim), count=count(1:ndim))
3133: | ENDIF
3134: | CALL scatter(veget_x_fm_g,veget_x_fm)
3135: |
3136: | IF (is_root_prc) THEN
3137: | ndim = 3;
3138: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3139: | count(1:ndim) = SHAPE(veget_max_x_fm_g)
3140: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3141: | ier = NF90_INQ_VARID (forcing_id,'veget_max',vid)
3142: | ier = NF90_GET_VAR (forcing_id, vid, &
3143: | & veget_max_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
3144: | & start=start(1:ndim), count=count(1:ndim))
3145: | ENDIF
3146: | CALL scatter(veget_max_x_fm_g,veget_max_x_fm)
3147: |
3148: | IF (is_root_prc) THEN
3149: | ndim = 3;
3150: |*===== start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
3151: | count(1:ndim) = SHAPE(lai_x_fm_g)
3152: | count(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
3153: | ier = NF90_INQ_VARID (forcing_id,'lai',vid)
3154: | ier = NF90_GET_VAR (forcing_id, vid, &
3155: | & lai_x_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
3156: | & start=start(1:ndim), count=count(1:ndim))
3157: | ENDIF
3158: | CALL scatter(lai_x_fm_g,lai_x_fm_g)
3159: | ENDIF
3160: +------ ENDDO
3161: !--------------------------
3162: END SUBROUTINE forcing_read
3163: !
3164: !=
3165: !
3166: SUBROUTINE setlai(npts,lai)
3167: !---------------------------------------------------------------------
3168: ! routine to force the lai in STOMATE (for assimilation procedures)
3169: ! for the moment setlai only gives the lai from stomate,
3170: ! this routine must be written in the future
3171: !
3172: ! 0 declarations
3173: !
3174: ! 0.1 input
3175: !
3176: ! Domain size
3177: INTEGER(i_std),INTENT(in) :: npts
3178: ! 0.3 output
3179: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: lai
3180: ! 0.4 local definitions
3181: INTEGER(i_std) :: j
3182: !---------------------------------------------------------------------
3183: +------> DO j=1,npft
3184: |V-----> WHERE (veget_max(:,j) > 0.0)
3185: || lai(:,j) = biomass(:,j,ileaf)/veget_max(:,j)*sla(j)
3186: || ELSEWHERE
3187: |V----- lai(:,j) = 0.0
3188: | ENDWHERE
3189: +------ ENDDO
3190: !--------------------
3191: END SUBROUTINE setlai
3192: !
3193: !=
3194: !
3195: !! BEGINNVADD
3196: !
3197: !=====================================================================
3198: ! NV clowproc_soil permet de faire l'interface entre sechiba
3199: ! et stomate lorsque l'on appelle uniquement le calcul du carbon sol
3200: !
3201: SUBROUTINE stomate_soil &
3202: & (npts, dt, clay_r,space_nat_r,&
3203: & soilcarbon_input, control_temp, control_moist,resp_hetero_soil)
3204: !---------------------------------------------------------------------
3205: !
3206: ! 0 declarations
3207: !
3208: ! 0.1 input
3209: !
3210: ! Domain size
3211: INTEGER(i_std),INTENT(in) :: npts
3212: ! time step in days
3213: REAL(r_std),INTENT(in) :: dt
3214: ! quantity of carbon going into carbon pools from litter decomposition
3215: ! (gC/(m**2 of nat/agri ground)/day)
3216: REAL(r_std),DIMENSION(npts),INTENT(in) :: clay_r
3217: REAL(r_std),DIMENSION(npts),INTENT(in) :: space_nat_r
3218: REAL(r_std),DIMENSION(npts,ncarb,nvegtypes),INTENT(in) :: &
3219: & soilcarbon_input
3220: ! temperature control of heterotrophic respiration
3221: REAL(r_std),DIMENSION(npts,nlevs),INTENT(in) :: control_temp
3222: ! moisture control of heterotrophic respiration
3223: REAL(r_std),DIMENSION(npts,nlevs),INTENT(in) :: control_moist
3224: !
3225: ! 0.3 output
3226: !
3227: ! soil heterotrophic respiration
3228: ! (first in gC/day/m**2 of natural/agricultural ground,
3229: ! but output in gC/day/m**2 of total ground)
3230: REAL(r_std),DIMENSION(npts,nvegtypes),INTENT(out) :: resp_hetero_soil
3231: !---------------------------------------------------------------------
3232: write_carbonforce = .FALSE.
3233: CALL soilcarbon (npts, dt, clay_r, space_nat_r, &
3234: soilcarbon_input, control_temp, control_moist, &
3235: carbon, resp_hetero_soil)
3236: !--------------------------
3237: END SUBROUTINE stomate_soil
3238: !
3239: !=
3240: !
3241: SUBROUTINE pondere_nat (npts,pondere)
3242: !---------------------------------------------------------------------
3243: INTEGER(i_std),INTENT(in) :: npts
3244: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: pondere
3245: !
3246: INTEGER(i_std) :: n
3247: !---------------------------------------------------------------------
3248: +------> DO n=1,npft
3249: | IF (natural(n)) THEN
3250: |V===== pondere(:,n)=space_nat(:)
3251: | ELSE
3252: |V===== pondere(:,n)=1.-space_nat(:)
3253: | ENDIF
3254: +------ ENDDO
3255: !-------------------------
3256: END SUBROUTINE pondere_nat
3257: !
3258: !=
3259: !
3260: SUBROUTINE pondere_nat_vegfrac (npts,pondere)
3261: !---------------------------------------------------------------------
3262: INTEGER(i_std),INTENT(in) :: npts
3263: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: pondere
3264: !
3265: INTEGER(i_std) :: n
3266: !---------------------------------------------------------------------
3267: +------> DO n=1,npft
3268: | IF (natural(n)) THEN
3269: |V===== pondere(:,n)=space_nat(:)*veget_max(:,n)
3270: | ELSE
3271: |V===== pondere(:,n)=(1.-space_nat(:))*veget_max(:,n)
3272: | ENDIF
3273: +------ ENDDO
3274: !---------------------------------------------------------------------
3275: END SUBROUTINE pondere_nat_vegfrac
3276: !
3277: !=
3278: !
3279: SUBROUTINE pondere_vegfrac (npts,pondere)
3280: !---------------------------------------------------------------------
3281: INTEGER(i_std),INTENT(in) :: npts
3282: REAL(r_std),DIMENSION(npts,npft),INTENT(out) :: pondere
3283: !
3284: INTEGER(i_std) :: n
3285: !---------------------------------------------------------------------
3286: +------> DO n=1,npft
3287: |V===== pondere(:,n)=veget_max(:,n)
3288: +------ ENDDO
3289: !-----------------------------
3290: END SUBROUTINE pondere_vegfrac
3291: !! ENDNVADD
3292: !
3293: !=
3294: !
3295: !-----------------
3296: END MODULE stomate
ORCHIDEE/src_stomate/Makefile 0000754 0103600 0005670 00000013267 11164403473 015721 0 ustar acamlmd lmdjus #-
#- $Id: AA_make.ldef,v 1.9 2008/01/08 11:49:08 ssipsl Exp $
#-
#---------------------------------------------------------------------
#- Creation des elements relatifs a STOMATE
#---------------------------------------------------------------------
SHELL = /bin/sh
#---------------------------------------------------------------------
LIBDIR = ../../../lib
BINDIR = ../../../bin
MODDIR = $(LIBDIR)
#---------------------------------------------------------------------
MODEL_LIB = $(LIBDIR)/libstomate.a
SXMODEL_LIB = $(MODEL_LIB)
#-
#- $Id: AA_make.gdef 578 2009-03-13 14:05:38Z bellier $
#-
#- Global definitions for gnu g95 compiler
M_K = gmake
P_C = cpp
P_O = -P -C -traditional $(P_P)
F_C = g95 -c
F_D =
F_P = -i4 -r8
w_w = -O5 -cpp -funroll-all-loops $(F_D) $(F_P) -I$(MODDIR)
#####################################-Q- g95 F_O = $(w_w) -fmod=$(MODDIR) -fno-second-underscore
F_O = $(w_w) -fmod=$(MODDIR)
F_L = g95
M_M = 0
L_X = 0
L_O =
A_C = ar -r
A_G = ar -x
C_C = cc -c
C_O =
C_L = cc
#-
NCDF_INC = /d4/acamlmd/LMDZ4V4/netcdf-3.6.1/include
NCDF_LIB = -L/d4/acamlmd/LMDZ4V4/netcdf-3.6.1/lib -lnetcdf
#-
RM = rm -f
STRIP = strip
SIZE = size
#-
#- $Id: AA_make,v 1.24 2008/01/08 11:49:08 ssipsl Exp $
#-
PARAM_LIB = $(LIBDIR)/libparameters.a
SXPARAM_LIB = $(PARAM_LIB)
#-
PARALLEL_LIB = $(LIBDIR)/libparallel.a
SXPARALLEL_LIB = $(PARALLEL_LIB)
#-
MODS1 = stomate_constants.f90 \
stomate_natagritot.f90 \
lpj_constraints.f90 \
lpj_cover.f90 \
lpj_crown.f90 \
lpj_establish.f90 \
lpj_fire.f90 \
lpj_gap.f90 \
lpj_kill.f90 \
lpj_light.f90 \
lpj_pftinout.f90 \
stomate_alloc.f90 \
stomate_data.f90 \
stomate_io.f90 \
stomate_litter.f90 \
stomate_npp.f90 \
stomate_phenology.f90 \
stomate_prescribe.f90 \
stomate_season.f90 \
stomate_soilcarbon.f90 \
stomate_turnover.f90 \
stomate_vmax.f90 \
stomate_assimtemp.f90 \
stomate_deforestation.f90 \
stomate_lpj.f90 \
stomate_resp.f90 \
stomate.f90
OBJSMODS1 = $(MODS1:.f90=.o)
#-
.PRECIOUS : $(MODEL_LIB)
#-
all:
$(M_K) libparameters
$(M_K) libparallel
$(M_K) m_all
@echo stomate is OK
m_all: $(MODEL_LIB)($(OBJSMODS1))
memory:
libparameters:
(cd ../src_parameters; $(M_K) -f Makefile)
libparallel:
(cd ../src_parallel; $(M_K) -f Makefile)
$(MODEL_LIB)(%.o): %.f90
$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
$(A_C) $(MODEL_LIB) $*.o
$(RM) $*.o
config:
$(BINDIR)/Fparser -name STOMATE $(MODS1)
echo 'Configuration of STOMATE done'
clean:
$(RM) $(MODEL_LIB)
$(MODEL_LIB)(stomate.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(MODEL_LIB)(stomate_lpj.o)
$(MODEL_LIB)(stomate_constants.o): \
$(PARAM_LIB)(constantes_veg.o)
$(MODEL_LIB)(stomate_natagritot.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_constraints.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_cover.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_crown.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_establish.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_fire.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_gap.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_kill.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_light.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(lpj_pftinout.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_alloc.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_data.o): \
$(PARAM_LIB)(constantes_co2.o) \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_io.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_litter.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_npp.o): \
$(MODEL_LIB)(stomate_natagritot.o)
$(MODEL_LIB)(stomate_phenology.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_prescribe.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_resp.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_season.o): \
$(MODEL_LIB)(stomate_natagritot.o)
$(MODEL_LIB)(stomate_soilcarbon.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_turnover.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_vmax.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_assimtemp.o): \
$(MODEL_LIB)(stomate_constants.o)
$(MODEL_LIB)(stomate_deforestation.o): \
$(MODEL_LIB)(stomate_data.o)
$(MODEL_LIB)(stomate_lpj.o): \
$(MODEL_LIB)(stomate_natagritot.o) \
$(MODEL_LIB)(lpj_constraints.o) \
$(MODEL_LIB)(lpj_cover.o) \
$(MODEL_LIB)(lpj_crown.o) \
$(MODEL_LIB)(lpj_establish.o) \
$(MODEL_LIB)(lpj_fire.o) \
$(MODEL_LIB)(lpj_gap.o) \
$(MODEL_LIB)(lpj_kill.o) \
$(MODEL_LIB)(lpj_light.o) \
$(MODEL_LIB)(lpj_pftinout.o) \
$(MODEL_LIB)(stomate_alloc.o) \
$(MODEL_LIB)(stomate_data.o) \
$(MODEL_LIB)(stomate_io.o) \
$(MODEL_LIB)(stomate_litter.o) \
$(MODEL_LIB)(stomate_npp.o) \
$(MODEL_LIB)(stomate_phenology.o) \
$(MODEL_LIB)(stomate_prescribe.o) \
$(MODEL_LIB)(stomate_season.o) \
$(MODEL_LIB)(stomate_soilcarbon.o) \
$(MODEL_LIB)(stomate_turnover.o) \
$(MODEL_LIB)(stomate_vmax.o) \
$(MODEL_LIB)(stomate_assimtemp.o) \
$(MODEL_LIB)(stomate_resp.o) \
$(MODEL_LIB)(stomate_deforestation.o)
ORCHIDEE/Makefile~ 0000754 0103600 0005670 00000003460 11164403473 013566 0 ustar acamlmd lmdjus #- $Id: AA_make.ldef,v 1.1 2007/06/21 09:11:58 ssipsl Exp $
#---------------------------------------------------------------------
#-
#-
#- $Id: AA_make.gdef 317 2008-04-14 16:27:52Z mafoipsl $
#-
#- Global definitions for NEC SX8 at Idris
LIB_MPI = MPI1
LIB_MPI_BIS = MPI1
PRISM_ARCH = SX
PRISM_NAME = brodie
FCM_ARCH = SX8_BRODIE
M_K = sxgmake
P_C = sxcpp
P_O = -P -C $(P_P)
F_C = sxmpif90 -c
CPPDIR = $(LIBDIR)/../tmp
F_D =
########En sequentiel########
F_P = -EP -ts $(CPPDIR) -float0 -P stack -Wf "-ptr byte -init stack=nan -init heap=nan" -DNC_DOUBLE -dW -Wf\"-A idbl4\" -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume"
#############################
#######En parallele##########
####-Q- sx8brodie #-P- I4R8 F_P = -EP -DCPP_PARA -ts $(CPPDIR) -float0 -P stack -Wf "-ptr byte -init stack=nan -init heap=nan" -DNC_DOUBLE -dW -Wf\"-A idbl4\" -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume"
#############################
F_O = $(F_D) $(F_P) -I $(MODDIR)
F_L = sxmpif90
M_M = 1
L_X = 0
L_O = $(F_P)
A_C = sxar -rv
A_G = sxar -x
A_X = sxar -rv
C_C = sxcc -c
C_O =
C_L = sxcc
FC_C = gcc -c
FC_O =
FC_L = gcc
#-
NCDF_INC = /SXlocal/pub/netCDF/netCDF-3.6.1/include
NCDF_LIB = -L/SXlocal/pub/netCDF/netCDF-3.6.1/lib -lnetcdf
#-
RM = rm -f
STRIP = strip
SIZE = size
#- $Id: AA_make,v 1.4 2007/09/20 13:32:32 ssipsl Exp $
all : libparameters libparallel liborglob libstomate libsechiba
libparameters :
(cd src_parameters ; $(M_K) -f Makefile)
libparallel :
(cd ../../modeles/ORCHIDEE/src_parallel ; $(M_K) -f Makefile)
liborglob :
(cd src_global ; $(M_K) -f Makefile)
libstomate :
(cd src_stomate ; $(M_K) -f Makefile)
libsechiba :
(cd src_sechiba ; $(M_K) -f Makefile)
config :
(cd src_parameters; $(M_K) -f Makefile config)
(cd src_sechiba; $(M_K) -f Makefile config)
(cd src_stomate; $(M_K) -f Makefile config)
ORCHIDEE/Makefile 0000754 0103600 0005670 00000002461 11164403473 013370 0 ustar acamlmd lmdjus #- $Id: AA_make.ldef,v 1.1 2007/06/21 09:11:58 ssipsl Exp $
#---------------------------------------------------------------------
#-
#-
#- $Id: AA_make.gdef 578 2009-03-13 14:05:38Z bellier $
#-
#- Global definitions for gnu g95 compiler
M_K = gmake
P_C = cpp
P_O = -P -C -traditional $(P_P)
F_C = g95 -c
F_D =
F_P = -i4 -r8
w_w = -O5 -cpp -funroll-all-loops $(F_D) $(F_P) -I$(MODDIR)
#####################################-Q- g95 F_O = $(w_w) -fmod=$(MODDIR) -fno-second-underscore
F_O = $(w_w) -fmod=$(MODDIR)
F_L = g95
M_M = 0
L_X = 0
L_O =
A_C = ar -r
A_G = ar -x
C_C = cc -c
C_O =
C_L = cc
#-
NCDF_INC = /d4/acamlmd/LMDZ4V4/netcdf-3.6.1/include
NCDF_LIB = -L/d4/acamlmd/LMDZ4V4/netcdf-3.6.1/lib -lnetcdf
#-
RM = rm -f
STRIP = strip
SIZE = size
#- $Id: AA_make,v 1.4 2007/09/20 13:32:32 ssipsl Exp $
all : libparameters libparallel liborglob libstomate libsechiba
libparameters :
(cd src_parameters ; $(M_K) -f Makefile)
libparallel :
(cd ../../modeles/ORCHIDEE/src_parallel ; $(M_K) -f Makefile)
liborglob :
(cd src_global ; $(M_K) -f Makefile)
libstomate :
(cd src_stomate ; $(M_K) -f Makefile)
libsechiba :
(cd src_sechiba ; $(M_K) -f Makefile)
config :
(cd src_parameters; $(M_K) -f Makefile config)
(cd src_sechiba; $(M_K) -f Makefile config)
(cd src_stomate; $(M_K) -f Makefile config)