subroutine endrun 160,3
call abort
return
end
#ifdef WRF_USE_CLM
module TridiagonalMod 3
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: TridiagonalMod
!
! !DESCRIPTION:
! Tridiagonal matrix solution
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: Tridiagonal
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: Tridiagonal
!
! !INTERFACE:
subroutine Tridiagonal (lbc, ubc, lbj, ubj, jtop, numf, filter, & 3,1
a, b, c, r, u)
!
! !DESCRIPTION:
! Tridiagonal matrix solution
!
! !USES:
use shr_kind_mod
, only: r8 => shr_kind_r8
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! lbinning and ubing column indices
integer , intent(in) :: lbj, ubj ! lbinning and ubing level indices
integer , intent(in) :: jtop(lbc:ubc) ! top level for each column
integer , intent(in) :: numf ! filter dimension
integer , intent(in) :: filter(1:numf) ! filter
real(r8), intent(in) :: a(lbc:ubc, lbj:ubj) ! "a" left off diagonal of tridiagonal matrix
real(r8), intent(in) :: b(lbc:ubc, lbj:ubj) ! "b" diagonal column for tridiagonal matrix
real(r8), intent(in) :: c(lbc:ubc, lbj:ubj) ! "c" right off diagonal tridiagonal matrix
real(r8), intent(in) :: r(lbc:ubc, lbj:ubj) ! "r" forcing term of tridiagonal matrix
real(r8), intent(inout) :: u(lbc:ubc, lbj:ubj) ! solution
!
! !CALLED FROM:
! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod
! subroutine SoilTemperature in module SoilTemperatureMod
! subroutine SoilWater in module HydrologyMod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 1 July 2003: Mariana Vertenstein; modified for vectorization
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: j,ci,fc !indices
real(r8) :: gam(lbc:ubc,lbj:ubj) !temporary
real(r8) :: bet(lbc:ubc) !temporary
!-----------------------------------------------------------------------
! Solve the matrix
!dir$ concurrent
!cdir nodep
do fc = 1,numf
ci = filter(fc)
bet(ci) = b(ci,jtop(ci))
end do
do j = lbj, ubj
!dir$ prefervector
!dir$ concurrent
!cdir nodep
do fc = 1,numf
ci = filter(fc)
if (j >= jtop(ci)) then
if (j == jtop(ci)) then
u(ci,j) = r(ci,j) / bet(ci)
else
gam(ci,j) = c(ci,j-1) / bet(ci)
bet(ci) = b(ci,j) - a(ci,j) * gam(ci,j)
u(ci,j) = (r(ci,j) - a(ci,j)*u(ci,j-1)) / bet(ci)
end if
end if
end do
end do
!Cray X1 unroll directive used here as work-around for compiler issue 2003/10/20
!dir$ unroll 0
do j = ubj-1,lbj,-1
!dir$ prefervector
!dir$ concurrent
!cdir nodep
do fc = 1,numf
ci = filter(fc)
if (j >= jtop(ci)) then
u(ci,j) = u(ci,j) - gam(ci,j+1) * u(ci,j+1)
end if
end do
end do
end subroutine Tridiagonal
end module TridiagonalMod
module globals 62,1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: globals
!
! !DESCRIPTION:
! Module of global time-related control variables
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
!
! !PUBLIC TYPES:
implicit none
! save
integer :: nstep !time step number
real(r8):: dtime !land model time step (sec)
!ylu add dt may be same as dtime, dtime=get_step_size(), dt=real(get_step_size(),r8)
real(r8):: dt !radiation time step (sec)
integer :: iyear0
integer :: day_per_year ! Get the number of days per year for currrent year
!end add
logical :: is_perpetual = .false. ! true when using perpetual calendar
integer :: year
integer :: month !current month (1 -> 12)
integer :: day !current day (1 -> 31)
integer :: secs ! seconds into current date
real(r8):: calday !calendar day
integer :: yrp1
integer :: monp1 !current month (1 -> 12)
integer :: dayp1 !current day (1 -> 31)
integer :: secp1
real(r8):: caldayp1 !calendar day for next time step
integer :: nbdate
!
!EOP
!-----------------------------------------------------------------------
contains
subroutine globals_mod 1
end subroutine globals_mod
end module globals
module nanMod 8,1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: nanMod
!
! !DESCRIPTION:
! Set parameters for the floating point flags "inf" Infinity
! and "nan" not-a-number. As well as "bigint" the point
! at which integers start to overflow. These values are used
! to initialize arrays with as a way to detect if arrays
! are being used before being set.
! Note that bigint is the largest possible 32-bit integer.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
!
! !PUBLIC TYPES:
implicit none
save
#ifdef __PGI
! quiet nan for portland group compilers
real(r8), parameter :: inf = O'0777600000000000000000'
real(r8), parameter :: nan = O'0777700000000000000000'
integer, parameter :: bigint = O'17777777777'
#elif __GNUC__
real(r8), parameter :: inf = 1.e19
real(r8), parameter :: nan = 1.e21
integer, parameter :: bigint = O'17777777777'
#else
! signaling nan otherwise
real(r8), parameter :: inf = O'0777600000000000000000'
real(r8), parameter :: nan = O'0777610000000000000000'
integer, parameter :: bigint = O'17777777777'
#endif
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein based on cam module created by
! CCM core group
!
!EOP
!-----------------------------------------------------------------------
contains
subroutine nanMod_mod
end subroutine nanMod_mod
end module nanMod
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: mkrank
!
! !INTERFACE:
subroutine mkrank (n, a, miss, iv, num) 1,3
!
! !DESCRIPTION:
! Return indices of largest [num] values in array [a]
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use module_cam_support, only: endrun
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: n !array length
real(r8), intent(in) :: a(0:n) !array to be ranked
integer , intent(in) :: miss !missing data value
integer , intent(in) :: num !number of largest values requested
integer , intent(out):: iv(num) !index to [num] largest values in array [a]
!
! !CALLED FROM:
! subroutine mkpft
! subroutine mksoicol
! subroutine mksoitex
!
! !REVISION HISTORY:
! Author: Gordon Bonan
!
!EOP
!
! !LOCAL VARIABLES:
real(r8) a_max !maximum value in array
integer i !array index
real(r8) delmax !tolerance for finding if larger value
integer m !do loop index
integer k !do loop index
logical exclude !true if data value has already been chosen
!-----------------------------------------------------------------------
delmax = 1.e-06
! Find index of largest non-zero number
iv(1) = miss
a_max = -9999.
do i = 0, n
if (a(i)>0. .and. (a(i)-a_max)>delmax) then
a_max = a(i)
iv(1) = i
end if
end do
! iv(1) = miss indicates no values > 0. this is an error
if (iv(1) == miss) then
write (6,*) 'MKRANK error: iv(1) = missing'
call endrun
end if
! Find indices of the next [num]-1 largest non-zero number.
! iv(m) = miss if there are no more values > 0
do m = 2, num
iv(m) = miss
a_max = -9999.
do i = 0, n
! exclude if data value has already been chosen
exclude = .false.
do k = 1, m-1
if (i == iv(k)) exclude = .true.
end do
! if not already chosen, see if it is the largest of
! the remaining values
if (.not. exclude) then
if (a(i)>0. .and. (a(i)-a_max)>delmax) then
a_max = a(i)
iv(m) = i
end if
end if
end do
end do
return
end subroutine mkrank
module clm_varpar 65,1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: clm_varpar
!
! !DESCRIPTION:
! Module containing CLM parameters
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
!
! !PUBLIC TYPES:
implicit none
save
!
! Define land surface 2-d grid. This sets the model resolution according
! to cpp directives LSMLON and LSMLAT in preproc.h.
!
! integer, parameter :: lsmlon = LSMLON ! maximum number of longitude points on lsm grid
! integer, parameter :: lsmlat = LSMLAT ! number of latitude points on lsm grid
! tcx make it dynamic, read from surface dataset
integer, parameter :: lsmlon = 1 ! maximum number of longitude points on lsm grid
integer, parameter :: lsmlat = 1 ! number of latitude points on lsm grid
! Define number of levels
integer, parameter :: nlevsoi = 10 ! number of soil layers
integer, parameter :: nlevlak = 10 ! number of lake layers
integer, parameter :: nlevsno = 5 ! maximum number of snow layers
!ylu add
integer, parameter :: nlevgrnd = 10 ! 10 ! 10 ! 10 ! 10 ! 10 ! 10 ! 10 ! 10 ! 10 ! 15 ! number of ground layers (includes lower layers that are hydrologically inactive)
integer, parameter :: nlevurb = nlevgrnd! number of urban layers (must equal nlevgrnd right now)
!ylu end
! Define miscellaneous parameters
integer, parameter :: numwat = 5 ! number of water types (soil, ice, 2 lakes, wetland)
! integer, parameter :: npftpar = 32 ! number of pft parameters (in LPJ - DGVM only)
integer, parameter :: numrad = 2 ! number of solar radiation bands: vis, nir
!ylu add
integer, parameter :: numsolar = 2 ! number of solar type bands: direct, diffuse
!ylu end
integer, parameter :: ndst = 4 ! number of dust size classes (BGC only)
integer, parameter :: dst_src_nbr = 3 ! number of size distns in src soil (BGC only)
integer, parameter :: sz_nbr = 200 ! number of sub-grid bins in large bin of dust size distribution (BGC only)
integer, parameter :: nvoc = 5 ! number of voc categories (BGC only)
!Not found in CLM3.5, putting back in from CLM3
!ylu remove
integer, parameter :: numcol = 8 !number of soil color types
! Define parameters for RTM river routing model
integer, parameter :: rtmlon = 720 !number of rtm longitudes
integer, parameter :: rtmlat = 360 !number of rtm latitudes
! Define indices used in surface file read
! maxpatch_pft = max number of vegetated pfts in naturally vegetated landunit
! maxpatch_crop = max number of crop pfts in crop landunit
!ylu add 10/15/10
#if (defined CROP)
integer, parameter :: numpft = 20 ! number of plant types
integer, parameter :: numcft = 6 ! actual # of crops
integer, parameter :: numveg = 16 ! number of veg types (without specific crop)
#else
integer, parameter :: numpft = 16 ! actual # of pfts (without bare)
integer, parameter :: numcft = 2 ! actual # of crops
integer, parameter :: numveg = numpft ! number of veg types (without specific crop)
#endif
integer, parameter :: maxpatch_urb = 1 ! 5 ! the current coupling not include urban.
#ifdef CROP
integer, parameter :: maxpatch_cft = 4 !YL changed from 2 to 4
#else
integer, parameter :: maxpatch_cft = 2
#endif
integer, parameter :: maxpatch_pft = 4
integer, parameter :: npatch_urban = maxpatch_pft + 1
integer, parameter :: npatch_lake = npatch_urban + maxpatch_urb
integer, parameter :: npatch_wet = npatch_lake + 1
integer, parameter :: npatch_glacier = npatch_wet + 1
integer, parameter :: npatch_crop = npatch_glacier + maxpatch_cft
integer, parameter :: maxpatch = npatch_crop
!ylu add
#if (defined CROP)
integer, parameter :: max_pft_per_gcell = numpft+1 + 3 + maxpatch_urb
#else
integer, parameter :: max_pft_per_gcell = numpft+1 + 3 + maxpatch_urb + numcft
#endif
integer, parameter :: max_pft_per_lu = max(numpft+1, numcft, maxpatch_urb)
integer, parameter :: max_pft_per_col = max(numpft+1, numcft, maxpatch_urb)
!Are these constants used? I don't see max_col_per_lunit referenced anywhere.
!ylu remove
! integer, parameter :: max_pft_per_gcell = numpft+1 + 4 + maxpatch_cft
! integer, parameter :: max_pft_per_lu = max(numpft+1, maxpatch_cft)
! integer, parameter :: max_pft_per_col = numpft+1
! integer, parameter :: max_pft_per_col = maxpatch_pft
!#if (defined NOCOMPETE)
! integer, parameter :: max_col_per_lunit = maxpatch_pft
!#else
! integer, parameter :: max_col_per_lunit = 1
!#endif
!Shouldn't this be 1?
! integer, parameter :: max_lunit_per_gcell = 5 !(soil,urban,lake,wetland,glacier)
contains
subroutine clm_varpar_mod 1
end subroutine clm_varpar_mod
!------------------------------------------------------------------------------
end module clm_varpar
module clm_varcon 92,2
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: clm_varcon
!
! !DESCRIPTION:
! Module containing various model constants
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varpar, only : numcol,numrad,nlevlak,&
maxpatch_pft,numpft,nlevgrnd
!
! !PUBLIC TYPES:
implicit none
save
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
integer, private :: i ! loop index
!------------------------------------------------------------------
! Initialize physical constants
!------------------------------------------------------------------
real(r8), parameter :: cday = 86400.0_r8 !sec in calendar day ~ sec
integer, parameter :: idx_Mie_snw_mx = 1471 ! number of effective radius indices used in Mie lookup table [idx]
integer, parameter :: idx_T_max = 11 ! maxiumum temperature index used in aging lookup table [idx]
integer, parameter :: idx_Tgrd_max = 31 ! maxiumum temperature gradient index used in aging lookup table [idx]
integer, parameter :: idx_rhos_max = 8 ! maxiumum snow density index used in aging lookup table [idx]
integer, parameter :: numrad_snw = 5 ! number of spectral bands used in snow model [nbr]
real(r8), parameter :: pie = 3.141592653589793_r8 ! pi
real(r8), parameter :: rpi = 3.141592653589793_r8 ! pi
real(r8), parameter :: grav = 9.80616_r8 !gravity constant [m/s2]
real(r8), parameter :: sb = 5.67e-8_r8 !stefan-boltzmann constant [W/m2/K4]
real(r8), parameter :: vkc = 0.4_r8 !von Karman constant [-]
real(r8), parameter :: rgas = 8314.468_r8 !Universal gas constant ~ J/K/kmole
real(r8), parameter :: rwat = 461.5046_r8 !gas constant for water vapor [J/(kg K)]
real(r8), parameter :: rair = 287.0423_r8 !gas constant for dry air [J/kg/K]
real(r8), parameter :: roverg = 47062.73_r8 !Rw/g constant = (8.3144/0.018)/(9.80616)*1000. mm/K
real(r8), parameter :: cpliq = 4.188e3_r8 !Specific heat of water [J/kg-K]
real(r8), parameter :: cpice = 2.11727e3_r8 !Specific heat of ice [J/kg-K]
real(r8), parameter :: cpair = 1.00464e3_r8 !specific heat of dry air [J/kg/K]
real(r8), parameter :: hvap = 2.501e6_r8 !Latent heat of evap for water [J/kg]
real(r8), parameter :: hfus = 3.337e5_r8 !Latent heat of fusion for ice [J/kg]
real(r8), parameter :: hsub = 2.501e6_r8+3.337e5_r8 !Latent heat of sublimation [J/kg]
real(r8), parameter :: denh2o = 1.000e3_r8 !density of liquid water [kg/m3]
real(r8), parameter :: denice = 0.917e3_r8 !density of ice [kg/m3]
real(r8), parameter :: tkair = 0.023_r8 !thermal conductivity of air [W/m/k]
real(r8), parameter :: tkice = 2.290_r8 !thermal conductivity of ice [W/m/k]
real(r8), parameter :: tkwat = 0.6_r8 !thermal conductivity of water [W/m/k]
real(r8), parameter :: tfrz = 273.16_r8 !freezing temperature [K]
real(r8), parameter :: tcrit = 2.5_r8 !critical temperature to determine rain or snow
real(r8), parameter :: po2 = 0.209_r8 !constant atmospheric partial pressure O2 (mol/mol)
real(r8), parameter :: pco2 = 355.e-06 !constant atmospheric partial pressure CO2 (mol/mol)
real(r8), parameter :: pstd = 101325.0_r8 !standard pressure ~ pascals
real(r8), parameter :: bdsno = 250. !bulk density snow (kg/m**3)
real(r8), parameter :: re = 6.37122e6_r8*0.001 !radius of earth (km)
!CLM4 --ylu
real(r8), public, parameter :: secspday= 86400.0_r8 ! Seconds per day
real(r8), public, parameter :: spval = 1.e36_r8 ! special value for real data
integer , public, parameter :: ispval = -9999 ! special value for int data
real(r8) :: alpha_aero = 1.0_r8 !constant for aerodynamic parameter weighting
real(r8) :: tlsai_crit = 2.0_r8 !critical value of elai+esai for which aerodynamic parameters are maximum
real(r8) :: watmin = 0.01_r8 !minimum soil moisture (mm)
!!
! These are tunable constants from clm2_3
real(r8), parameter :: zlnd = 0.01 !Roughness length for soil [m]
real(r8), parameter :: zsno = 0.0024 !Roughness length for snow [m]
real(r8), parameter :: csoilc = 0.004 !Drag coefficient for soil under canopy [-]
real(r8), parameter :: capr = 0.34 !Tuning factor to turn first layer T into surface T
real(r8), parameter :: cnfac = 0.5 !Crank Nicholson factor between 0 and 1
real(r8), parameter :: ssi = 0.033 !Irreducible water saturation of snow
real(r8), parameter :: wimp = 0.05 !Water impremeable if porosity less than wimp
real(r8), parameter :: pondmx = 10.0 !Ponding depth (mm)
!new from CLM4 ylu add
real(r8) :: pondmx_urban = 1.0_r8 !Ponding depth for urban roof and impervious road (mm)
real(r8) :: o2_molar_const = 0.209_r8 !constant atmospheric O2 molar ratio (mol/mol)
real(r8), parameter :: maxwattabfract = 1.0 !Max water table fraction for landunit that is not wet or ice
!!!!!
!new from CLM4 add by ylu
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
real(r8), parameter :: preind_atm_del13c = -6.0 ! preindustrial value for atmospheric del13C
real(r8), parameter :: preind_atm_ratio = SHR_CONST_PDB + (preind_atm_del13c * SHR_CONST_PDB)/1000.0 ! 13C/12C
real(r8) :: c13ratio = preind_atm_ratio/(1.0+preind_atm_ratio) ! 13C/(12+13)C preind atmosphere
#endif
real(r8), parameter :: ht_efficiency_factor = 0.75_r8 !efficiency factor for urban heating (-)
real(r8), parameter :: ac_efficiency_factor = 0.25_r8 !efficiency factor for urban air conditioning (-)
real(r8) :: ht_wasteheat_factor = 1.0_r8/ht_efficiency_factor !wasteheat factor for urban heating (-)
real(r8) :: ac_wasteheat_factor = 1.0_r8/ac_efficiency_factor !wasteheat factor for urban air conditioning (-)
real(r8) :: wasteheat_limit = 100._r8 !limit on wasteheat (W/m2)
!------------------------------------------------------------------
! Initialize water type constants
!------------------------------------------------------------------
! "water" types
! 1 soil
! 2 land ice (glacier)
! 3 deep lake
! 4 shallow lake
! 5 wetland: swamp, marsh, etc
integer,parameter :: istsoil = 1 !soil "water" type
integer,parameter :: istice = 2 !land ice "water" type
integer,parameter :: istdlak = 3 !deep lake "water" type
integer,parameter :: istslak = 4 !shallow lake "water" type
integer,parameter :: istwet = 5 !wetland "water" type
integer,parameter :: isturb = 6 !urban landunit type
!new from CLM4 add by ylu
#ifdef CROP
integer,parameter :: istcrop = 7 !crop landunit type
#endif
integer,parameter :: icol_roof = 61
integer,parameter :: icol_sunwall = 62
integer,parameter :: icol_shadewall = 63
integer,parameter :: icol_road_imperv = 64
integer,parameter :: icol_road_perv = 65
!Yaqiong Lu mv fndepdyn and fpftdyn from clm_varctl to clm_varcon
logical, public :: set_caerdep_from_file = .true. ! if reading in carbon aerosol deposition from file
logical, public :: set_dustdep_from_file = .true. ! if reading in dust aerosol deposition from file
! Landunit logic
!
logical, public :: create_crop_landunit = .false. ! true => separate crop landunit is not created by default
logical, public :: allocate_all_vegpfts = .false. ! true => allocate memory for all possible vegetated pfts on
! vegetated landunit if at least one pft has nonzero weight
character(len=256), public :: faerdep = ' ' ! aerosol depos
character(len=256), public :: fndepdyn = ' ' ! dynamic nitrogen deposition data file name
character(len=256), public :: fpftdyn = ' ' ! dynamic landuse dataset
! snow and aerosol Mie parameters:
! (arrays declared here, but are set in iniTimeConst)
! (idx_Mie_snw_mx is number of snow radii with defined parameters (i.e. from 30um to 1500um))
! direct-beam weighted ice optical properties
real(r8) :: ss_alb_snw_drc(idx_Mie_snw_mx,numrad_snw)
real(r8) :: asm_prm_snw_drc(idx_Mie_snw_mx,numrad_snw)
real(r8) :: ext_cff_mss_snw_drc(idx_Mie_snw_mx,numrad_snw)
! diffuse radiation weighted ice optical properties
real(r8) :: ss_alb_snw_dfs(idx_Mie_snw_mx,numrad_snw)
real(r8) :: asm_prm_snw_dfs(idx_Mie_snw_mx,numrad_snw)
real(r8) :: ext_cff_mss_snw_dfs(idx_Mie_snw_mx,numrad_snw)
! hydrophiliic BC
real(r8) :: ss_alb_bc1(1,numrad_snw)
real(r8) :: asm_prm_bc1(1,numrad_snw)
real(r8) :: ext_cff_mss_bc1(1,numrad_snw)
! hydrophobic BC
real(r8) :: ss_alb_bc2(1,numrad_snw)
real(r8) :: asm_prm_bc2(1,numrad_snw)
real(r8) :: ext_cff_mss_bc2(1,numrad_snw)
! hydrophobic OC
real(r8) :: ss_alb_oc1(1,numrad_snw)
real(r8) :: asm_prm_oc1(1,numrad_snw)
real(r8) :: ext_cff_mss_oc1(1,numrad_snw)
! hydrophilic OC
real(r8) :: ss_alb_oc2(1,numrad_snw)
real(r8) :: asm_prm_oc2(1,numrad_snw)
real(r8) :: ext_cff_mss_oc2(1,numrad_snw)
! dust species 1:
real(r8) :: ss_alb_dst1(1,numrad_snw)
real(r8) :: asm_prm_dst1(1,numrad_snw)
real(r8) :: ext_cff_mss_dst1(1,numrad_snw)
! dust species 2:
real(r8) :: ss_alb_dst2(1,numrad_snw)
real(r8) :: asm_prm_dst2(1,numrad_snw)
real(r8) :: ext_cff_mss_dst2(1,numrad_snw)
! dust species 3:
real(r8) :: ss_alb_dst3(1,numrad_snw)
real(r8) :: asm_prm_dst3(1,numrad_snw)
real(r8) :: ext_cff_mss_dst3(1,numrad_snw)
! dust species 4:
real(r8) :: ss_alb_dst4(1,numrad_snw)
real(r8) :: asm_prm_dst4(1,numrad_snw)
real(r8) :: ext_cff_mss_dst4(1,numrad_snw)
data(ss_alb_bc1(1,i),i=1,5) / 0.515945305512804, 0.434313626536424, 0.346103765992635,&
0.275522926330555, 0.138576096442815/
data(asm_prm_bc1(1,i),i=1,5) / 0.521517715996158, 0.34457189840306, 0.244048159248401,&
0.188518513380877, 0.103316928297739/
data(ext_cff_mss_bc1(1,i),i=1,5) /25368.6111954733, 12520.3846877849, 7738.643174918, &
5744.35461327268, 3526.76546641382/
data(ss_alb_bc2(1,i),i=1,5) /0.287685315976181, 0.186577277125224, 0.123152237089201, &
0.0883462885905543, 0.0403421562269378/
data(asm_prm_bc2(1,i),i=1,5) /0.350231881885906, 0.211924244128064, 0.146188682542913, &
0.112009439045293, 0.060565694843084/
data(ext_cff_mss_bc2(1,i),i=1,5) / 11398.4540724821, 5922.76076637376, 4039.88947595266,&
3261.62137894056, 2223.60028513459/
data(ss_alb_oc1(1,i),i=1,5) / 0.996738033108225, 0.993951726870337, 0.98995641641622, &
0.986792757460599, 0.950852907010411/
data(asm_prm_oc1(1,i),i=1,5) / 0.771317243327679, 0.745701825432596, 0.721705644101165,&
0.702407207901621, 0.643447858916726/
data(ext_cff_mss_oc1(1,i),i=1,5) / 37773.5353898986, 22112.4459872647, 14719.3405499929,&
10940.4200945733, 5441.11949854352/
data(ss_alb_oc2(1,i),i=1,5) / 0.963132440682188, 0.920560323320592, 0.860191636407288, &
0.813824138511211, 0.744011091642019/
data(asm_prm_oc2(1,i),i=1,5) / 0.618810265705101, 0.57310868510342, 0.537906606684992, &
0.511257182926184, 0.440320412154112/
data(ext_cff_mss_oc2(1,i),i=1,5) /3288.85206279517, 1485.50576885264, 871.90125135612, &
606.005758817735, 247.996083891168/
data(ss_alb_dst1(1,i),i=1,5) /0.97891105715305, 0.994175916042451, 0.993357580762207, &
0.992545751316266, 0.953291550046772/
data(asm_prm_dst1(1,i),i=1,5) /0.690908112844937, 0.717759065247993, 0.671511248292627,&
0.614225462567888, 0.436682950958558/
data(ext_cff_mss_dst1(1,i),i=1,5) /2686.90326329624, 2419.98140297723, 1627.51690973548,&
1138.23252303209, 466.104227277046/
data(ss_alb_dst2(1,i),i=1,5) / 0.943752248802793, 0.984191668599419, 0.989309063917025, &
0.991793946836264, 0.982999590668913/
data(asm_prm_dst2(1,i),i=1,5) /0.699478684452806, 0.651992387581091, 0.695738438913831, &
0.724417176862696, 0.701481090364134/
data(ext_cff_mss_dst2(1,i),i=1,5) /841.089434044834, 987.406197502421, 1183.52284776972, &
1267.30625580205, 993.497508579304/
data(ss_alb_dst3(1,i),i=1,5) /0.904044530646049, 0.964651629694555, 0.968275809551522, &
0.972598419874107, 0.977612418329876/
data(asm_prm_dst3(1,i),i=1,5) /0.785636278417498, 0.749796744517699, 0.683301177698451, &
0.629720518882672, 0.665531587501598/
data(ext_cff_mss_dst3(1,i),i=1,5) /387.85423560755, 419.109723948302, 399.559447343404, &
397.191283865122, 503.14317519429/
data(ss_alb_dst4(1,i),i=1,5) /0.849818195355416, 0.940460325044343, 0.948316305534169, &
0.952841175117807, 0.955379528193802/
data(asm_prm_dst4(1,i),i=1,5) /0.849818195355416, 0.940460325044343, 0.948316305534169, &
0.952841175117807, 0.955379528193802/
data(ext_cff_mss_dst4(1,i),i=1,5) /196.638063554016, 202.877379461792, 208.304425287341, &
204.723737634461, 228.755667038372/
! best-fit parameters for snow aging defined over:
! 11 temperatures from 225 to 273 K
! 31 temperature gradients from 0 to 300 K/m
! 8 snow densities from 0 to 350 kg/m3
! (arrays declared here, but are set in iniTimeConst)
real(r8) :: snowage_tau(idx_T_max,idx_Tgrd_max,idx_rhos_max)
real(r8) :: snowage_kappa(idx_T_max,idx_Tgrd_max,idx_rhos_max)
real(r8) :: snowage_drdt0(idx_T_max,idx_Tgrd_max,idx_rhos_max)
real, dimension(idx_Mie_snw_mx*numrad_snw) :: &
xx_ext_cff_mss_snw_dfs &
,xx_ss_alb_snw_drc &
,xx_asm_prm_snw_drc &
,xx_ext_cff_mss_snw_drc &
,xx_ss_alb_snw_dfs &
,xx_asm_prm_snw_dfs
real, dimension(idx_rhos_max*idx_Tgrd_max*idx_T_max) :: &
xx_snowage_tau &
,xx_snowage_kappa &
,xx_snowage_drdt0
real(r8) :: ndep ! Sum of NOy and NHx deposition (unit: g(N)/m2/year)
data ndep/0.1600056/
real(r8),dimension(1:12) :: bcphidry,bcphodry,bcphiwet,ocphidry,ocphodry,ocphiwet,dstx01wd,dstx01dd,dstx02wd,&
dstx02dd,dstx03wd,dstx03dd,dstx04wd,dstx04dd
!hydrophilic BC wet deposition (unit: kg/m2/s)
data(bcphiwet(i),i=1,12)/2.825279e-13,2.804302e-13,2.806464e-13,2.776603e-13,2.867702e-13,2.840975e-13,&
3.122134e-13,3.540193e-13,3.618796e-13,3.123423e-13,2.668725e-13,2.721869e-13/
!hydrophilic BC dry deposition (unit: kg/m2/s)
data(bcphidry(i),i=1,12)/4.379167e-14,4.140940e-14,3.956216e-14,3.461795e-14,3.561638e-14,3.812630e-14,&
4.509564e-14,5.387520e-14,4.985846e-14,4.057210e-14,3.778306e-14,4.178772e-14/
!hydrophobic BC dry deposition (unit: kg/m2/s)
data(bcphodry(i),i=1,12)/4.192595e-14,3.831034e-14,3.536048e-14,3.209042e-14,3.280311e-14,3.226350e-14,&
3.723765e-14,4.297412e-14,4.106369e-14,3.602615e-14,3.536953e-14,4.030912e-14/
!hydrophilic OC wet deposition (unit: kg/m2/s)
data(ocphiwet(i),i=1,12)/1.162276e-12,1.151254e-12,1.188579e-12,1.186147e-12,1.340542e-12,1.292835e-12,&
1.628738e-12,2.033289e-12,1.964814e-12,1.479005e-12,1.043205e-12,1.068595e-12/
!hydrophilic OC dry deposition (unit: kg/m2/s)
data(ocphidry(i),i=1,12)/2.152982e-13,1.993085e-13,1.982182e-13,1.799778e-13,2.096774e-13,2.264119e-13,&
3.075992e-13,3.972984e-13,3.344011e-13,2.181304e-13,1.666979e-13,1.974062e-13/
!hydrophobic OC dry deposition (unit: kg/m2/s)
data(ocphodry(i),i=1,12)/1.041400e-13,9.450685e-14,9.076748e-14,8.334433e-14,9.459879e-14,9.190213e-14,&
1.252610e-13,1.566317e-13,1.342872e-13,9.783121e-14,8.087127e-14,9.675401e-14/
!DSTX01 wet deposition flux at bottom (unit: kg/m2/s)
data(dstx01wd(i),i=1,12)/3.954503e-12,4.835873e-12,5.138886e-12,4.327863e-12,4.352995e-12,5.446991e-12,&
5.994205e-12,5.140828e-12,3.412828e-12,2.943823e-12,3.267167e-12,3.414306e-12/
!DSTX01 dry deposition flux at bottom (unit: kg/m2/s)
data(dstx01dd(i),i=1,12)/1.926454e-13,2.188806e-13,2.054299e-13,1.452168e-13,1.216905e-13,1.291714e-13,&
1.238305e-13,1.022406e-13,8.948773e-14,1.024716e-13,1.347662e-13,1.688275e-13/
!DSTX02 wet deposition flux at bottom (unit: kg/m2/s)
data(dstx02wd(i),i=1,12)/9.846976e-12,1.203580e-11,1.324912e-11,1.146517e-11,1.176165e-11,1.479383e-11,&
1.656127e-11,1.427957e-11,9.381504e-12,7.933820e-12,8.429268e-12,8.695841e-12/
!DSTX02 dry deposition flux at bottom (unit: kg/m2/s)
data(dstx02dd(i),i=1,12)/2.207384e-12,2.523390e-12,2.099760e-12,1.318037e-12,1.071989e-12,1.305896e-12,&
1.065086e-12,8.545297e-13,7.591564e-13,9.132561e-13,1.344110e-12,1.683045e-12/
!DSTX03 wet deposition flux at bottom (unit: kg/m2/s)
data(dstx03wd(i),i=1,12)/5.689729e-12,7.006299e-12,8.480560e-12,8.957637e-12,1.042770e-11,1.315425e-11,&
1.529579e-11,1.397714e-11,9.306412e-12,7.171395e-12,6.230214e-12,5.392280e-12/
!DSTX03 dry deposition flux at bottom (unit: kg/m2/s)
data(dstx03dd(i),i=1,12)/1.344186e-11,1.552927e-11,1.442798e-11,9.362479e-12,8.622053e-12,1.158499e-11,&
1.128677e-11,8.671572e-12,6.141916e-12,6.720502e-12,8.372052e-12,1.090343e-11/
!DSTX04 wet deposition flux at bottom (unit: kg/m2/s)
data(dstx04wd(i),i=1,12)/5.657587e-12,7.503811e-12,1.001585e-11,1.095202e-11,1.382148e-11,1.919693e-11,&
2.390845e-11,2.121497e-11,1.201019e-11,7.470685e-12,5.650550e-12,4.622456e-12/
!DSTX04 dry deposition flux at bottom (unit: kg/m2/s)
data(dstx04dd(i),i=1,12)/7.075009e-11,8.168510e-11,8.081875e-11,6.024911e-11,6.014012e-11,7.693025e-11,&
7.988822e-11,6.632887e-11,4.771782e-11,4.599348e-11,4.981839e-11,5.885732e-11/
real(r8) :: organic(1:nlevgrnd)!organic matter density at soil levels
!(unit: kg/m3 (assumed carbon content 0.58 gC per gOM)
data(organic(i),i=1,nlevgrnd)/0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/
! The following data are global average for each soil layer
! data(organic(i),i=1,nlevgrnd)/15.36,15.12,13.22,10.80,8.31,6.09,4.37,3.12,0.00,0.00/
real(r8) :: fmax ! maximum fractional saturated area!
! this parameter is for soil hydrology, and it is used in SoilHydrologyMod.F
! this is an ajustable parameter for a specific region -- Jiming Jin
data fmax/0.366/
real(r8) :: efisop(1:6)! emission factors for isoprene (ug/m2/h1)
data(efisop(i), i=1,6)/3025.2,& ! broadleaf trees
554.6 ,& ! fineleaf evergreen
131.0 ,& ! fineleaf deciduous
2629.5,& ! shrubs
164.3 ,& ! grass
14.1/ ! crops
!------------------------------------------------------------------
! Initialize miscellaneous radiation constants
!------------------------------------------------------------------
integer,parameter :: num_landcover_types = 24 !24 (USGS)
! saturated soil albedos for 8 color classes: 1=vis, 2=nir
real(r8) :: albsat(numcol,numrad) !wet soil albedo by color class and waveband
data(albsat(i,1),i=1,8)/0.12,0.11,0.10,0.09,0.08,0.07,0.06,0.05/
data(albsat(i,2),i=1,8)/0.24,0.22,0.20,0.18,0.16,0.14,0.12,0.10/
! dry soil albedos for 8 color classes: 1=vis, 2=nir
real(r8) :: albdry(numcol,numrad) !dry soil albedo by color class and waveband
data(albdry(i,1),i=1,8)/0.24,0.22,0.20,0.18,0.16,0.14,0.12,0.10/
data(albdry(i,2),i=1,8)/0.48,0.44,0.40,0.36,0.32,0.28,0.24,0.20/
! albedo land ice: 1=vis, 2=nir
real(r8) :: albice(numrad) !albedo land ice by waveband
data (albice(i),i=1,numrad) /0.80, 0.55/
! albedo frozen lakes: 1=vis, 2=nir
real(r8) :: alblak(numrad) !albedo frozen lakes by waveband
data (alblak(i),i=1,numrad) /0.60, 0.40/
! omega,betad,betai for snow
real(r8),parameter :: betads = 0.5 !two-stream parameter betad for snow
real(r8),parameter :: betais = 0.5 !two-stream parameter betai for snow
real(r8) :: omegas(numrad) !two-stream parameter omega for snow by band
data (omegas(i),i=1,numrad) /0.8, 0.4/
!------------------------------------------------------------------
! Soil and Lake depths are constants for now
! The values for the following arrays are set in routine iniTimeConst
!------------------------------------------------------------------
real(r8) :: zlak(1:nlevlak) !lake z (layers)
real(r8) :: dzlak(1:nlevlak) !lake dz (thickness)
real(r8) :: zsoi(1:nlevgrnd) !soil z (layers)
real(r8) :: dzsoi(1:nlevgrnd) !soil dz (thickness)
real(r8) :: zisoi(0:nlevgrnd) !soil zi (interfaces)
real(r8) :: sand(19) ! percent sand
real(r8) :: clay(19) ! percent clay
integer :: soic(19)
integer :: plant(24,maxpatch_pft)
real(r8) :: cover(24,maxpatch_pft)
data(sand(i), i=1,19)/92.,80.,66.,20.,5.,43.,60.,&
10.,32.,51., 6.,22.,39.7,0.,100.,54.,17.,100.,92./
data(clay(i), i=1,19)/ 3., 5.,10.,15.,5.,18.,27.,&
33.,33.,41.,47.,58.,14.7,0., 0., 8.5,54., 0., 3./
data(soic(i), i=1,19)/1,2,2,3,3,4,5,5,6,7,7,8,8,0,&
1,1,4,7,1/
! soil type from MM5
! (1) sand
! (2) loamy-sand
! (3) sandy-loam
! (4) silt-loam
! (5) silt
! (6) loam
! (7) sandy-clay-loam
! (8) silty-clay-loam
! (9) clay-loam
! (10) sandy-clay
! (11) silty-clay
! (12) clay
! (13) organic-material,
! (14) water
! (15) bedrock
! (16) other(land-ice)
! (17) playa
! (18) lava
! (19) white-sand
!----------------------------------------------------------------------------
data (plant(i,1),i=1,24) / 0, 15, 15, 15, 15, 15, &
14, 9, 9, 14, 7, 3, &
4, 1, 1, 0, 0, 4, &
11, 11, 2, 11, 11, 0/
data (cover(i,1),i=1,24) /100., 85., 85., 85., 50., 40., &
60., 80., 50., 70., 75., 50., &
95., 75., 37., 100., 100., 80., &
10., 30., 13., 20., 10., 100./
data (plant(i,2),i=1,24) / 0, 0, 0, 0, 14, 3, &
13, 0, 14, 6, 0, 0, &
0, 0, 7, 0, 0, 0, &
0, 12, 3, 12, 12, 0/
data (cover(i,2),i=1,24) / 0., 15., 15., 15., 35., 30., &
20., 20., 30., 30., 25., 50., &
5., 25., 37., 0., 0., 20., &
90., 30., 13., 20., 10., 0./
data (plant(i,3),i=1,24) / 0, 0, 0, 0, 0, 0, &
0, 0, 0, 0, 0, 0, &
0, 0, 0, 0, 0, 0, &
0, 0, 10, 0, 0, 0/
data (cover(i,3),i=1,24) / 0., 0., 0., 0., 15., 30., &
20., 0., 20., 0., 0., 0., &
0., 0., 26., 0., 0., 0., &
0., 40., 24., 60., 80., 0./
data (plant(i,4),i=1,24) / 0, 0, 0, 0, 0, 0, &
0, 0, 0, 0, 0, 0, &
0, 0, 0, 0, 0, 0, &
0, 0, 0, 0, 0, 0/
data (cover(i,4),i=1,24) / 0., 0., 0., 0., 0., 0., &
0., 0., 0., 0., 0., 0., &
0., 0., 0., 0., 0., 0., &
0., 0., 50., 0., 0., 0./
!-----------------------------------------------------------------------
!USGS vegetation 24 categories
!
!Urban and Built-Up Land 1
!Dryland Cropland and Pasture 2
!Irrigated Cropland and Pasture 3
!Mixed Dryland/Irrg. C.P. 4
!Cropland/Grassland Mosaic 5
!Cropland/Woodland Mosaic 6
!Grassland 7
!Shrubland 8
!Mixed Shrubland/Grassland 9
!Savanna 10
!Deciduous Broadleaf Forest 11
!Deciduous Needleleaf Forest 12
!Evergreen Broadleaf Forest 13
!Evergreen Needleleaf Forest 14
!Mixed Forest 15
!Water Bodies 16
!Herbaceous Wetland 17
!Wooded Wetland 18
!Barren or Sparsely Vegetated 19
!Herbaceous Tundra 20
!Wooded Tundra 21
!Mixed Tundra 22
!Bare Ground Tundra 23
!Snow or Ice 24
!-----------------------------------------------------------------------
real(r8):: lai(numpft,12),sai(numpft,12)
real(r8):: hvt(16),hvb(16)
data (hvt(i),i=1,16) /17.0,17.0,14.0,35.0,35.0,18.0,20.0,20.0,&
0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5/
data (hvb(i),i=1,16) /8.50, 8.50,7.00,1.00,1.00,10.00,11.50,11.50,&
0.10,0.10,0.10,0.01,0.10,0.01,0.01,0.01/
data (lai(1,i),i=1,12) &
/4.1,4.2,4.6,4.8,4.9,5.0,4.8,4.7,4.6,4.2,4.0,4.0/
data (lai(2,i),i=1,12) &
/4.1,4.2,4.6,4.8,4.9,5.0,4.8,4.7,4.6,4.2,4.0,4.0/
data (lai(3,i),i=1,12) &
/0.0,0.0,0.0,0.6,1.2,2.0,2.6,1.7,1.0,0.5,0.2,0.0/
data (lai(4,i),i=1,12) &
/4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5/
data (lai(5,i),i=1,12) &
/4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5,4.5/
data (lai(6,i),i=1,12) &
/0.8,0.7,0.4,0.5,0.5,0.7,1.7,3.0,2.5,1.6,1.0,1.0/
data (lai(7,i),i=1,12) &
/0.0,0.0,0.3,1.2,3.0,4.7,4.5,3.4,1.2,0.3,0.0,0.0/
data (lai(8,i),i=1,12) &
/0.0,0.0,0.3,1.2,3.0,4.7,4.5,3.4,1.2,0.3,0.0,0.0/
data (lai(9,i),i=1,12) &
/1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0/
data (lai(10,i),i=1,12) &
/0.9,0.8,0.2,0.2,0.0,0.0,0.0,0.2,0.4,0.5,0.6,0.8/
data (lai(11,i),i=1,12) &
/0.0,0.0,0.0,0.0,0.0,0.2,1.4,1.2,0.0,0.0,0.0,0.0/
data (lai(12,i),i=1,12) &
/0.4,0.5,0.6,0.7,1.2,3.0,3.5,1.5,0.7,0.6,0.5,0.4/
data (lai(13,i),i=1,12) &
/0.0,0.0,0.0,0.0,0.0,0.2,1.4,1.2,0.0,0.0,0.0,0.0/
data (lai(14,i),i=1,12) &
/0.4,0.5,0.6,0.7,1.2,3.0,3.5,1.5,0.7,0.6,0.5,0.4/
data (lai(15,i),i=1,12) &
/0.0,0.0,0.0,0.0,1.0,2.0,3.0,3.0,1.5,0.0,0.0,0.0/
data (lai(16,i),i=1,12) &
/0.0,0.0,0.0,0.0,1.0,2.0,3.0,3.0,1.5,0.0,0.0,0.0/
!-----------------------------------------------------------------------
data (sai(1,i),i=1,12) &
/0.4,0.5,0.4,0.3,0.4,0.5,0.5,0.6,0.6,0.7,0.6,0.5/
data (sai(2,i),i=1,12) &
/0.4,0.5,0.4,0.3,0.4,0.5,0.5,0.6,0.6,0.7,0.6,0.5/
data (sai(3,i),i=1,12) &
/0.3,0.3,0.3,0.4,0.4,0.4,1.7,1.2,1.0,0.8,0.6,0.5/
data (sai(4,i),i=1,12) &
/0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5/
data (sai(5,i),i=1,12) &
/0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5/
data (sai(6,i),i=1,12) &
/0.4,0.3,0.5,0.3,0.3,0.3,0.3,0.7,0.7,1.1,0.9,0.2/
data (sai(7,i),i=1,12) &
/0.4,0.4,0.4,0.4,0.5,0.4,0.9,1.4,2.6,1.4,0.6,0.4/
data (sai(8,i),i=1,12) &
/0.4,0.4,0.4,0.4,0.5,0.4,0.9,1.4,2.6,1.4,0.6,0.4/
data (sai(9,i),i=1,12) &
/0.3,0.3,0.3,0.3,0.3,0.3,0.3,0.3,0.3,0.3,0.3,0.3/
data (sai(10,i),i=1,12) &
/0.1,0.2,0.6,0.1,0.6,0.0,0.1,0.1,0.1,0.1,0.1,0.1/
data (sai(11,i),i=1,12) &
/0.1,0.1,0.1,0.1,0.1,0.1,0.1,0.5,1.4,0.1,0.1,0.1/
data (sai(12,i),i=1,12) &
/0.3,0.3,0.3,0.3,0.3,0.4,0.8,2.3,1.1,0.4,0.4,0.4/
data (sai(13,i),i=1,12) &
/0.1,0.1,0.1,0.1,0.1,0.1,0.1,0.5,1.4,0.1,0.1,0.1/
data (sai(14,i),i=1,12) &
/0.3,0.3,0.3,0.3,0.3,0.4,0.8,2.3,1.1,0.4,0.4,0.4/
data (sai(15,i),i=1,12) &
/0.0,0.0,0.0,0.0,1.0,2.0,3.0,3.0,1.5,0.0,0.0,0.0/
data (sai(16,i),i=1,12) &
/0.0,0.0,0.0,0.0,1.0,2.0,3.0,3.0,1.5,0.0,0.0,0.0/
!----------------------------------------------------------------------------
character(len=40) pftname(0:numpft)
real(r8) dleaf(0:numpft) !characteristic leaf dimension (m)
real(r8) c3psn(0:numpft) !photosynthetic pathway: 0. = c4, 1. = c3
real(r8) vcmx25(0:numpft) !max rate of carboxylation at 25C (umol CO2/m**2/s)
real(r8) mp(0:numpft) !slope of conductance-to-photosynthesis relationship
real(r8) qe25(0:numpft) !quantum efficiency at 25C (umol CO2 / umol photon)
real(r8) xl(0:numpft) !leaf/stem orientation index
real(r8) rhol(0:numpft,numrad) !leaf reflectance: 1=vis, 2=nir
real(r8) rhos(0:numpft,numrad) !stem reflectance: 1=vis, 2=nir
real(r8) taul(0:numpft,numrad) !leaf transmittance: 1=vis, 2=nir
real(r8) taus(0:numpft,numrad) !stem transmittance: 1=vis, 2=nir
real(r8) z0mr(0:numpft) !ratio of momentum roughness length to canopy top height (-)
real(r8) displar(0:numpft) !ratio of displacement height to canopy top height (-)
real(r8) roota_par(0:numpft) !CLM rooting distribution parameter [1/m]
real(r8) rootb_par(0:numpft) !CLM rooting distribution parameter [1/m]
data (pftname(i),i=1,16)/'needleleaf_evergreen_temperate_tree',&
'needleleaf_evergreen_boreal_tree' ,&
'needleleaf_deciduous_boreal_tree' ,&
'broadleaf_evergreen_tropical_tree' ,&
'broadleaf_evergreen_temperate_tree' ,&
'broadleaf_deciduous_tropical_tree' ,&
'broadleaf_deciduous_temperate_tree' ,&
'broadleaf_deciduous_boreal_tree' ,&
'broadleaf_evergreen_shrub' ,&
'broadleaf_deciduous_temperate_shrub',&
'broadleaf_deciduous_boreal_shrub' ,&
'c3_arctic_grass' ,&
'c3_non-arctic_grass' ,&
'c4_grass' ,&
'corn' ,&
'wheat'/
data (z0mr(i),i=1,16)/ 0.055, 0.055, 0.055, 0.075, 0.075, &
0.055,0.055, 0.055, 0.120, 0.120, 0.120, 0.120, 0.120,&
0.120, 0.120, 0.120/
data (displar(i),i=1,16)/ 0.67, 0.67, 0.67, 0.67, 0.67, &
0.67, 0.67, 0.67, 0.68, 0.68, 0.68, 0.68, 0.68, &
0.68, 0.68, 0.68/
data (dleaf(i),i=1,16)/ 0.04, 0.04, 0.04, 0.04, 0.04,&
0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04,&
0.04, 0.04, 0.04/
data (c3psn(i),i=1,16)/1.0,1.0,1.0,1.0,1.0,1.0,1.0,1.0,&
1.0,1.0,1.0,1.0,1.0,0.0,1.0,1.0/
data (vcmx25(i),i=1,16)/51.0,43.0,43.0,75.0,69.0,40.0,&
51.0,51.0,17.0,17.0,33.0,43.0,43.0,24.0,50.0,50.0/
data (mp(i),i=1,16)/6.0,6.0,6.0,9.0,9.0,9.0,9.0,9.0,&
9.0,9.0,9.0,9.0,9.0,5.0,9.0,9.0/
data (qe25(i),i=1,16)/ 0.06, 0.06, 0.06, 0.06, 0.06,&
0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06,&
0.04, 0.06, 0.06/
data (rhol(i,1),i=1,16)/ 0.07, 0.07, 0.07, 0.10, 0.10,&
0.10, 0.10, 0.10, 0.07, 0.10, 0.10, 0.11, 0.11,&
0.11, 0.11, 0.11/
data (rhol(i,2),i=1,16)/ 0.35, 0.35, 0.35, 0.45, 0.45,&
0.45, 0.45, 0.45, 0.35, 0.45, 0.45, 0.58, 0.58, &
0.58, 0.58, 0.58/
data (rhos(i,1),i=1,16) /0.16, 0.16, 0.16, 0.16, 0.16,&
0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.36,&
0.36, 0.36, 0.36/
data (rhos(i,2),i=1,16)/ 0.39, 0.39, 0.39, 0.39, 0.39,&
0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.58, &
0.58, 0.58, 0.58/
data (taul(i,1),i=1,16)/ 0.05, 0.05, 0.05, 0.05, 0.05,&
0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.07,&
0.07, 0.07, 0.07/
data (taul(i,2),i=1,16)/ 0.10, 0.10, 0.10, 0.25, 0.25,&
0.25, 0.25, 0.25, 0.10, 0.25, 0.25, 0.25, 0.25, &
0.25, 0.25, 0.25/
data (taus(i,1),i=1,16)/0.001, 0.001, 0.001, 0.001,&
0.001,0.001, 0.001, 0.001, 0.001, 0.001, 0.001,&
0.220, 0.220, 0.220, 0.220, 0.220/
data (taus(i,2),i=1,16)/ 0.001, 0.001, 0.001, 0.001,&
0.001, 0.001, 0.001, 0.001, 0.001, 0.001, &
0.001, 0.380, 0.380, 0.380, 0.380, 0.380/
data (xl(i),i=1,16)/0.01,0.01,0.01,0.10,0.10, 0.01,&
0.25, 0.25, 0.01, 0.25, 0.25, -0.30, -0.30,&
-0.30, -0.30, -0.30/
data (roota_par(i),i=1,16)/ 7.0, 7.0, 7.0, 7.0,&
7.0, 6.0, 6.0, 6.0, 7.0, 7.0, 7.0, 11.0, &
11.0, 11.0, 6.0, 6.0/
data (rootb_par(i),i=1,16)/ 2.0, 2.0, 2.0, &
1.0, 1.0, 2.0, 2.0, 2.0, 1.5, 1.5, 1.5, &
2.0, 2.0, 2.0, 3.0, 3.0/
contains
subroutine var_par 1
end subroutine var_par
end module clm_varcon
module clm_varsur 7,3
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: clm_varsur
!
! !DESCRIPTION:
! Module containing 2-d surface boundary data information
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varpar, only : maxpatch,lsmlon, lsmlat, nlevsoi
use module_cam_support, only: endrun
!
! !PUBLIC TYPES:
implicit none
save
!
! land model grid
!
!ylu add
! real(r8),allocatable :: pctspec(:) ! percent of spec lunits wrt gcell
!ylu end
integer :: numlon(lsmlat) !longitude points for each latitude strip
real(r8):: latixy(1) !latitude of grid cell (degrees)
real(r8):: longxy(1) !longitude of grid cell (degrees)
real(r8):: area(1) !grid cell area (km**2)
real(r8):: landarea !total land area for all gridcells (km^2)
real(r8):: lats(lsmlat+1) !grid cell latitude, southern edge (degrees)
real(r8):: lonw(lsmlon+1,lsmlat) !grid cell longitude, western edge (degrees)
real(r8):: lsmedge(4) !North,East,South,West edges of grid (deg)
logical :: pole_points !true => grid has pole points
logical :: fullgrid = .true. !true => no grid reduction towards poles
logical :: offline_rdgrid !true => read offline grid rather than creating it
!
! fractional land and mask
!
! integer landmask(smlon,lsmlat) !land mask: 1 = land. 0 = ocean
! real(r8) landfrac(lsmlon,lsmlat) !fractional land
!
! surface boundary data
!
real(r8), allocatable :: gti(:)
integer , allocatable :: soic2d(:) !soil color
real(r8) , allocatable :: efisop2d(:,:)
real(r8), allocatable :: sand3d(:,:) !soil texture: percent sand
real(r8), allocatable :: clay3d(:,:) !soil texture: percent clay
real(r8), allocatable :: organic3d(:,:) !organic matter: kg/m3
real(r8), allocatable :: pctgla(:) !percent of grid cell that is glacier
real(r8), allocatable :: pctlak(:) !percent of grid cell that is lake
real(r8), allocatable :: pctwet(:) !percent of grid cell that is wetland
real(r8), allocatable :: pcturb(:) !percent of grid cell that is urbanized
integer , allocatable :: vegxy(:,:) ! vegetation type
real(r8), allocatable,target :: wtxy(:,:) ! subgrid weights
!
! !PUBLIC MEMBER FUNCTIONS:
public :: varsur_alloc !allocates 2d surface data needed for initialization
public :: varsur_dealloc !deallocates 2d surface data needed for initialization
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: varsur_alloc
!
! !INTERFACE:
subroutine varsur_alloc 1,2
!
! !DESCRIPTION:
! Allocate dynamic memory for module variables
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!
! LOCAL VARIABLES:
integer :: ier,begg,endg !error code
begg=1
endg=1
!-----------------------------------------------------------------------
allocate (vegxy(1,maxpatch), &
wtxy(1,maxpatch), &
stat=ier)
if (ier /= 0) then
write(6,*)'initialize allocation error'
call endrun()
endif
allocate (soic2d(begg:endg), &
gti(begg:endg), &
efisop2d(1:6,begg:endg),&
sand3d(begg:endg,nlevsoi), &
clay3d(begg:endg,nlevsoi), &
organic3d(begg:endg,nlevsoi), &
pctgla(begg:endg), &
pctlak(begg:endg), &
pctwet(begg:endg), &
pcturb(begg:endg), stat=ier)
if (ier /= 0) then
write(6,*)'varsur_alloc(): allocation error'
call endrun()
endif
end subroutine varsur_alloc
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: varsur_dealloc
!
! !INTERFACE:
subroutine varsur_dealloc 1
!
! !DESCRIPTION:
! Deallocate dynamic memory for module variables
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
deallocate (soic2d, &
gti, &
efisop2d,&
sand3d, &
clay3d, &
organic3d,&
pctgla, &
pctlak, &
pctwet, &
pcturb, &
wtxy, &
vegxy)
end subroutine varsur_dealloc
end module clm_varsur
!#include <misc.h>
!#include <preproc.h>
module clmtype 91,1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: clmtype
!
! !DESCRIPTION:
! Define derived type hierarchy. Includes declaration of
! the clm derived type and 1d mapping arrays.
!
! --------------------------------------------------------
! gridcell types can have values of
! --------------------------------------------------------
! 1 => default
! --------------------------------------------------------
! landunits types can have values of (see clm_varcon.F90)
! --------------------------------------------------------
! 1 => (istsoil) soil (vegetated or bare soil landunit)
! 2 => (istice) land ice
! 3 => (istdlak) deep lake
! 4 => (istslak) shall lake (not currently implemented)
! 5 => (istwet) wetland
! 6 => (isturb) urban
! 7 => (istcrop) crop (only for CROP configuration)
! --------------------------------------------------------
! column types can have values of
! --------------------------------------------------------
! 1 => (istsoil) soil (vegetated or bare soil)
! 2 => (istice) land ice
! 3 => (istdlak) deep lake
! 4 => (istslak) shallow lake
! 5 => (istwet) wetland
! 61 => (icol_roof) urban roof
! 62 => (icol_sunwall) urban sunwall
! 63 => (icol_shadewall) urban shadewall
! 64 => (icol_road_imperv) urban impervious road
! 65 => (icol_road_perv) urban pervious road
! --------------------------------------------------------
! pft types can have values of
! --------------------------------------------------------
! 0 => not vegetated
! 1 => needleleaf evergreen temperate tree
! 2 => needleleaf evergreen boreal tree
! 3 => needleleaf deciduous boreal tree
! 4 => broadleaf evergreen tropical tree
! 5 => broadleaf evergreen temperate tree
! 6 => broadleaf deciduous tropical tree
! 7 => broadleaf deciduous temperate tree
! 8 => broadleaf deciduous boreal tree
! 9 => broadleaf evergreen shrub
! 10 => broadleaf deciduous temperate shrub
! 11 => broadleaf deciduous boreal shrub
! 12 => c3 arctic grass
! 13 => c3 non-arctic grass
! 14 => c4 grass
! 15 => corn
! 16 => wheat
! --------------------------------------------------------
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
!
! !PUBLIC TYPES:
implicit none
!
! !REVISION HISTORY:
! Created by Peter Thornton and Mariana Vertenstein
!
!*******************************************************************************
!----------------------------------------------------
! Begin definition of conservation check structures
!----------------------------------------------------
! energy balance structure
!----------------------------------------------------
type, public :: energy_balance_type
real(r8), pointer :: errsoi(:) !soil/lake energy conservation error (W/m**2)
real(r8), pointer :: errseb(:) !surface energy conservation error (W/m**2)
real(r8), pointer :: errsol(:) !solar radiation conservation error (W/m**2)
real(r8), pointer :: errlon(:) !longwave radiation conservation error (W/m**2)
end type energy_balance_type
!----------------------------------------------------
! water balance structure
!----------------------------------------------------
type, public :: water_balance_type
real(r8), pointer :: begwb(:) !water mass begining of the time step
real(r8), pointer :: endwb(:) !water mass end of the time step
real(r8), pointer :: errh2o(:) !water conservation error (mm H2O)
end type water_balance_type
!----------------------------------------------------
! carbon balance structure
!----------------------------------------------------
type, public :: carbon_balance_type
real(r8), pointer :: begcb(:) !carbon mass, beginning of time step (gC/m**2)
real(r8), pointer :: endcb(:) !carbon mass, end of time step (gC/m**2)
real(r8), pointer :: errcb(:) !carbon balance error for the timestep (gC/m**2)
end type carbon_balance_type
!----------------------------------------------------
! nitrogen balance structure
!----------------------------------------------------
type, public :: nitrogen_balance_type
real(r8), pointer :: begnb(:) !nitrogen mass, beginning of time step (gN/m**2)
real(r8), pointer :: endnb(:) !nitrogen mass, end of time step (gN/m**2)
real(r8), pointer :: errnb(:) !nitrogen balance error for the timestep (gN/m**2)
end type nitrogen_balance_type
!----------------------------------------------------
! End definition of conservation check structures
!----------------------------------------------------
!*******************************************************************************
!*******************************************************************************
!----------------------------------------------------
! Begin definition of structures defined at the pft_type level
!----------------------------------------------------
! pft physical state variables structure
!----------------------------------------------------
type, public :: pft_pstate_type
integer , pointer :: frac_veg_nosno(:) !fraction of vegetation not covered by snow (0 OR 1) [-]
integer , pointer :: frac_veg_nosno_alb(:) !fraction of vegetation not covered by snow (0 OR 1) [-]
real(r8), pointer :: emv(:) !vegetation emissivity
real(r8), pointer :: z0mv(:) !roughness length over vegetation, momentum [m]
real(r8), pointer :: z0hv(:) !roughness length over vegetation, sensible heat [m]
real(r8), pointer :: z0qv(:) !roughness length over vegetation, latent heat [m]
real(r8), pointer :: rootfr(:,:) !fraction of roots in each soil layer (nlevgrnd)
real(r8), pointer :: rootr(:,:) !effective fraction of roots in each soil layer (nlevgrnd)
real(r8), pointer :: rresis(:,:) !root resistance by layer (0-1) (nlevgrnd)
real(r8), pointer :: dewmx(:) !Maximum allowed dew [mm]
real(r8), pointer :: rssun(:) !sunlit stomatal resistance (s/m)
real(r8), pointer :: rssha(:) !shaded stomatal resistance (s/m)
real(r8), pointer :: laisun(:) !sunlit projected leaf area index
real(r8), pointer :: laisha(:) !shaded projected leaf area index
real(r8), pointer :: btran(:) !transpiration wetness factor (0 to 1)
real(r8), pointer :: fsun(:) !sunlit fraction of canopy
real(r8), pointer :: tlai(:) !one-sided leaf area index, no burying by snow
real(r8), pointer :: tsai(:) !one-sided stem area index, no burying by snow
real(r8), pointer :: elai(:) !one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) !one-sided stem area index with burying by snow
real(r8), pointer :: fwet(:) !fraction of canopy that is wet (0 to 1)
real(r8), pointer :: fdry(:) !fraction of foliage that is green and dry [-] (new)
real(r8), pointer :: dt_veg(:) !change in t_veg, last iteration (Kelvin)
real(r8), pointer :: htop(:) !canopy top (m)
real(r8), pointer :: hbot(:) !canopy bottom (m)
real(r8), pointer :: z0m(:) !momentum roughness length (m)
real(r8), pointer :: displa(:) !displacement height (m)
real(r8), pointer :: albd(:,:) !surface albedo (direct) (numrad)
real(r8), pointer :: albi(:,:) !surface albedo (indirect) (numrad)
real(r8), pointer :: fabd(:,:) !flux absorbed by veg per unit direct flux (numrad)
real(r8), pointer :: fabi(:,:) !flux absorbed by veg per unit diffuse flux (numrad)
real(r8), pointer :: ftdd(:,:) !down direct flux below veg per unit dir flx (numrad)
real(r8), pointer :: ftid(:,:) !down diffuse flux below veg per unit dir flx (numrad)
real(r8), pointer :: ftii(:,:) !down diffuse flux below veg per unit dif flx (numrad)
real(r8), pointer :: u10(:) !10-m wind (m/s) (for dust model)
real(r8), pointer :: ram1(:) !aerodynamical resistance (s/m)
real(r8), pointer :: fv(:) !friction velocity (m/s) (for dust model)
real(r8), pointer :: forc_hgt_u_pft(:) !wind forcing height (10m+z0m+d) (m)
real(r8), pointer :: forc_hgt_t_pft(:) !temperature forcing height (10m+z0m+d) (m)
real(r8), pointer :: forc_hgt_q_pft(:) !specific humidity forcing height (10m+z0m+d) (m)
#if (defined CROP)
real(r8), pointer :: hdidx(:)
real(r8), pointer :: cumvd(:)
real(r8), pointer :: htmx(:) ! max hgt attained by a crop during yr
real(r8), pointer :: vf(:) ! vernalization factor for wheat
real(r8), pointer :: gddmaturity(:)
real(r8), pointer :: gdd0(:)
real(r8), pointer :: gdd8(:)
real(r8), pointer :: gdd10(:)
real(r8), pointer :: gdd020(:)
real(r8), pointer :: gdd820(:)
real(r8), pointer :: gdd1020(:)
real(r8), pointer :: gddplant(:) ! accum gdd past planting date for crop
real(r8), pointer :: gddtsoi(:)
real(r8), pointer :: huileaf(:)
real(r8), pointer :: huigrain(:)
real(r8), pointer :: a10tmin(:)
real(r8), pointer :: a5tmin(:)
real(r8), pointer :: aleafi(:)
real(r8), pointer :: astemi(:)
real(r8), pointer :: aleaf(:)
real(r8), pointer :: astem(:)
integer , pointer :: croplive(:)
integer , pointer :: cropplant(:) ! this and next could be 2-D to
integer , pointer :: harvdate(:) ! facilitate crop rotation
integer , pointer :: idop(:)
integer , pointer :: peaklai(:) ! 1: max allowed lai; 0: not at max
#endif
real(r8), pointer :: vds(:) !deposition velocity term (m/s) (for dry dep SO4, NH4NO3)
! new variables for CN code
real(r8), pointer :: slasun(:) !specific leaf area for sunlit canopy, projected area basis (m^2/gC)
real(r8), pointer :: slasha(:) !specific leaf area for shaded canopy, projected area basis (m^2/gC)
real(r8), pointer :: lncsun(:) !leaf N concentration per unit projected LAI (gN leaf/m^2)
real(r8), pointer :: lncsha(:) !leaf N concentration per unit projected LAI (gN leaf/m^2)
real(r8), pointer :: vcmxsun(:) !sunlit leaf Vcmax (umolCO2/m^2/s)
real(r8), pointer :: vcmxsha(:) !shaded leaf Vcmax (umolCO2/m^2/s)
real(r8), pointer :: gdir(:) !leaf projection in solar direction (0 to 1)
real(r8), pointer :: omega(:,:) !fraction of intercepted radiation that is scattered (0 to 1)
real(r8), pointer :: eff_kid(:,:) !effective extinction coefficient for indirect from direct
real(r8), pointer :: eff_kii(:,:) !effective extinction coefficient for indirect from indirect
real(r8), pointer :: sun_faid(:,:) !fraction sun canopy absorbed indirect from direct
real(r8), pointer :: sun_faii(:,:) !fraction sun canopy absorbed indirect from indirect
real(r8), pointer :: sha_faid(:,:) !fraction shade canopy absorbed indirect from direct
real(r8), pointer :: sha_faii(:,:) !fraction shade canopy absorbed indirect from indirect
! 4/14/05: PET
! Adding isotope code
real(r8), pointer :: cisun(:) !sunlit intracellular CO2 (Pa)
real(r8), pointer :: cisha(:) !shaded intracellular CO2 (Pa)
#if (defined C13)
real(r8), pointer :: alphapsnsun(:) !sunlit 13c fractionation ([])
real(r8), pointer :: alphapsnsha(:) !shaded 13c fractionation ([])
#endif
! heald: added outside of CASA definition
real(r8), pointer :: sandfrac(:) ! sand fraction
real(r8), pointer :: clayfrac(:) ! clay fraction
! for dry deposition of chemical tracers
real(r8), pointer :: mlaidiff(:) ! difference between lai month one and month two
real(r8), pointer :: rb1(:) ! aerodynamical resistance (s/m)
real(r8), pointer :: annlai(:,:) ! 12 months of monthly lai from input data set
#if (defined CASA)
real(r8), pointer :: Closs(:,:) ! C lost to atm
real(r8), pointer :: Ctrans(:,:) ! C transfers out of pool types
real(r8), pointer :: Resp_C(:,:) ! C respired
real(r8), pointer :: Tpool_C(:,:)! Total C pool size
real(r8), pointer :: eff(:,:)
real(r8), pointer :: frac_donor(:,:)
real(r8), pointer :: livefr(:,:) !live fraction
real(r8), pointer :: pet(:) !potential evaporation (mm h2o/s)
real(r8), pointer :: co2flux(:) ! net CO2 flux (g C/m2/sec) [+= atm]
real(r8), pointer :: fnpp(:) ! NPP (g C/m2/sec)
real(r8), pointer :: soilt(:) !soil temp for top 30cm
real(r8), pointer :: smoist(:) !soil moisture for top 30cm
real(r8), pointer :: sz(:) !thickness of soil layers contributing to output
real(r8), pointer :: watopt(:) !optimal soil water content for et for top 30cm (mm3/mm3)
real(r8), pointer :: watdry(:) !soil water when et stops for top 30cm (mm3/mm3)
real(r8), pointer :: soiltc(:) !soil temp for entire column
real(r8), pointer :: smoistc(:) !soil moisture for entire column
real(r8), pointer :: szc(:) !thickness of soil layers contributing to output
real(r8), pointer :: watoptc(:) !optimal soil water content for et for entire column (mm3/mm3)
real(r8), pointer :: watdryc(:) !soil water when et stops for entire column (mm3/mm3)
real(r8), pointer :: Wlim(:) !Water limitation min value
real(r8), pointer :: litterscalar(:)
real(r8), pointer :: rootlitscalar(:)
real(r8), pointer :: stressCD(:) ! cold and drought stress function (sec-1)
! add to "annK(m,LEAF)" and "annK(m,FROOT)"
! in casa_litterfall.F
real(r8), pointer :: excessC(:) ! excess Carbon (gC/m2/timestep)
real(r8), pointer :: bgtemp(:) ! temperature dependence
real(r8), pointer :: bgmoist(:) ! moisture dependence
real(r8), pointer :: plai(:) ! prognostic LAI (m2 leaf/m2 ground)
real(r8), pointer :: Cflux(:) ! Carbon flux
real(r8), pointer :: XSCpool(:)
real(r8), pointer :: tday(:) ! daily accumulated temperature (deg C)
real(r8), pointer :: tdayavg(:) ! daily averaged temperature (deg C)
real(r8), pointer :: tcount(:) ! counter for daily avg temp
real(r8), pointer :: degday(:) ! accumulated degree days (deg C)
real(r8), pointer :: ndegday(:) ! counter for number of degree days
real(r8), pointer :: stressT(:) ! temperature stress function for leaf
! loss apply to Litterfall of deciduous veg
real(r8), pointer :: stressW(:) ! water stress function for leaf loss
real(r8), pointer :: iseabeg(:) ! index for start of growing season
real(r8), pointer :: nstepbeg(:) ! nstep at start of growing season
real(r8), pointer :: lgrow(:) ! growing season index (0 or 1) to be
! passed daily to CASA to get NPP
#if (defined CLAMP)
! Summary variables added for the C-LAMP Experiments
real(r8), pointer :: casa_agnpp(:) ! above-ground net primary production [gC/m2/s]
real(r8), pointer :: casa_ar(:) ! autotrophic respiration [gC/m2/s]
real(r8), pointer :: casa_bgnpp(:) ! below-ground net primary production [gC/m2/s]
real(r8), pointer :: casa_cwdc(:) ! coarse woody debris C [gC/m2]
real(r8), pointer :: casa_cwdc_hr(:) ! cwd heterotrophic respiration [gC/m2/s]
real(r8), pointer :: casa_cwdc_loss(:) ! cwd C loss [gC/m2/s]
real(r8), pointer :: casa_frootc(:) ! fine root C [gC/m2]
real(r8), pointer :: casa_frootc_alloc(:) ! fine root C allocation [gC/m2/s]
real(r8), pointer :: casa_frootc_loss(:) ! fine root C loss [gC/m2/s]
real(r8), pointer :: casa_gpp(:) ! gross primary production [gC/m2/s]
real(r8), pointer :: casa_hr(:) ! total heterotrophic respiration [gC/m2/s]
real(r8), pointer :: casa_leafc(:) ! leaf C [gC/m2]
real(r8), pointer :: casa_leafc_alloc(:) ! leaf C allocation [gC/m2/s]
real(r8), pointer :: casa_leafc_loss(:) ! leaf C loss [gC/m2/s]
real(r8), pointer :: casa_litterc(:) ! total litter C (excluding cwd C) [gC/m2]
real(r8), pointer :: casa_litterc_hr(:) ! litter heterotrophic respiration [gC/m2/s]
real(r8), pointer :: casa_litterc_loss(:) ! litter C loss [gC/m2/s]
real(r8), pointer :: casa_nee(:) ! net ecosystem exchange [gC/m2/s]
real(r8), pointer :: casa_nep(:) ! net ecosystem production [gC/m2/s]
real(r8), pointer :: casa_npp(:) ! net primary production [gC/m2/s]
real(r8), pointer :: casa_soilc(:) ! total soil organic matter C (excluding cwd and litter C) [gC/m2]
real(r8), pointer :: casa_soilc_hr(:) ! soil heterotrophic respiration [gC/m2/s]
real(r8), pointer :: casa_soilc_loss(:) ! total soil organic matter C loss [gC/m2/s]
real(r8), pointer :: casa_woodc(:) ! wood C [gC/m2]
real(r8), pointer :: casa_woodc_alloc(:) ! wood C allocation [gC/m2/s]
real(r8), pointer :: casa_woodc_loss(:) ! wood C loss [gC/m2/s]
#endif
#endif
end type pft_pstate_type
!----------------------------------------------------
! pft ecophysiological constants structure
!----------------------------------------------------
type, public :: pft_epc_type
integer , pointer :: noveg(:) !value for not vegetated
integer , pointer :: tree(:) !tree or not?
real(r8), pointer :: smpso(:) !soil water potential at full stomatal opening (mm)
real(r8), pointer :: smpsc(:) !soil water potential at full stomatal closure (mm)
real(r8), pointer :: fnitr(:) !foliage nitrogen limitation factor (-)
real(r8), pointer :: foln(:) !foliage nitrogen (%)
real(r8), pointer :: dleaf(:) !characteristic leaf dimension (m)
real(r8), pointer :: c3psn(:) !photosynthetic pathway: 0. = c4, 1. = c3
real(r8), pointer :: vcmx25(:) !max rate of carboxylation at 25C (umol CO2/m**2/s)
real(r8), pointer :: mp(:) !slope of conductance-to-photosynthesis relationship
real(r8), pointer :: qe25(:) !quantum efficiency at 25C (umol CO2 / umol photon)
real(r8), pointer :: xl(:) !leaf/stem orientation index
real(r8), pointer :: rhol(:,:) !leaf reflectance: 1=vis, 2=nir (numrad)
real(r8), pointer :: rhos(:,:) !stem reflectance: 1=vis, 2=nir (numrad)
real(r8), pointer :: taul(:,:) !leaf transmittance: 1=vis, 2=nir (numrad)
real(r8), pointer :: taus(:,:) !stem transmittance: 1=vis, 2=nir (numrad)
real(r8), pointer :: z0mr(:) !ratio of momentum roughness length to canopy top height (-)
real(r8), pointer :: displar(:) !ratio of displacement height to canopy top height (-)
real(r8), pointer :: roota_par(:) !CLM rooting distribution parameter [1/m]
real(r8), pointer :: rootb_par(:) !CLM rooting distribution parameter [1/m]
real(r8), pointer :: sla(:) !specific leaf area [m2 leaf g-1 carbon]
! new variables for CN code
real(r8), pointer :: dwood(:) !wood density (gC/m3)
real(r8), pointer :: slatop(:) !specific leaf area at top of canopy, projected area basis [m^2/gC]
real(r8), pointer :: dsladlai(:) !dSLA/dLAI, projected area basis [m^2/gC]
real(r8), pointer :: leafcn(:) !leaf C:N (gC/gN)
real(r8), pointer :: flnr(:) !fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf)
real(r8), pointer :: woody(:) !binary flag for woody lifeform (1=woody, 0=not woody)
real(r8), pointer :: lflitcn(:) !leaf litter C:N (gC/gN)
real(r8), pointer :: frootcn(:) !fine root C:N (gC/gN)
real(r8), pointer :: livewdcn(:) !live wood (phloem and ray parenchyma) C:N (gC/gN)
real(r8), pointer :: deadwdcn(:) !dead wood (xylem and heartwood) C:N (gC/gN)
#ifdef CROP
real(r8), pointer :: graincn(:) !grain C:N (gC/gN)
#endif
real(r8), pointer :: froot_leaf(:) !allocation parameter: new fine root C per new leaf C (gC/gC)
real(r8), pointer :: stem_leaf(:) !allocation parameter: new stem c per new leaf C (gC/gC)
real(r8), pointer :: croot_stem(:) !allocation parameter: new coarse root C per new stem C (gC/gC)
real(r8), pointer :: flivewd(:) !allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units)
real(r8), pointer :: fcur(:) !allocation parameter: fraction of allocation that goes to currently displayed growth, remainder to storage
real(r8), pointer :: lf_flab(:) !leaf litter labile fraction
real(r8), pointer :: lf_fcel(:) !leaf litter cellulose fraction
real(r8), pointer :: lf_flig(:) !leaf litter lignin fraction
real(r8), pointer :: fr_flab(:) !fine root litter labile fraction
real(r8), pointer :: fr_fcel(:) !fine root litter cellulose fraction
real(r8), pointer :: fr_flig(:) !fine root litter lignin fraction
real(r8), pointer :: dw_fcel(:) !dead wood cellulose fraction
real(r8), pointer :: dw_flig(:) !dead wood lignin fraction
real(r8), pointer :: leaf_long(:) !leaf longevity (yrs)
real(r8), pointer :: evergreen(:) !binary flag for evergreen leaf habit (0 or 1)
real(r8), pointer :: stress_decid(:) !binary flag for stress-deciduous leaf habit (0 or 1)
real(r8), pointer :: season_decid(:) !binary flag for seasonal-deciduous leaf habit (0 or 1)
! new variables for fire code
real(r8), pointer :: resist(:) !resistance to fire (no units)
end type pft_epc_type
#if (defined CNDV) || (defined CROP)
!----------------------------------------------------
! pft DGVM-specific ecophysiological constants structure
!----------------------------------------------------
type, public :: pft_dgvepc_type
real(r8), pointer :: crownarea_max(:) !tree maximum crown area [m2]
real(r8), pointer :: tcmin(:) !minimum coldest monthly mean temperature [units?]
real(r8), pointer :: tcmax(:) !maximum coldest monthly mean temperature [units?]
real(r8), pointer :: gddmin(:) !minimum growing degree days (at or above 5 C)
real(r8), pointer :: twmax(:) !upper limit of temperature of the warmest month [units?]
real(r8), pointer :: reinickerp(:) !parameter in allometric equation
real(r8), pointer :: allom1(:) !parameter in allometric
real(r8), pointer :: allom2(:) !parameter in allometric
real(r8), pointer :: allom3(:) !parameter in allometric
end type pft_dgvepc_type
#endif
!----------------------------------------------------
! pft ecophysiological variables structure
!----------------------------------------------------
type, public :: pft_epv_type
real(r8), pointer :: dormant_flag(:) !dormancy flag
real(r8), pointer :: days_active(:) !number of days since last dormancy
real(r8), pointer :: onset_flag(:) !onset flag
real(r8), pointer :: onset_counter(:) !onset days counter
real(r8), pointer :: onset_gddflag(:) !onset flag for growing degree day sum
real(r8), pointer :: onset_fdd(:) !onset freezing degree days counter
real(r8), pointer :: onset_gdd(:) !onset growing degree days
real(r8), pointer :: onset_swi(:) !onset soil water index
real(r8), pointer :: offset_flag(:) !offset flag
real(r8), pointer :: offset_counter(:) !offset days counter
real(r8), pointer :: offset_fdd(:) !offset freezing degree days counter
real(r8), pointer :: offset_swi(:) !offset soil water index
real(r8), pointer :: lgsf(:) !long growing season factor [0-1]
real(r8), pointer :: bglfr(:) !background litterfall rate (1/s)
real(r8), pointer :: bgtr(:) !background transfer growth rate (1/s)
real(r8), pointer :: dayl(:) !daylength (seconds)
real(r8), pointer :: prev_dayl(:) !daylength from previous timestep (seconds)
real(r8), pointer :: annavg_t2m(:) !annual average 2m air temperature (K)
real(r8), pointer :: tempavg_t2m(:) !temporary average 2m air temperature (K)
real(r8), pointer :: gpp(:) !GPP flux before downregulation (gC/m2/s)
real(r8), pointer :: availc(:) !C flux available for allocation (gC/m2/s)
real(r8), pointer :: xsmrpool_recover(:) !C flux assigned to recovery of negative cpool (gC/m2/s)
#if (defined C13)
real(r8), pointer :: xsmrpool_c13ratio(:) !C13/C(12+13) ratio for xsmrpool (proportion)
#endif
real(r8), pointer :: alloc_pnow(:) !fraction of current allocation to display as new growth (DIM)
real(r8), pointer :: c_allometry(:) !C allocation index (DIM)
real(r8), pointer :: n_allometry(:) !N allocation index (DIM)
real(r8), pointer :: plant_ndemand(:) !N flux required to support initial GPP (gN/m2/s)
real(r8), pointer :: tempsum_potential_gpp(:)!temporary annual sum of potential GPP
real(r8), pointer :: annsum_potential_gpp(:) !annual sum of potential GPP
real(r8), pointer :: tempmax_retransn(:) !temporary annual max of retranslocated N pool (gN/m2)
real(r8), pointer :: annmax_retransn(:) !annual max of retranslocated N pool (gN/m2)
real(r8), pointer :: avail_retransn(:) !N flux available from retranslocation pool (gN/m2/s)
real(r8), pointer :: plant_nalloc(:) !total allocated N flux (gN/m2/s)
real(r8), pointer :: plant_calloc(:) !total allocated C flux (gC/m2/s)
real(r8), pointer :: excess_cflux(:) !C flux not allocated due to downregulation (gC/m2/s)
real(r8), pointer :: downreg(:) !fractional reduction in GPP due to N limitation (DIM)
real(r8), pointer :: prev_leafc_to_litter(:) !previous timestep leaf C litterfall flux (gC/m2/s)
real(r8), pointer :: prev_frootc_to_litter(:)!previous timestep froot C litterfall flux (gC/m2/s)
real(r8), pointer :: tempsum_npp(:) !temporary annual sum of NPP (gC/m2/yr)
real(r8), pointer :: annsum_npp(:) !annual sum of NPP (gC/m2/yr)
#if (defined CNDV)
real(r8), pointer :: tempsum_litfall(:) !temporary annual sum of litfall (gC/m2/yr)
real(r8), pointer :: annsum_litfall(:) !annual sum of litfall (gC/m2/yr)
#endif
#if (defined C13)
real(r8), pointer :: rc13_canair(:) !C13O2/C12O2 in canopy air
real(r8), pointer :: rc13_psnsun(:) !C13O2/C12O2 in sunlit canopy psn flux
real(r8), pointer :: rc13_psnsha(:) !C13O2/C12O2 in shaded canopy psn flux
#endif
end type pft_epv_type
!----------------------------------------------------
! pft energy state variables structure
!----------------------------------------------------
type, public :: pft_estate_type
real(r8), pointer :: t_ref2m(:) !2 m height surface air temperature (Kelvin)
real(r8), pointer :: t_ref2m_min(:) !daily minimum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_max(:) !daily maximum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_min_inst(:) !instantaneous daily min of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_max_inst(:) !instantaneous daily max of average 2 m height surface air temp (K)
real(r8), pointer :: q_ref2m(:) !2 m height surface specific humidity (kg/kg)
real(r8), pointer :: t_ref2m_u(:) !Urban 2 m height surface air temperature (Kelvin)
real(r8), pointer :: t_ref2m_r(:) !Rural 2 m height surface air temperature (Kelvin)
real(r8), pointer :: t_ref2m_min_u(:) !Urban daily minimum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_min_r(:) !Rural daily minimum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_max_u(:) !Urban daily maximum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_max_r(:) !Rural daily maximum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_min_inst_u(:) !Urban instantaneous daily min of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_min_inst_r(:) !Rural instantaneous daily min of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_max_inst_u(:) !Urban instantaneous daily max of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_max_inst_r(:) !Rural instantaneous daily max of average 2 m height surface air temp (K)
real(r8), pointer :: rh_ref2m(:) !2 m height surface relative humidity (%)
real(r8), pointer :: rh_ref2m_u(:) !Urban 2 m height surface relative humidity (%)
real(r8), pointer :: rh_ref2m_r(:) !Rural 2 m height surface relative humidity (%)
real(r8), pointer :: t_veg(:) !vegetation temperature (Kelvin)
real(r8), pointer :: thm(:) !intermediate variable (forc_t+0.0098*forc_hgt_t_pft)
end type pft_estate_type
!----------------------------------------------------
! pft water state variables structure
!----------------------------------------------------
type, public :: pft_wstate_type
real(r8), pointer :: h2ocan(:) !canopy water (mm H2O)
end type pft_wstate_type
!----------------------------------------------------
! pft carbon state variables structure
!----------------------------------------------------
type, public :: pft_cstate_type
real(r8), pointer :: leafcmax(:) ! (gC/m2) ann max leaf C
#if (defined CROP)
real(r8), pointer :: grainc(:) ! (gC/m2) grain C
real(r8), pointer :: grainc_storage(:) ! (gC/m2) grain C storage
real(r8), pointer :: grainc_xfer(:) ! (gC/m2) grain C transfer
#endif
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool
real(r8), pointer :: xsmrpool(:) ! (gC/m2) abstract C pool to meet excess MR demand
real(r8), pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation
! summary (diagnostic) state variables, not involved in mass balance
real(r8), pointer :: dispvegc(:) ! (gC/m2) displayed veg carbon, excluding storage and cpool
real(r8), pointer :: storvegc(:) ! (gC/m2) stored vegetation carbon, excluding cpool
real(r8), pointer :: totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool
real(r8), pointer :: totpftc(:) ! (gC/m2) total pft-level carbon, including cpool
#if (defined CLAMP) && (defined CN)
! CLAMP summary (diagnostic) variable
real(r8), pointer :: woodc(:) ! (gC/m2) wood C
#endif
end type pft_cstate_type
!----------------------------------------------------
! pft nitrogen state variables structure
!----------------------------------------------------
type, public :: pft_nstate_type
#if (defined CROP)
real(r8), pointer :: grainn(:) ! (gN/m2) grain N
real(r8), pointer :: grainn_storage(:) ! (gN/m2) grain N storage
real(r8), pointer :: grainn_xfer(:) ! (gN/m2) grain N transfer
#endif
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool
real(r8), pointer :: pft_ntrunc(:) ! (gN/m2) pft-level sink for N truncation
! summary (diagnostic) state variables, not involved in mass balance
real(r8), pointer :: dispvegn(:) ! (gN/m2) displayed veg nitrogen, excluding storage
real(r8), pointer :: storvegn(:) ! (gN/m2) stored vegetation nitrogen
real(r8), pointer :: totvegn(:) ! (gN/m2) total vegetation nitrogen
real(r8), pointer :: totpftn(:) ! (gN/m2) total pft-level nitrogen
end type pft_nstate_type
!----------------------------------------------------
! pft VOC state variables structure
!----------------------------------------------------
type, public :: pft_vstate_type
real(r8), pointer :: t_veg24(:) ! 24hr average vegetation temperature (K)
real(r8), pointer :: t_veg240(:) ! 240hr average vegetation temperature (Kelvin)
real(r8), pointer :: fsd24(:) ! 24hr average of direct beam radiation
real(r8), pointer :: fsd240(:) ! 240hr average of direct beam radiation
real(r8), pointer :: fsi24(:) ! 24hr average of diffuse beam radiation
real(r8), pointer :: fsi240(:) ! 240hr average of diffuse beam radiation
real(r8), pointer :: fsun24(:) ! 24hr average of sunlit fraction of canopy
real(r8), pointer :: fsun240(:) ! 240hr average of sunlit fraction of canopy
real(r8), pointer :: elai_p(:) ! leaf area index average over timestep
end type pft_vstate_type
#if (defined CNDV) || (defined CROP)
!----------------------------------------------------
! pft DGVM state variables structure
!----------------------------------------------------
type, public :: pft_dgvstate_type
real(r8), pointer :: agddtw(:) !accumulated growing degree days above twmax
real(r8), pointer :: agdd(:) !accumulated growing degree days above 5
real(r8), pointer :: t10(:) !10-day running mean of the 2 m temperature (K)
real(r8), pointer :: t_mo(:) !30-day average temperature (Kelvin)
real(r8), pointer :: t_mo_min(:) !annual min of t_mo (Kelvin)
real(r8), pointer :: prec365(:) !365-day running mean of tot. precipitation
logical , pointer :: present(:) !whether PFT present in patch
logical , pointer :: pftmayexist(:) !if .false. then exclude seasonal decid pfts from tropics
real(r8), pointer :: nind(:) !number of individuals (#/m**2)
real(r8), pointer :: lm_ind(:) !individual leaf mass
real(r8), pointer :: lai_ind(:) !LAI per individual
real(r8), pointer :: fpcinc(:) !foliar projective cover increment (fraction)
real(r8), pointer :: fpcgrid(:) !foliar projective cover on gridcell (fraction)
real(r8), pointer :: fpcgridold(:) !last yr's fpcgrid
real(r8), pointer :: crownarea(:) !area that each individual tree takes up (m^2)
real(r8), pointer :: greffic(:)
real(r8), pointer :: heatstress(:)
end type pft_dgvstate_type
#endif
!----------------------------------------------------
! pft energy flux variables structure
!----------------------------------------------------
type, public :: pft_eflux_type
real(r8), pointer :: sabg(:) !solar radiation absorbed by ground (W/m**2)
real(r8), pointer :: sabv(:) !solar radiation absorbed by vegetation (W/m**2)
real(r8), pointer :: fsa(:) !solar radiation absorbed (total) (W/m**2)
real(r8), pointer :: fsa_u(:) !urban solar radiation absorbed (total) (W/m**2)
real(r8), pointer :: fsa_r(:) !rural solar radiation absorbed (total) (W/m**2)
real(r8), pointer :: fsr(:) !solar radiation reflected (W/m**2)
real(r8), pointer :: parsun(:) !average absorbed PAR for sunlit leaves (W/m**2)
real(r8), pointer :: parsha(:) !average absorbed PAR for shaded leaves (W/m**2)
real(r8), pointer :: dlrad(:) !downward longwave radiation below the canopy [W/m2]
real(r8), pointer :: ulrad(:) !upward longwave radiation above the canopy [W/m2]
real(r8), pointer :: eflx_lh_tot(:) !total latent heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_tot_u(:) !urban total latent heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_tot_r(:) !rural total latent heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_grnd(:) !ground evaporation heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_soil_grnd(:) !soil heat flux (W/m**2) [+ = into soil]
real(r8), pointer :: eflx_soil_grnd_u(:) !urban soil heat flux (W/m**2) [+ = into soil]
real(r8), pointer :: eflx_soil_grnd_r(:) !rural soil heat flux (W/m**2) [+ = into soil]
real(r8), pointer :: eflx_sh_tot(:) !total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_tot_u(:) !urban total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_tot_r(:) !rural total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_grnd(:) !sensible heat flux from ground (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_veg(:) !sensible heat flux from leaves (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_vege(:) !veg evaporation heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_vegt(:) !veg transpiration heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_wasteheat_pft(:) !sensible heat flux from domestic heating/cooling sources of waste heat (W/m**2)
real(r8), pointer :: eflx_heat_from_ac_pft(:) !sensible heat flux put back into canyon due to removal by AC (W/m**2)
real(r8), pointer :: eflx_traffic_pft(:) !traffic sensible heat flux (W/m**2)
real(r8), pointer :: eflx_anthro(:) !total anthropogenic heat flux (W/m**2)
real(r8), pointer :: cgrnd(:) !deriv. of soil energy flux wrt to soil temp [w/m2/k]
real(r8), pointer :: cgrndl(:) !deriv. of soil latent heat flux wrt soil temp [w/m**2/k]
real(r8), pointer :: cgrnds(:) !deriv. of soil sensible heat flux wrt soil temp [w/m2/k]
real(r8), pointer :: eflx_gnet(:) !net heat flux into ground (W/m**2)
real(r8), pointer :: dgnetdT(:) !derivative of net ground heat flux wrt soil temp (W/m**2 K)
real(r8), pointer :: eflx_lwrad_out(:) !emitted infrared (longwave) radiation (W/m**2)
real(r8), pointer :: eflx_lwrad_net(:) !net infrared (longwave) rad (W/m**2) [+ = to atm]
real(r8), pointer :: eflx_lwrad_net_u(:) !urban net infrared (longwave) rad (W/m**2) [+ = to atm]
real(r8), pointer :: eflx_lwrad_net_r(:) !rural net infrared (longwave) rad (W/m**2) [+ = to atm]
real(r8), pointer :: netrad(:) !net radiation (W/m**2) [+ = to sfc]
real(r8), pointer :: fsds_vis_d(:) !incident direct beam vis solar radiation (W/m**2)
real(r8), pointer :: fsds_nir_d(:) !incident direct beam nir solar radiation (W/m**2)
real(r8), pointer :: fsds_vis_i(:) !incident diffuse vis solar radiation (W/m**2)
real(r8), pointer :: fsds_nir_i(:) !incident diffuse nir solar radiation (W/m**2)
real(r8), pointer :: fsr_vis_d(:) !reflected direct beam vis solar radiation (W/m**2)
real(r8), pointer :: fsr_nir_d(:) !reflected direct beam nir solar radiation (W/m**2)
real(r8), pointer :: fsr_vis_i(:) !reflected diffuse vis solar radiation (W/m**2)
real(r8), pointer :: fsr_nir_i(:) !reflected diffuse nir solar radiation (W/m**2)
real(r8), pointer :: fsds_vis_d_ln(:) !incident direct beam vis solar radiation at local noon (W/m**2)
real(r8), pointer :: fsds_nir_d_ln(:) !incident direct beam nir solar radiation at local noon (W/m**2)
real(r8), pointer :: fsr_vis_d_ln(:) !reflected direct beam vis solar radiation at local noon (W/m**2)
real(r8), pointer :: fsr_nir_d_ln(:) !reflected direct beam nir solar radiation at local noon (W/m**2)
real(r8), pointer :: sun_add(:,:) !sun canopy absorbed direct from direct (W/m**2)
real(r8), pointer :: tot_aid(:,:) !total canopy absorbed indirect from direct (W/m**2)
real(r8), pointer :: sun_aid(:,:) !sun canopy absorbed indirect from direct (W/m**2)
real(r8), pointer :: sun_aii(:,:) !sun canopy absorbed indirect from indirect (W/m**2)
real(r8), pointer :: sha_aid(:,:) !shade canopy absorbed indirect from direct (W/m**2)
real(r8), pointer :: sha_aii(:,:) !shade canopy absorbed indirect from indirect (W/m**2)
real(r8), pointer :: sun_atot(:,:) !sun canopy total absorbed (W/m**2)
real(r8), pointer :: sha_atot(:,:) !shade canopy total absorbed (W/m**2)
real(r8), pointer :: sun_alf(:,:) !sun canopy total absorbed by leaves (W/m**2)
real(r8), pointer :: sha_alf(:,:) !shade canopy total absored by leaves (W/m**2)
real(r8), pointer :: sun_aperlai(:,:) !sun canopy total absorbed per unit LAI (W/m**2)
real(r8), pointer :: sha_aperlai(:,:) !shade canopy total absorbed per unit LAI (W/m**2)
real(r8), pointer :: sabg_lyr(:,:) ! absorbed radiation in each snow layer and top soil layer (pft,lyr) [W/m2]
real(r8), pointer :: sfc_frc_aer(:) ! surface forcing of snow with all aerosols (pft) [W/m2]
real(r8), pointer :: sfc_frc_bc(:) ! surface forcing of snow with BC (pft) [W/m2]
real(r8), pointer :: sfc_frc_oc(:) ! surface forcing of snow with OC (pft) [W/m2]
real(r8), pointer :: sfc_frc_dst(:) ! surface forcing of snow with dust (pft) [W/m2]
real(r8), pointer :: sfc_frc_aer_sno(:)! surface forcing of snow with all aerosols, averaged only when snow is present (pft) [W/m2]
real(r8), pointer :: sfc_frc_bc_sno(:) ! surface forcing of snow with BC, averaged only when snow is present (pft) [W/m2]
real(r8), pointer :: sfc_frc_oc_sno(:) ! surface forcing of snow with OC, averaged only when snow is present (pft) [W/m2]
real(r8), pointer :: sfc_frc_dst_sno(:)! surface forcing of snow with dust, averaged only when snow is present (pft) [W/m2]
real(r8), pointer :: fsr_sno_vd(:) ! reflected direct beam vis solar radiation from snow (W/m**2)
real(r8), pointer :: fsr_sno_nd(:) ! reflected direct beam NIR solar radiation from snow (W/m**2)
real(r8), pointer :: fsr_sno_vi(:) ! reflected diffuse vis solar radiation from snow (W/m**2)
real(r8), pointer :: fsr_sno_ni(:) ! reflected diffuse NIR solar radiation from snow (W/m**2)
real(r8), pointer :: fsds_sno_vd(:) ! incident visible, direct radiation on snow (for history files) [W/m2]
real(r8), pointer :: fsds_sno_nd(:) ! incident near-IR, direct radiation on snow (for history files) [W/m2]
real(r8), pointer :: fsds_sno_vi(:) ! incident visible, diffuse radiation on snow (for history files) [W/m2]
real(r8), pointer :: fsds_sno_ni(:) ! incident near-IR, diffuse radiation on snow (for history files) [W/m2]
end type pft_eflux_type
!----------------------------------------------------
! pft momentum flux variables structure
!----------------------------------------------------
type, public :: pft_mflux_type
real(r8),pointer :: taux(:) !wind (shear) stress: e-w (kg/m/s**2)
real(r8),pointer :: tauy(:) !wind (shear) stress: n-s (kg/m/s**2)
end type pft_mflux_type
!----------------------------------------------------
! pft water flux variables structure
!----------------------------------------------------
type, public :: pft_wflux_type
real(r8), pointer :: qflx_prec_intr(:) !interception of precipitation [mm/s]
real(r8), pointer :: qflx_prec_grnd(:) !water onto ground including canopy runoff [kg/(m2 s)]
real(r8), pointer :: qflx_rain_grnd(:) !rain on ground after interception (mm H2O/s) [+]
real(r8), pointer :: qflx_snow_grnd(:) !snow on ground after interception (mm H2O/s) [+]
real(r8), pointer :: qflx_snwcp_ice(:) !excess snowfall due to snow capping (mm H2O /s) [+]
real(r8), pointer :: qflx_snwcp_liq(:) !excess rainfall due to snow capping (mm H2O /s) [+]
real(r8), pointer :: qflx_evap_veg(:) !vegetation evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_tran_veg(:) !vegetation transpiration (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_evap_can(:) !evaporation from leaves and stems
real(r8), pointer :: qflx_evap_soi(:) !soil evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_evap_tot(:) !qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
real(r8), pointer :: qflx_evap_grnd(:) !ground surface evaporation rate (mm H2O/s) [+]
real(r8), pointer :: qflx_dew_grnd(:) !ground surface dew formation (mm H2O /s) [+]
real(r8), pointer :: qflx_sub_snow(:) !sublimation rate from snow pack (mm H2O /s) [+]
real(r8), pointer :: qflx_dew_snow(:) !surface dew added to snow pack (mm H2O /s) [+]
end type pft_wflux_type
!----------------------------------------------------
! pft carbon flux variables structure
!----------------------------------------------------
type, public :: pft_cflux_type
real(r8), pointer :: psnsun(:) !sunlit leaf photosynthesis (umol CO2 /m**2/ s)
real(r8), pointer :: psnsha(:) !shaded leaf photosynthesis (umol CO2 /m**2/ s)
real(r8), pointer :: fpsn(:) !photosynthesis (umol CO2 /m**2 /s)
real(r8), pointer :: fco2(:) !net CO2 flux (umol CO2 /m**2 /s) [+ = to atm]
! new variables for CN code
! gap mortality fluxes
real(r8), pointer :: m_leafc_to_litter(:) ! leaf C mortality (gC/m2/s)
real(r8), pointer :: m_leafc_storage_to_litter(:) ! leaf C storage mortality (gC/m2/s)
real(r8), pointer :: m_leafc_xfer_to_litter(:) ! leaf C transfer mortality (gC/m2/s)
real(r8), pointer :: m_frootc_to_litter(:) ! fine root C mortality (gC/m2/s)
real(r8), pointer :: m_frootc_storage_to_litter(:) ! fine root C storage mortality (gC/m2/s)
real(r8), pointer :: m_frootc_xfer_to_litter(:) ! fine root C transfer mortality (gC/m2/s)
real(r8), pointer :: m_livestemc_to_litter(:) ! live stem C mortality (gC/m2/s)
real(r8), pointer :: m_livestemc_storage_to_litter(:) ! live stem C storage mortality (gC/m2/s)
real(r8), pointer :: m_livestemc_xfer_to_litter(:) ! live stem C transfer mortality (gC/m2/s)
real(r8), pointer :: m_deadstemc_to_litter(:) ! dead stem C mortality (gC/m2/s)
real(r8), pointer :: m_deadstemc_storage_to_litter(:) ! dead stem C storage mortality (gC/m2/s)
real(r8), pointer :: m_deadstemc_xfer_to_litter(:) ! dead stem C transfer mortality (gC/m2/s)
real(r8), pointer :: m_livecrootc_to_litter(:) ! live coarse root C mortality (gC/m2/s)
real(r8), pointer :: m_livecrootc_storage_to_litter(:) ! live coarse root C storage mortality (gC/m2/s)
real(r8), pointer :: m_livecrootc_xfer_to_litter(:) ! live coarse root C transfer mortality (gC/m2/s)
real(r8), pointer :: m_deadcrootc_to_litter(:) ! dead coarse root C mortality (gC/m2/s)
real(r8), pointer :: m_deadcrootc_storage_to_litter(:) ! dead coarse root C storage mortality (gC/m2/s)
real(r8), pointer :: m_deadcrootc_xfer_to_litter(:) ! dead coarse root C transfer mortality (gC/m2/s)
real(r8), pointer :: m_gresp_storage_to_litter(:) ! growth respiration storage mortality (gC/m2/s)
real(r8), pointer :: m_gresp_xfer_to_litter(:) ! growth respiration transfer mortality (gC/m2/s)
! harvest mortality fluxes
real(r8), pointer :: hrv_leafc_to_litter(:) ! leaf C harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_leafc_storage_to_litter(:) ! leaf C storage harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_leafc_xfer_to_litter(:) ! leaf C transfer harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_frootc_to_litter(:) ! fine root C harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_frootc_storage_to_litter(:) ! fine root C storage harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_frootc_xfer_to_litter(:) ! fine root C transfer harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_livestemc_to_litter(:) ! live stem C harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_livestemc_storage_to_litter(:) ! live stem C storage harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_livestemc_xfer_to_litter(:) ! live stem C transfer harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_deadstemc_to_prod10c(:) ! dead stem C harvest to 10-year product pool (gC/m2/s)
real(r8), pointer :: hrv_deadstemc_to_prod100c(:) ! dead stem C harvest to 100-year product pool (gC/m2/s)
real(r8), pointer :: hrv_deadstemc_storage_to_litter(:) ! dead stem C storage harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_deadstemc_xfer_to_litter(:) ! dead stem C transfer harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_livecrootc_to_litter(:) ! live coarse root C harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_livecrootc_storage_to_litter(:) ! live coarse root C storage harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_livecrootc_xfer_to_litter(:) ! live coarse root C transfer harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_deadcrootc_to_litter(:) ! dead coarse root C harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_deadcrootc_storage_to_litter(:) ! dead coarse root C storage harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_deadcrootc_xfer_to_litter(:) ! dead coarse root C transfer harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_gresp_storage_to_litter(:) ! growth respiration storage harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_gresp_xfer_to_litter(:) ! growth respiration transfer harvest mortality (gC/m2/s)
real(r8), pointer :: hrv_xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s)
! PFT-level fire fluxes
real(r8), pointer :: m_leafc_to_fire(:) ! leaf C fire loss (gC/m2/s)
real(r8), pointer :: m_leafc_storage_to_fire(:) ! leaf C storage fire loss (gC/m2/s)
real(r8), pointer :: m_leafc_xfer_to_fire(:) ! leaf C transfer fire loss (gC/m2/s)
real(r8), pointer :: m_frootc_to_fire(:) ! fine root C fire loss (gC/m2/s)
real(r8), pointer :: m_frootc_storage_to_fire(:) ! fine root C storage fire loss (gC/m2/s)
real(r8), pointer :: m_frootc_xfer_to_fire(:) ! fine root C transfer fire loss (gC/m2/s)
real(r8), pointer :: m_livestemc_to_fire(:) ! live stem C fire loss (gC/m2/s)
real(r8), pointer :: m_livestemc_storage_to_fire(:) ! live stem C storage fire loss (gC/m2/s)
real(r8), pointer :: m_livestemc_xfer_to_fire(:) ! live stem C transfer fire loss (gC/m2/s)
real(r8), pointer :: m_deadstemc_to_fire(:) ! dead stem C fire loss (gC/m2/s)
real(r8), pointer :: m_deadstemc_to_litter_fire(:) ! dead stem C fire mortality to litter (gC/m2/s)
real(r8), pointer :: m_deadstemc_storage_to_fire(:) ! dead stem C storage fire loss (gC/m2/s)
real(r8), pointer :: m_deadstemc_xfer_to_fire(:) ! dead stem C transfer fire loss (gC/m2/s)
real(r8), pointer :: m_livecrootc_to_fire(:) ! live coarse root C fire loss (gC/m2/s)
real(r8), pointer :: m_livecrootc_storage_to_fire(:) ! live coarse root C storage fire loss (gC/m2/s)
real(r8), pointer :: m_livecrootc_xfer_to_fire(:) ! live coarse root C transfer fire loss (gC/m2/s)
real(r8), pointer :: m_deadcrootc_to_fire(:) ! dead coarse root C fire loss (gC/m2/s)
real(r8), pointer :: m_deadcrootc_to_litter_fire(:) ! dead coarse root C fire mortality to litter (gC/m2/s)
real(r8), pointer :: m_deadcrootc_storage_to_fire(:) ! dead coarse root C storage fire loss (gC/m2/s)
real(r8), pointer :: m_deadcrootc_xfer_to_fire(:) ! dead coarse root C transfer fire loss (gC/m2/s)
real(r8), pointer :: m_gresp_storage_to_fire(:) ! growth respiration storage fire loss (gC/m2/s)
real(r8), pointer :: m_gresp_xfer_to_fire(:) ! growth respiration transfer fire loss (gC/m2/s)
! phenology fluxes from transfer pools
#if (defined CROP)
real(r8), pointer :: grainc_xfer_to_grainc(:) ! grain C growth from storage (gC/m2/s)
#endif
real(r8), pointer :: leafc_xfer_to_leafc(:) ! leaf C growth from storage (gC/m2/s)
real(r8), pointer :: frootc_xfer_to_frootc(:) ! fine root C growth from storage (gC/m2/s)
real(r8), pointer :: livestemc_xfer_to_livestemc(:) ! live stem C growth from storage (gC/m2/s)
real(r8), pointer :: deadstemc_xfer_to_deadstemc(:) ! dead stem C growth from storage (gC/m2/s)
real(r8), pointer :: livecrootc_xfer_to_livecrootc(:) ! live coarse root C growth from storage (gC/m2/s)
real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:) ! dead coarse root C growth from storage (gC/m2/s)
! leaf and fine root litterfall
real(r8), pointer :: leafc_to_litter(:) ! leaf C litterfall (gC/m2/s)
real(r8), pointer :: frootc_to_litter(:) ! fine root C litterfall (gC/m2/s)
#if (defined CROP)
real(r8), pointer :: livestemc_to_litter(:) ! live stem C litterfall (gC/m2/s)
real(r8), pointer :: grainc_to_food(:) ! grain C to food (gC/m2/s)
#endif
! maintenance respiration fluxes
real(r8), pointer :: leaf_mr(:) ! leaf maintenance respiration (gC/m2/s)
real(r8), pointer :: froot_mr(:) ! fine root maintenance respiration (gC/m2/s)
real(r8), pointer :: livestem_mr(:) ! live stem maintenance respiration (gC/m2/s)
real(r8), pointer :: livecroot_mr(:) ! live coarse root maintenance respiration (gC/m2/s)
real(r8), pointer :: leaf_curmr(:) ! leaf maintenance respiration from current GPP (gC/m2/s)
real(r8), pointer :: froot_curmr(:) ! fine root maintenance respiration from current GPP (gC/m2/s)
real(r8), pointer :: livestem_curmr(:) ! live stem maintenance respiration from current GPP (gC/m2/s)
real(r8), pointer :: livecroot_curmr(:) ! live coarse root maintenance respiration from current GPP (gC/m2/s)
real(r8), pointer :: leaf_xsmr(:) ! leaf maintenance respiration from storage (gC/m2/s)
real(r8), pointer :: froot_xsmr(:) ! fine root maintenance respiration from storage (gC/m2/s)
real(r8), pointer :: livestem_xsmr(:) ! live stem maintenance respiration from storage (gC/m2/s)
real(r8), pointer :: livecroot_xsmr(:) ! live coarse root maintenance respiration from storage (gC/m2/s)
! photosynthesis fluxes
real(r8), pointer :: psnsun_to_cpool(:) ! C fixation from sunlit canopy (gC/m2/s)
real(r8), pointer :: psnshade_to_cpool(:) ! C fixation from shaded canopy (gC/m2/s)
! allocation fluxes, from current GPP
real(r8), pointer :: cpool_to_xsmrpool(:) ! allocation to maintenance respiration storage pool (gC/m2/s)
#if (defined CROP)
real(r8), pointer :: cpool_to_grainc(:) ! allocation to grain C (gC/m2/s)
real(r8), pointer :: cpool_to_grainc_storage(:) ! allocation to grain C storage (gC/m2/s)
#endif
real(r8), pointer :: cpool_to_leafc(:) ! allocation to leaf C (gC/m2/s)
real(r8), pointer :: cpool_to_leafc_storage(:) ! allocation to leaf C storage (gC/m2/s)
real(r8), pointer :: cpool_to_frootc(:) ! allocation to fine root C (gC/m2/s)
real(r8), pointer :: cpool_to_frootc_storage(:) ! allocation to fine root C storage (gC/m2/s)
real(r8), pointer :: cpool_to_livestemc(:) ! allocation to live stem C (gC/m2/s)
real(r8), pointer :: cpool_to_livestemc_storage(:) ! allocation to live stem C storage (gC/m2/s)
real(r8), pointer :: cpool_to_deadstemc(:) ! allocation to dead stem C (gC/m2/s)
real(r8), pointer :: cpool_to_deadstemc_storage(:) ! allocation to dead stem C storage (gC/m2/s)
real(r8), pointer :: cpool_to_livecrootc(:) ! allocation to live coarse root C (gC/m2/s)
real(r8), pointer :: cpool_to_livecrootc_storage(:) ! allocation to live coarse root C storage (gC/m2/s)
real(r8), pointer :: cpool_to_deadcrootc(:) ! allocation to dead coarse root C (gC/m2/s)
real(r8), pointer :: cpool_to_deadcrootc_storage(:) ! allocation to dead coarse root C storage (gC/m2/s)
real(r8), pointer :: cpool_to_gresp_storage(:) ! allocation to growth respiration storage (gC/m2/s)
! growth respiration fluxes
#if (defined CROP)
real(r8), pointer :: xsmrpool_to_atm(:)
real(r8), pointer :: cpool_grain_gr(:) ! grain growth respiration (gC/m2/s)
real(r8), pointer :: cpool_grain_storage_gr(:) ! grain growth respiration to storage (gC/m2/s)
real(r8), pointer :: transfer_grain_gr(:) ! grain growth respiration from storage (gC/m2/s)
#endif
real(r8), pointer :: cpool_leaf_gr(:) ! leaf growth respiration (gC/m2/s)
real(r8), pointer :: cpool_leaf_storage_gr(:) ! leaf growth respiration to storage (gC/m2/s)
real(r8), pointer :: transfer_leaf_gr(:) ! leaf growth respiration from storage (gC/m2/s)
real(r8), pointer :: cpool_froot_gr(:) ! fine root growth respiration (gC/m2/s)
real(r8), pointer :: cpool_froot_storage_gr(:) ! fine root growth respiration to storage (gC/m2/s)
real(r8), pointer :: transfer_froot_gr(:) ! fine root growth respiration from storage (gC/m2/s)
real(r8), pointer :: cpool_livestem_gr(:) ! live stem growth respiration (gC/m2/s)
real(r8), pointer :: cpool_livestem_storage_gr(:) ! live stem growth respiration to storage (gC/m2/s)
real(r8), pointer :: transfer_livestem_gr(:) ! live stem growth respiration from storage (gC/m2/s)
real(r8), pointer :: cpool_deadstem_gr(:) ! dead stem growth respiration (gC/m2/s)
real(r8), pointer :: cpool_deadstem_storage_gr(:) ! dead stem growth respiration to storage (gC/m2/s)
real(r8), pointer :: transfer_deadstem_gr(:) ! dead stem growth respiration from storage (gC/m2/s)
real(r8), pointer :: cpool_livecroot_gr(:) ! live coarse root growth respiration (gC/m2/s)
real(r8), pointer :: cpool_livecroot_storage_gr(:) ! live coarse root growth respiration to storage (gC/m2/s)
real(r8), pointer :: transfer_livecroot_gr(:) ! live coarse root growth respiration from storage (gC/m2/s)
real(r8), pointer :: cpool_deadcroot_gr(:) ! dead coarse root growth respiration (gC/m2/s)
real(r8), pointer :: cpool_deadcroot_storage_gr(:) ! dead coarse root growth respiration to storage (gC/m2/s)
real(r8), pointer :: transfer_deadcroot_gr(:) ! dead coarse root growth respiration from storage (gC/m2/s)
! annual turnover of storage to transfer pools
#if (defined CROP)
real(r8), pointer :: grainc_storage_to_xfer(:) ! grain C shift storage to transfer (gC/m2/s)
#endif
real(r8), pointer :: leafc_storage_to_xfer(:) ! leaf C shift storage to transfer (gC/m2/s)
real(r8), pointer :: frootc_storage_to_xfer(:) ! fine root C shift storage to transfer (gC/m2/s)
real(r8), pointer :: livestemc_storage_to_xfer(:) ! live stem C shift storage to transfer (gC/m2/s)
real(r8), pointer :: deadstemc_storage_to_xfer(:) ! dead stem C shift storage to transfer (gC/m2/s)
real(r8), pointer :: livecrootc_storage_to_xfer(:) ! live coarse root C shift storage to transfer (gC/m2/s)
real(r8), pointer :: deadcrootc_storage_to_xfer(:) ! dead coarse root C shift storage to transfer (gC/m2/s)
real(r8), pointer :: gresp_storage_to_xfer(:) ! growth respiration shift storage to transfer (gC/m2/s)
! turnover of livewood to deadwood
real(r8), pointer :: livestemc_to_deadstemc(:) ! live stem C turnover (gC/m2/s)
real(r8), pointer :: livecrootc_to_deadcrootc(:) ! live coarse root C turnover (gC/m2/s)
! summary (diagnostic) flux variables, not involved in mass balance
real(r8), pointer :: gpp(:) ! (gC/m2/s) gross primary production
real(r8), pointer :: mr(:) ! (gC/m2/s) maintenance respiration
real(r8), pointer :: current_gr(:) ! (gC/m2/s) growth resp for new growth displayed in this timestep
real(r8), pointer :: transfer_gr(:) ! (gC/m2/s) growth resp for transfer growth displayed in this timestep
real(r8), pointer :: storage_gr(:) ! (gC/m2/s) growth resp for growth sent to storage for later display
real(r8), pointer :: gr(:) ! (gC/m2/s) total growth respiration
real(r8), pointer :: ar(:) ! (gC/m2/s) autotrophic respiration (MR + GR)
real(r8), pointer :: rr(:) ! (gC/m2/s) root respiration (fine root MR + total root GR)
real(r8), pointer :: npp(:) ! (gC/m2/s) net primary production
real(r8), pointer :: agnpp(:) ! (gC/m2/s) aboveground NPP
real(r8), pointer :: bgnpp(:) ! (gC/m2/s) belowground NPP
real(r8), pointer :: litfall(:) ! (gC/m2/s) litterfall (leaves and fine roots)
real(r8), pointer :: vegfire(:) ! (gC/m2/s) pft-level fire loss (obsolete, mark for removal)
real(r8), pointer :: wood_harvestc(:) ! (gC/m2/s) pft-level wood harvest (to product pools)
real(r8), pointer :: pft_cinputs(:) ! (gC/m2/s) pft-level carbon inputs (for balance checking)
real(r8), pointer :: pft_coutputs(:) ! (gC/m2/s) pft-level carbon outputs (for balance checking)
#if (defined CLAMP) && (defined CN)
! CLAMP summary (diagnostic) variables, not involved in mass balance
real(r8), pointer :: frootc_alloc(:) ! (gC/m2/s) pft-level fine root C alloc
real(r8), pointer :: frootc_loss(:) ! (gC/m2/s) pft-level fine root C loss
real(r8), pointer :: leafc_alloc(:) ! (gC/m2/s) pft-level leaf C alloc
real(r8), pointer :: leafc_loss(:) ! (gC/m2/s) pft-level leaf C loss
real(r8), pointer :: woodc_alloc(:) ! (gC/m2/s) pft-level wood C alloc
real(r8), pointer :: woodc_loss(:) ! (gC/m2/s) pft-level wood C loss
#endif
! new variables for fire code
real(r8), pointer :: pft_fire_closs(:) ! (gC/m2/s) total pft-level fire C loss
end type pft_cflux_type
!----------------------------------------------------
! pft nitrogen flux variables structure
!----------------------------------------------------
type, public :: pft_nflux_type
! new variables for CN code
! gap mortality fluxes
real(r8), pointer :: m_leafn_to_litter(:) ! leaf N mortality (gN/m2/s)
real(r8), pointer :: m_frootn_to_litter(:) ! fine root N mortality (gN/m2/s)
real(r8), pointer :: m_leafn_storage_to_litter(:) ! leaf N storage mortality (gN/m2/s)
real(r8), pointer :: m_frootn_storage_to_litter(:) ! fine root N storage mortality (gN/m2/s)
real(r8), pointer :: m_livestemn_storage_to_litter(:) ! live stem N storage mortality (gN/m2/s)
real(r8), pointer :: m_deadstemn_storage_to_litter(:) ! dead stem N storage mortality (gN/m2/s)
real(r8), pointer :: m_livecrootn_storage_to_litter(:) ! live coarse root N storage mortality (gN/m2/s)
real(r8), pointer :: m_deadcrootn_storage_to_litter(:) ! dead coarse root N storage mortality (gN/m2/s)
real(r8), pointer :: m_leafn_xfer_to_litter(:) ! leaf N transfer mortality (gN/m2/s)
real(r8), pointer :: m_frootn_xfer_to_litter(:) ! fine root N transfer mortality (gN/m2/s)
real(r8), pointer :: m_livestemn_xfer_to_litter(:) ! live stem N transfer mortality (gN/m2/s)
real(r8), pointer :: m_deadstemn_xfer_to_litter(:) ! dead stem N transfer mortality (gN/m2/s)
real(r8), pointer :: m_livecrootn_xfer_to_litter(:) ! live coarse root N transfer mortality (gN/m2/s)
real(r8), pointer :: m_deadcrootn_xfer_to_litter(:) ! dead coarse root N transfer mortality (gN/m2/s)
real(r8), pointer :: m_livestemn_to_litter(:) ! live stem N mortality (gN/m2/s)
real(r8), pointer :: m_deadstemn_to_litter(:) ! dead stem N mortality (gN/m2/s)
real(r8), pointer :: m_livecrootn_to_litter(:) ! live coarse root N mortality (gN/m2/s)
real(r8), pointer :: m_deadcrootn_to_litter(:) ! dead coarse root N mortality (gN/m2/s)
real(r8), pointer :: m_retransn_to_litter(:) ! retranslocated N pool mortality (gN/m2/s)
! harvest mortality fluxes
real(r8), pointer :: hrv_leafn_to_litter(:) ! leaf N harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_frootn_to_litter(:) ! fine root N harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_leafn_storage_to_litter(:) ! leaf N storage harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_frootn_storage_to_litter(:) ! fine root N storage harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_livestemn_storage_to_litter(:) ! live stem N storage harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_deadstemn_storage_to_litter(:) ! dead stem N storage harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_livecrootn_storage_to_litter(:) ! live coarse root N storage harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_deadcrootn_storage_to_litter(:) ! dead coarse root N storage harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_leafn_xfer_to_litter(:) ! leaf N transfer harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_frootn_xfer_to_litter(:) ! fine root N transfer harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_livestemn_xfer_to_litter(:) ! live stem N transfer harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_deadstemn_xfer_to_litter(:) ! dead stem N transfer harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_livecrootn_xfer_to_litter(:) ! live coarse root N transfer harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_deadcrootn_xfer_to_litter(:) ! dead coarse root N transfer harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_livestemn_to_litter(:) ! live stem N harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_deadstemn_to_prod10n(:) ! dead stem N harvest to 10-year product pool (gN/m2/s)
real(r8), pointer :: hrv_deadstemn_to_prod100n(:) ! dead stem N harvest to 100-year product pool (gN/m2/s)
real(r8), pointer :: hrv_livecrootn_to_litter(:) ! live coarse root N harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_deadcrootn_to_litter(:) ! dead coarse root N harvest mortality (gN/m2/s)
real(r8), pointer :: hrv_retransn_to_litter(:) ! retranslocated N pool harvest mortality (gN/m2/s)
! fire mortality fluxes
real(r8), pointer :: m_leafn_to_fire(:) ! leaf N fire loss (gN/m2/s)
real(r8), pointer :: m_leafn_storage_to_fire(:) ! leaf N storage fire loss (gN/m2/s)
real(r8), pointer :: m_leafn_xfer_to_fire(:) ! leaf N transfer fire loss (gN/m2/s)
real(r8), pointer :: m_frootn_to_fire(:) ! fine root N fire loss (gN/m2/s)
real(r8), pointer :: m_frootn_storage_to_fire(:) ! fine root N storage fire loss (gN/m2/s)
real(r8), pointer :: m_frootn_xfer_to_fire(:) ! fine root N transfer fire loss (gN/m2/s)
real(r8), pointer :: m_livestemn_to_fire(:) ! live stem N fire loss (gN/m2/s)
real(r8), pointer :: m_livestemn_storage_to_fire(:) ! live stem N storage fire loss (gN/m2/s)
real(r8), pointer :: m_livestemn_xfer_to_fire(:) ! live stem N transfer fire loss (gN/m2/s)
real(r8), pointer :: m_deadstemn_to_fire(:) ! dead stem N fire loss (gN/m2/s)
real(r8), pointer :: m_deadstemn_to_litter_fire(:) ! dead stem N fire mortality to litter (gN/m2/s)
real(r8), pointer :: m_deadstemn_storage_to_fire(:) ! dead stem N storage fire loss (gN/m2/s)
real(r8), pointer :: m_deadstemn_xfer_to_fire(:) ! dead stem N transfer fire loss (gN/m2/s)
real(r8), pointer :: m_livecrootn_to_fire(:) ! live coarse root N fire loss (gN/m2/s)
real(r8), pointer :: m_livecrootn_storage_to_fire(:) ! live coarse root N storage fire loss (gN/m2/s)
real(r8), pointer :: m_livecrootn_xfer_to_fire(:) ! live coarse root N transfer fire loss (gN/m2/s)
real(r8), pointer :: m_deadcrootn_to_fire(:) ! dead coarse root N fire loss (gN/m2/s)
real(r8), pointer :: m_deadcrootn_to_litter_fire(:) ! dead coarse root N fire mortality to litter (gN/m2/s)
real(r8), pointer :: m_deadcrootn_storage_to_fire(:) ! dead coarse root N storage fire loss (gN/m2/s)
real(r8), pointer :: m_deadcrootn_xfer_to_fire(:) ! dead coarse root N transfer fire loss (gN/m2/s)
real(r8), pointer :: m_retransn_to_fire(:) ! retranslocated N pool fire loss (gN/m2/s)
! phenology fluxes from transfer pool
#if (defined CROP)
real(r8), pointer :: grainn_xfer_to_grainn(:) ! grain N growth from storage (gN/m2/s)
#endif
real(r8), pointer :: leafn_xfer_to_leafn(:) ! leaf N growth from storage (gN/m2/s)
real(r8), pointer :: frootn_xfer_to_frootn(:) ! fine root N growth from storage (gN/m2/s)
real(r8), pointer :: livestemn_xfer_to_livestemn(:) ! live stem N growth from storage (gN/m2/s)
real(r8), pointer :: deadstemn_xfer_to_deadstemn(:) ! dead stem N growth from storage (gN/m2/s)
real(r8), pointer :: livecrootn_xfer_to_livecrootn(:) ! live coarse root N growth from storage (gN/m2/s)
real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:) ! dead coarse root N growth from storage (gN/m2/s)
! litterfall fluxes
#if (defined CROP)
real(r8), pointer :: livestemn_to_litter(:) ! livestem N to litter (gN/m2/s)
real(r8), pointer :: grainn_to_food(:) ! grain N to food (gN/m2/s)
#endif
real(r8), pointer :: leafn_to_litter(:) ! leaf N litterfall (gN/m2/s)
real(r8), pointer :: leafn_to_retransn(:) ! leaf N to retranslocated N pool (gN/m2/s)
real(r8), pointer :: frootn_to_litter(:) ! fine root N litterfall (gN/m2/s)
! allocation fluxes
real(r8), pointer :: retransn_to_npool(:) ! deployment of retranslocated N (gN/m2/s)
real(r8), pointer :: sminn_to_npool(:) ! deployment of soil mineral N uptake (gN/m2/s)
#if (defined CROP)
real(r8), pointer :: npool_to_grainn(:) ! allocation to grain N (gN/m2/s)
real(r8), pointer :: npool_to_grainn_storage(:) ! allocation to grain N storage (gN/m2/s)
#endif
real(r8), pointer :: npool_to_leafn(:) ! allocation to leaf N (gN/m2/s)
real(r8), pointer :: npool_to_leafn_storage(:) ! allocation to leaf N storage (gN/m2/s)
real(r8), pointer :: npool_to_frootn(:) ! allocation to fine root N (gN/m2/s)
real(r8), pointer :: npool_to_frootn_storage(:) ! allocation to fine root N storage (gN/m2/s)
real(r8), pointer :: npool_to_livestemn(:) ! allocation to live stem N (gN/m2/s)
real(r8), pointer :: npool_to_livestemn_storage(:) ! allocation to live stem N storage (gN/m2/s)
real(r8), pointer :: npool_to_deadstemn(:) ! allocation to dead stem N (gN/m2/s)
real(r8), pointer :: npool_to_deadstemn_storage(:) ! allocation to dead stem N storage (gN/m2/s)
real(r8), pointer :: npool_to_livecrootn(:) ! allocation to live coarse root N (gN/m2/s)
real(r8), pointer :: npool_to_livecrootn_storage(:) ! allocation to live coarse root N storage (gN/m2/s)
real(r8), pointer :: npool_to_deadcrootn(:) ! allocation to dead coarse root N (gN/m2/s)
real(r8), pointer :: npool_to_deadcrootn_storage(:) ! allocation to dead coarse root N storage (gN/m2/s)
! annual turnover of storage to transfer pools
#if (defined CROP)
real(r8), pointer :: grainn_storage_to_xfer(:) ! grain N shift storage to transfer (gN/m2/s)
#endif
real(r8), pointer :: leafn_storage_to_xfer(:) ! leaf N shift storage to transfer (gN/m2/s)
real(r8), pointer :: frootn_storage_to_xfer(:) ! fine root N shift storage to transfer (gN/m2/s)
real(r8), pointer :: livestemn_storage_to_xfer(:) ! live stem N shift storage to transfer (gN/m2/s)
real(r8), pointer :: deadstemn_storage_to_xfer(:) ! dead stem N shift storage to transfer (gN/m2/s)
real(r8), pointer :: livecrootn_storage_to_xfer(:) ! live coarse root N shift storage to transfer (gN/m2/s)
real(r8), pointer :: deadcrootn_storage_to_xfer(:) ! dead coarse root N shift storage to transfer (gN/m2/s)
! turnover of livewood to deadwood, with retranslocation
real(r8), pointer :: livestemn_to_deadstemn(:) ! live stem N turnover (gN/m2/s)
real(r8), pointer :: livestemn_to_retransn(:) ! live stem N to retranslocated N pool (gN/m2/s)
real(r8), pointer :: livecrootn_to_deadcrootn(:) ! live coarse root N turnover (gN/m2/s)
real(r8), pointer :: livecrootn_to_retransn(:) ! live coarse root N to retranslocated N pool (gN/m2/s)
! summary (diagnostic) flux variables, not involved in mass balance
real(r8), pointer :: ndeploy(:) ! total N deployed to growth and storage (gN/m2/s)
real(r8), pointer :: pft_ninputs(:) ! total N inputs to pft-level (gN/m2/s)
real(r8), pointer :: pft_noutputs(:) ! total N outputs from pft-level (gN/m2/s)
real(r8), pointer :: wood_harvestn(:) ! total N losses to wood product pools (gN/m2/s)
! new variables for fire code
real(r8), pointer :: pft_fire_nloss(:) ! total pft-level fire N loss (gN/m2/s)
end type pft_nflux_type
!----------------------------------------------------
! pft VOC flux variables structure
!----------------------------------------------------
type, public :: pft_vflux_type
real(r8), pointer :: vocflx_tot(:) !total VOC flux into atmosphere [ug C m-2 h-1]
real(r8), pointer :: vocflx(:,:) !(nvoc) VOC flux [ug C m-2 h-1]
real(r8), pointer :: vocflx_1(:) !vocflx(1) (for history output) [ug C m-2 h-1]
real(r8), pointer :: vocflx_2(:) !vocflx(2) (for history output) [ug C m-2 h-1]
real(r8), pointer :: vocflx_3(:) !vocflx(3) (for history output) [ug C m-2 h-1]
real(r8), pointer :: vocflx_4(:) !vocflx(4) (for history output) [ug C m-2 h-1]
real(r8), pointer :: vocflx_5(:) !vocflx(5) (for history output) [ug C m-2 h-1]
real(r8), pointer :: Eopt_out(:) !Eopt coefficient
real(r8), pointer :: topt_out(:) !topt coefficient
real(r8), pointer :: alpha_out(:) !alpha coefficient
real(r8), pointer :: cp_out(:) !cp coefficient
real(r8), pointer :: paru_out(:)
real(r8), pointer :: par24u_out(:)
real(r8), pointer :: par240u_out(:)
real(r8), pointer :: para_out(:)
real(r8), pointer :: par24a_out(:)
real(r8), pointer :: par240a_out(:)
real(r8), pointer :: gamma_out(:)
real(r8), pointer :: gammaL_out(:)
real(r8), pointer :: gammaT_out(:)
real(r8), pointer :: gammaP_out(:)
real(r8), pointer :: gammaA_out(:)
real(r8), pointer :: gammaS_out(:)
end type pft_vflux_type
!----------------------------------------------------
! pft dry dep velocity variables structure
!----------------------------------------------------
type, public :: pft_depvd_type
real(r8), pointer :: drydepvel(:,:)
end type pft_depvd_type
!----------------------------------------------------
! pft dust flux variables structure
!----------------------------------------------------
type, public :: pft_dflux_type
real(r8), pointer :: flx_mss_vrt_dst(:,:) !(ndst) !surface dust emission (kg/m**2/s) [ + = to atm]
real(r8), pointer :: flx_mss_vrt_dst_tot(:) !total dust flux into atmosphere
real(r8), pointer :: vlc_trb(:,:) !(ndst) turbulent deposition velocity (m/s)
real(r8), pointer :: vlc_trb_1(:) !turbulent deposition velocity 1(m/s)
real(r8), pointer :: vlc_trb_2(:) !turbulent deposition velocity 2(m/s)
real(r8), pointer :: vlc_trb_3(:) !turbulent deposition velocity 3(m/s)
real(r8), pointer :: vlc_trb_4(:) !turbulent deposition velocity 4(m/s)
end type pft_dflux_type
!----------------------------------------------------
! End definition of structures defined at the pft_type level
!----------------------------------------------------
!*******************************************************************************
!*******************************************************************************
!----------------------------------------------------
! Begin definition of structures defined at the column_type level
!----------------------------------------------------
! column physical state variables structure
!----------------------------------------------------
type, public :: column_pstate_type
type(pft_pstate_type) :: pps_a !pft-level pstate variables averaged to the column
integer , pointer :: snl(:) !number of snow layers
integer , pointer :: isoicol(:) !soil color class
real(r8), pointer :: bsw(:,:) !Clapp and Hornberger "b" (nlevgrnd)
real(r8), pointer :: watsat(:,:) !volumetric soil water at saturation (porosity) (nlevgrnd)
real(r8), pointer :: watdry(:,:) !btran parameter for btran=0
real(r8), pointer :: watopt(:,:) !btran parameter for btran = 1
real(r8), pointer :: hksat(:,:) !hydraulic conductivity at saturation (mm H2O /s) (nlevgrnd)
real(r8), pointer :: sucsat(:,:) !minimum soil suction (mm) (nlevgrnd)
real(r8), pointer :: hkdepth(:) !decay factor (m)
real(r8), pointer :: wtfact(:) !maximum saturated fraction for a gridcell
real(r8), pointer :: fracice(:,:) !fractional impermeability (-)
real(r8), pointer :: csol(:,:) !heat capacity, soil solids (J/m**3/Kelvin) (nlevgrnd)
real(r8), pointer :: tkmg(:,:) !thermal conductivity, soil minerals [W/m-K] (new) (nlevgrnd)
real(r8), pointer :: tkdry(:,:) !thermal conductivity, dry soil (W/m/Kelvin) (nlevgrnd)
real(r8), pointer :: tksatu(:,:) !thermal conductivity, saturated soil [W/m-K] (new) (nlevgrnd)
real(r8), pointer :: smpmin(:) !restriction for min of soil potential (mm) (new)
real(r8), pointer :: gwc_thr(:) !threshold soil moisture based on clay content
real(r8), pointer :: mss_frc_cly_vld(:) ![frc] Mass fraction clay limited to 0.20
real(r8), pointer :: mbl_bsn_fct(:) !basin factor
logical , pointer :: do_capsnow(:) !true => do snow capping
real(r8), pointer :: snowdp(:) !snow height (m)
real(r8), pointer :: frac_sno(:) !fraction of ground covered by snow (0 to 1)
real(r8), pointer :: zi(:,:) !interface level below a "z" level (m) (-nlevsno+0:nlevgrnd)
real(r8), pointer :: dz(:,:) !layer thickness (m) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: z(:,:) !layer depth (m) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: frac_iceold(:,:) !fraction of ice relative to the tot water (new) (-nlevsno+1:nlevgrnd)
integer , pointer :: imelt(:,:) !flag for melting (=1), freezing (=2), Not=0 (new) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: eff_porosity(:,:) !effective porosity = porosity - vol_ice (nlevgrnd)
real(r8), pointer :: emg(:) !ground emissivity
real(r8), pointer :: z0mg(:) !roughness length over ground, momentum [m]
real(r8), pointer :: z0hg(:) !roughness length over ground, sensible heat [m]
real(r8), pointer :: z0qg(:) !roughness length over ground, latent heat [m]
real(r8), pointer :: htvp(:) !latent heat of vapor of water (or sublimation) [j/kg]
real(r8), pointer :: beta(:) !coefficient of convective velocity [-]
real(r8), pointer :: zii(:) !convective boundary height [m]
real(r8), pointer :: albgrd(:,:) !ground albedo (direct) (numrad)
real(r8), pointer :: albgri(:,:) !ground albedo (diffuse) (numrad)
real(r8), pointer :: rootr_column(:,:) !effective fraction of roots in each soil layer (nlevgrnd)
real(r8), pointer :: rootfr_road_perv(:,:) !fraction of roots in each soil layer for urban pervious road
real(r8), pointer :: rootr_road_perv(:,:) !effective fraction of roots in each soil layer of urban pervious road
real(r8), pointer :: wf(:) !soil water as frac. of whc for top 0.5 m
! real(r8), pointer :: xirrig(:) !irrigation rate
real(r8), pointer :: max_dayl(:) !maximum daylength for this column (s)
! new variables for CN code
real(r8), pointer :: bsw2(:,:) !Clapp and Hornberger "b" for CN code
real(r8), pointer :: psisat(:,:) !soil water potential at saturation for CN code (MPa)
real(r8), pointer :: vwcsat(:,:) !volumetric water content at saturation for CN code (m3/m3)
real(r8), pointer :: decl(:) ! solar declination angle (radians)
real(r8), pointer :: coszen(:) !cosine of solar zenith angle
real(r8), pointer :: soilpsi(:,:) !soil water potential in each soil layer (MPa)
real(r8), pointer :: fpi(:) !fraction of potential immobilization (no units)
real(r8), pointer :: fpg(:) !fraction of potential gpp (no units)
real(r8), pointer :: annsum_counter(:) !seconds since last annual accumulator turnover
real(r8), pointer :: cannsum_npp(:) !annual sum of NPP, averaged from pft-level (gC/m2/yr)
real(r8), pointer :: cannavg_t2m(:) !annual average of 2m air temperature, averaged from pft-level (K)
real(r8), pointer :: watfc(:,:) !volumetric soil water at field capacity (nlevsoi)
! new variables for fire code
real(r8), pointer :: me(:) !moisture of extinction (proportion)
real(r8), pointer :: fire_prob(:) !daily fire probability (0-1)
real(r8), pointer :: mean_fire_prob(:) !e-folding mean of daily fire probability (0-1)
real(r8), pointer :: fireseasonl(:) !annual fire season length (days, <= 365)
real(r8), pointer :: farea_burned(:) !timestep fractional area burned (proportion)
real(r8), pointer :: ann_farea_burned(:) !annual total fractional area burned (proportion)
real(r8), pointer :: albsnd_hst(:,:) ! snow albedo, direct, for history files (col,bnd) [frc]
real(r8), pointer :: albsni_hst(:,:) ! snow albedo, diffuse, for history files (col,bnd) [frc]
real(r8), pointer :: albsod(:,:) ! soil albedo: direct (col,bnd) [frc]
real(r8), pointer :: albsoi(:,:) ! soil albedo: diffuse (col,bnd) [frc]
real(r8), pointer :: flx_absdv(:,:) ! absorbed flux per unit incident direct flux: VIS (col,lyr) [frc]
real(r8), pointer :: flx_absdn(:,:) ! absorbed flux per unit incident direct flux: NIR (col,lyr) [frc]
real(r8), pointer :: flx_absiv(:,:) ! absorbed flux per unit incident diffuse flux: VIS (col,lyr) [frc]
real(r8), pointer :: flx_absin(:,:) ! absorbed flux per unit incident diffuse flux: NIR (col,lyr) [frc]
real(r8), pointer :: snw_rds(:,:) ! snow grain radius (col,lyr) [m^-6, microns]
real(r8), pointer :: snw_rds_top(:) ! snow grain radius, top layer (col) [m^-6, microns]
real(r8), pointer :: sno_liq_top(:) ! snow liquid water fraction (mass), top layer (col) [fraction]
real(r8), pointer :: mss_bcpho(:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bcphi(:,:) ! mass of hydrophillic BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bctot(:,:) ! total mass of BC in snow (pho+phi) (col,lyr) [kg]
real(r8), pointer :: mss_bc_col(:) ! column-integrated mass of total BC (col) [kg]
real(r8), pointer :: mss_bc_top(:) ! top-layer mass of total BC (col) [kg]
real(r8), pointer :: mss_ocpho(:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocphi(:,:) ! mass of hydrophillic OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_octot(:,:) ! total mass of OC in snow (pho+phi) (col,lyr) [kg]
real(r8), pointer :: mss_oc_col(:) ! column-integrated mass of total OC (col) [kg]
real(r8), pointer :: mss_oc_top(:) ! top-layer mass of total OC (col) [kg]
real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dsttot(:,:) ! total mass of dust in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst_col(:) ! column-integrated mass of dust in snow (col) [kg]
real(r8), pointer :: mss_dst_top(:) ! top-layer mass of dust in snow (col) [kg]
real(r8), pointer :: h2osno_top(:) ! top-layer mass of snow (col) [kg]
real(r8), pointer :: mss_cnc_bcphi(:,:) ! mass concentration of hydrophilic BC in snow (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_bcpho(:,:) ! mass concentration of hydrophilic BC in snow (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_ocphi(:,:) ! mass concentration of hydrophilic OC in snow (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_ocpho(:,:) ! mass concentration of hydrophilic OC in snow (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst1(:,:) ! mass concentration of dust species 1 in snow (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst2(:,:) ! mass concentration of dust species 2 in snow (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst3(:,:) ! mass concentration of dust species 3 in snow (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst4(:,:) ! mass concentration of dust species 4 in snow (col,lyr) [kg/kg]
real(r8), pointer :: albgrd_pur(:,:) ! pure snow ground direct albedo (numrad)
real(r8), pointer :: albgri_pur(:,:) ! pure snow ground diffuse albedo (numrad)
real(r8), pointer :: albgrd_bc(:,:) ! ground direct albedo without BC (numrad)
real(r8), pointer :: albgri_bc(:,:) ! ground diffuse albedo without BC (numrad)
real(r8), pointer :: albgrd_oc(:,:) ! ground direct albedo without OC (numrad)
real(r8), pointer :: albgri_oc(:,:) ! ground diffuse albedo without OC (numrad)
real(r8), pointer :: albgrd_dst(:,:) ! ground direct albedo without dust (numrad)
real(r8), pointer :: albgri_dst(:,:) ! ground diffuse albedo without dust (numrad)
real(r8), pointer :: dTdz_top(:) ! temperature gradient in top layer [K m-1]
real(r8), pointer :: snot_top(:) ! temperature of top snow layer [K]
end type column_pstate_type
!----------------------------------------------------
! column energy state variables structure
!----------------------------------------------------
type, public :: column_estate_type
type(pft_estate_type):: pes_a !pft-level energy state variables averaged to the column
real(r8), pointer :: t_grnd(:) !ground temperature (Kelvin)
real(r8), pointer :: t_grnd_u(:) !Urban ground temperature (Kelvin)
real(r8), pointer :: t_grnd_r(:) !Rural ground temperature (Kelvin)
real(r8), pointer :: dt_grnd(:) !change in t_grnd, last iteration (Kelvin)
real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: t_soi_10cm(:) !soil temperature in top 10cm of soil (Kelvin)
real(r8), pointer :: t_lake(:,:) !lake temperature (Kelvin) (1:nlevlak)
real(r8), pointer :: tssbef(:,:) !soil/snow temperature before update (-nlevsno+1:nlevgrnd)
real(r8), pointer :: thv(:) !virtual potential temperature (kelvin)
real(r8), pointer :: hc_soi(:) !soil heat content (MJ/m2)
real(r8), pointer :: hc_soisno(:) !soil plus snow heat content (MJ/m2)
end type column_estate_type
!----------------------------------------------------
! column water state variables structure
!----------------------------------------------------
type, public :: column_wstate_type
type(pft_wstate_type):: pws_a !pft-level water state variables averaged to the column
real(r8), pointer :: h2osno(:) !snow water (mm H2O)
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) (new) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: h2osoi_liqice_10cm(:) !liquid water + ice lens in top 10cm of soil (kg/m2)
real(r8), pointer :: h2osoi_vol(:,:) !volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] (nlevgrnd)
real(r8), pointer :: h2osno_old(:) !snow mass for previous time step (kg/m2) (new)
real(r8), pointer :: qg(:) !ground specific humidity [kg/kg]
real(r8), pointer :: dqgdT(:) !d(qg)/dT
real(r8), pointer :: snowice(:) !average snow ice lens
real(r8), pointer :: snowliq(:) !average snow liquid water
real(r8) ,pointer :: soilalpha(:) !factor that reduces ground saturated specific humidity (-)
real(r8), pointer :: soilbeta(:) !factor that reduces ground evaporation L&P1992(-)
real(r8) ,pointer :: soilalpha_u(:) !urban factor that reduces ground saturated specific humidity (-)
real(r8), pointer :: zwt(:) !water table depth
real(r8), pointer :: fcov(:) !fractional impermeable area
real(r8), pointer :: wa(:) !water in the unconfined aquifer (mm)
real(r8), pointer :: wt(:) !total water storage (unsaturated soil water + groundwater) (mm)
real(r8), pointer :: qcharge(:) !aquifer recharge rate (mm/s)
real(r8), pointer :: smp_l(:,:) !soil matric potential (mm)
real(r8), pointer :: hk_l(:,:) !hydraulic conductivity (mm/s)
real(r8), pointer :: fsat(:) !fractional area with water table at surface
end type column_wstate_type
!----------------------------------------------------
! column carbon state variables structure
!----------------------------------------------------
type, public :: column_cstate_type
type(pft_cstate_type):: pcs_a !pft-level carbon state variables averaged to the column
! NOTE: the soilc variable is used by the original CLM C-cycle code,
! and is not used by the CN code
real(r8), pointer :: soilc(:) !soil carbon (kg C /m**2)
! BGC variables
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: soil1c(:) ! (gC/m2) soil organic matter C (fast pool)
real(r8), pointer :: soil2c(:) ! (gC/m2) soil organic matter C (medium pool)
real(r8), pointer :: soil3c(:) ! (gC/m2) soil organic matter C (slow pool)
real(r8), pointer :: soil4c(:) ! (gC/m2) soil organic matter C (slowest pool)
real(r8), pointer :: col_ctrunc(:) ! (gC/m2) column-level sink for C truncation
! pools for dynamic landcover
real(r8), pointer :: seedc(:) ! (gC/m2) column-level pool for seeding new PFTs
real(r8), pointer :: prod10c(:) ! (gC/m2) wood product C pool, 10-year lifespan
real(r8), pointer :: prod100c(:) ! (gC/m2) wood product C pool, 100-year lifespan
real(r8), pointer :: totprodc(:) ! (gC/m2) total wood product C
! summary (diagnostic) state variables, not involved in mass balance
real(r8), pointer :: totlitc(:) ! (gC/m2) total litter carbon
real(r8), pointer :: totsomc(:) ! (gC/m2) total soil organic matter carbon
real(r8), pointer :: totecosysc(:) ! (gC/m2) total ecosystem carbon, incl veg but excl cpool
real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool
end type column_cstate_type
!----------------------------------------------------
! column nitrogen state variables structure
!----------------------------------------------------
type, public :: column_nstate_type
type(pft_nstate_type):: pns_a !pft-level nitrogen state variables averaged to the column
! BGC variables
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: litr1n(:) ! (gN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (gN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (gN/m2) litter lignin N
real(r8), pointer :: soil1n(:) ! (gN/m2) soil organic matter N (fast pool)
real(r8), pointer :: soil2n(:) ! (gN/m2) soil organic matter N (medium pool)
real(r8), pointer :: soil3n(:) ! (gN/m2) soil orgainc matter N (slow pool)
real(r8), pointer :: soil4n(:) ! (gN/m2) soil orgainc matter N (slowest pool)
real(r8), pointer :: sminn(:) ! (gN/m2) soil mineral N
real(r8), pointer :: col_ntrunc(:) ! (gN/m2) column-level sink for N truncation
! wood product pools, for dynamic landcover
real(r8), pointer :: seedn(:) ! (gN/m2) column-level pool for seeding new PFTs
real(r8), pointer :: prod10n(:) ! (gN/m2) wood product N pool, 10-year lifespan
real(r8), pointer :: prod100n(:) ! (gN/m2) wood product N pool, 100-year lifespan
real(r8), pointer :: totprodn(:) ! (gN/m2) total wood product N
! summary (diagnostic) state variables, not involved in mass balance
real(r8), pointer :: totlitn(:) ! (gN/m2) total litter nitrogen
real(r8), pointer :: totsomn(:) ! (gN/m2) total soil organic matter nitrogen
real(r8), pointer :: totecosysn(:) ! (gN/m2) total ecosystem nitrogen, incl veg
real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg
end type column_nstate_type
!----------------------------------------------------
! column VOC state variables structure
!----------------------------------------------------
type, public :: column_vstate_type
type(pft_vstate_type):: pvs_a !pft-level VOC state variables averaged to the column
end type column_vstate_type
#if (defined CNDV)
!----------------------------------------------------
! column DGVM state variables structure
!----------------------------------------------------
type, public :: column_dgvstate_type
type(pft_dgvstate_type):: pdgvs_a
end type column_dgvstate_type
#endif
!----------------------------------------------------
! column dust state variables structure
!----------------------------------------------------
type, public :: column_dstate_type
real(r8), pointer :: dummy_entry(:)
end type column_dstate_type
!----------------------------------------------------
! column energy flux variables structure
!----------------------------------------------------
type, public :: column_eflux_type
type(pft_eflux_type):: pef_a ! pft-level energy flux variables averaged to the column
real(r8), pointer :: eflx_snomelt(:) ! snow melt heat flux (W/m**2)
real(r8), pointer :: eflx_snomelt_u(:) ! urban snow melt heat flux (W/m**2)
real(r8), pointer :: eflx_snomelt_r(:) ! rural snow melt heat flux (W/m**2)
real(r8), pointer :: eflx_impsoil(:) ! implicit evaporation for soil temperature equation
real(r8), pointer :: eflx_fgr12(:) ! ground heat flux between soil layers 1 and 2 (W/m2)
! Urban variable
real(r8), pointer :: eflx_building_heat(:) ! heat flux from urban building interior to urban walls, roof (W/m**2)
real(r8), pointer :: eflx_urban_ac(:) ! urban air conditioning flux (W/m**2)
real(r8), pointer :: eflx_urban_heat(:) ! urban heating flux (W/m**2)
end type column_eflux_type
!----------------------------------------------------
! column momentum flux variables structure
!----------------------------------------------------
type, public :: column_mflux_type
type(pft_mflux_type):: pmf_a ! pft-level momentum flux variables averaged to the column
end type column_mflux_type
!----------------------------------------------------
! column water flux variables structure
!----------------------------------------------------
type, public :: column_wflux_type
type(pft_wflux_type):: pwf_a ! pft-level water flux variables averaged to the column
real(r8), pointer :: qflx_infl(:) ! infiltration (mm H2O /s)
real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s)
real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s)
real(r8), pointer :: qflx_top_soil(:)! net water input into soil from top (mm/s)
real(r8), pointer :: qflx_snomelt(:) ! snow melt (mm H2O /s)
real(r8), pointer :: qflx_qrgwl(:) ! qflx_surf at glaciers, wetlands, lakes
real(r8), pointer :: qflx_runoff(:) ! total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s)
real(r8), pointer :: qflx_runoff_u(:)! Urban total runoff (qflx_drain+qflx_surf) (mm H2O /s)
real(r8), pointer :: qflx_runoff_r(:)! Rural total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s)
real(r8), pointer :: qmelt(:) ! snow melt [mm/s]
real(r8), pointer :: h2ocan_loss(:) ! mass balance correction term for dynamic weights
real(r8), pointer :: qflx_rsub_sat(:) ! soil saturation excess [mm/s]
real(r8), pointer :: flx_bc_dep_dry(:) ! dry (BCPHO+BCPHI) BC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_bc_dep_wet(:) ! wet (BCPHI) BC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_bc_dep_pho(:) ! hydrophobic BC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_bc_dep_phi(:) ! hydrophillic BC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_bc_dep(:) ! total (dry+wet) BC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_oc_dep_dry(:) ! dry (OCPHO+OCPHI) OC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_oc_dep_wet(:) ! wet (OCPHI) OC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_oc_dep_pho(:) ! hydrophobic OC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_oc_dep_phi(:) ! hydrophillic OC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_oc_dep(:) ! total (dry+wet) OC deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_dst_dep_dry1(:) ! dust species 1 dry deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_dst_dep_wet1(:) ! dust species 1 wet deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_dst_dep_dry2(:) ! dust species 2 dry deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_dst_dep_wet2(:) ! dust species 2 wet deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_dst_dep_dry3(:) ! dust species 3 dry deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_dst_dep_wet3(:) ! dust species 3 wet deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_dst_dep_dry4(:) ! dust species 4 dry deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_dst_dep_wet4(:) ! dust species 4 wet deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: flx_dst_dep(:) ! total (dry+wet) dust deposition on ground (positive definite) (col) [kg/s]
real(r8), pointer :: qflx_snofrz_lyr(:,:)! snow freezing rate (positive definite) (col,lyr) [kg m-2 s-1]
end type column_wflux_type
!----------------------------------------------------
! column carbon flux variables structure
!----------------------------------------------------
type, public :: column_cflux_type
type(pft_cflux_type):: pcf_a !pft-level carbon flux variables averaged to the column
! new variables for CN code
! column-level gap mortality fluxes
real(r8), pointer :: m_leafc_to_litr1c(:) ! leaf C mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_leafc_to_litr2c(:) ! leaf C mortality to litter 2 C (gC/m2/s)
real(r8), pointer :: m_leafc_to_litr3c(:) ! leaf C mortality to litter 3 C (gC/m2/s)
real(r8), pointer :: m_frootc_to_litr1c(:) ! fine root C mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_frootc_to_litr2c(:) ! fine root C mortality to litter 2 C (gC/m2/s)
real(r8), pointer :: m_frootc_to_litr3c(:) ! fine root C mortality to litter 3 C (gC/m2/s)
real(r8), pointer :: m_livestemc_to_cwdc(:) ! live stem C mortality to coarse woody debris C (gC/m2/s)
real(r8), pointer :: m_deadstemc_to_cwdc(:) ! dead stem C mortality to coarse woody debris C (gC/m2/s)
real(r8), pointer :: m_livecrootc_to_cwdc(:) ! live coarse root C mortality to coarse woody debris C (gC/m2/s)
real(r8), pointer :: m_deadcrootc_to_cwdc(:) ! dead coarse root C mortality to coarse woody debris C (gC/m2/s)
real(r8), pointer :: m_leafc_storage_to_litr1c(:) ! leaf C storage mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_frootc_storage_to_litr1c(:) ! fine root C storage mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_livestemc_storage_to_litr1c(:) ! live stem C storage mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_deadstemc_storage_to_litr1c(:) ! dead stem C storage mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_livecrootc_storage_to_litr1c(:) ! live coarse root C storage mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_deadcrootc_storage_to_litr1c(:) ! dead coarse root C storage mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_gresp_storage_to_litr1c(:) ! growth respiration storage mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_leafc_xfer_to_litr1c(:) ! leaf C transfer mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_frootc_xfer_to_litr1c(:) ! fine root C transfer mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_livestemc_xfer_to_litr1c(:) ! live stem C transfer mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_deadstemc_xfer_to_litr1c(:) ! dead stem C transfer mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_livecrootc_xfer_to_litr1c(:) ! live coarse root C transfer mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_deadcrootc_xfer_to_litr1c(:) ! dead coarse root C transfer mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: m_gresp_xfer_to_litr1c(:) ! growth respiration transfer mortality to litter 1 C (gC/m2/s)
! column-level harvest mortality fluxes
real(r8), pointer :: hrv_leafc_to_litr1c(:) ! leaf C harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_leafc_to_litr2c(:) ! leaf C harvest mortality to litter 2 C (gC/m2/s)
real(r8), pointer :: hrv_leafc_to_litr3c(:) ! leaf C harvest mortality to litter 3 C (gC/m2/s)
real(r8), pointer :: hrv_frootc_to_litr1c(:) ! fine root C harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_frootc_to_litr2c(:) ! fine root C harvest mortality to litter 2 C (gC/m2/s)
real(r8), pointer :: hrv_frootc_to_litr3c(:) ! fine root C harvest mortality to litter 3 C (gC/m2/s)
real(r8), pointer :: hrv_livestemc_to_cwdc(:) ! live stem C harvest mortality to coarse woody debris C (gC/m2/s)
real(r8), pointer :: hrv_deadstemc_to_prod10c(:) ! dead stem C harvest mortality to 10-year product pool (gC/m2/s)
real(r8), pointer :: hrv_deadstemc_to_prod100c(:) ! dead stem C harvest mortality to 100-year product pool (gC/m2/s)
real(r8), pointer :: hrv_livecrootc_to_cwdc(:) ! live coarse root C harvest mortality to coarse woody debris C (gC/m2/s)
real(r8), pointer :: hrv_deadcrootc_to_cwdc(:) ! dead coarse root C harvest mortality to coarse woody debris C (gC/m2/s)
real(r8), pointer :: hrv_leafc_storage_to_litr1c(:) ! leaf C storage harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_frootc_storage_to_litr1c(:) ! fine root C storage harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_livestemc_storage_to_litr1c(:) ! live stem C storage harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_deadstemc_storage_to_litr1c(:) ! dead stem C storage harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_livecrootc_storage_to_litr1c(:) ! live coarse root C storage harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_deadcrootc_storage_to_litr1c(:) ! dead coarse root C storage harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_gresp_storage_to_litr1c(:) ! growth respiration storage harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_leafc_xfer_to_litr1c(:) ! leaf C transfer harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_frootc_xfer_to_litr1c(:) ! fine root C transfer harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_livestemc_xfer_to_litr1c(:) ! live stem C transfer harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_deadstemc_xfer_to_litr1c(:) ! dead stem C transfer harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_livecrootc_xfer_to_litr1c(:) ! live coarse root C transfer harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_deadcrootc_xfer_to_litr1c(:) ! dead coarse root C transfer harvest mortality to litter 1 C (gC/m2/s)
real(r8), pointer :: hrv_gresp_xfer_to_litr1c(:) ! growth respiration transfer harvest mortality to litter 1 C (gC/m2/s)
! column-level fire fluxes
real(r8), pointer :: m_deadstemc_to_cwdc_fire(:) ! dead stem C to coarse woody debris C by fire (gC/m2/s)
real(r8), pointer :: m_deadcrootc_to_cwdc_fire(:) ! dead coarse root C to to woody debris C by fire (gC/m2/s)
real(r8), pointer :: m_litr1c_to_fire(:) ! litter 1 C fire loss (gC/m2/s)
real(r8), pointer :: m_litr2c_to_fire(:) ! litter 2 C fire loss (gC/m2/s)
real(r8), pointer :: m_litr3c_to_fire(:) ! litter 3 C fire loss (gC/m2/s)
real(r8), pointer :: m_cwdc_to_fire(:) ! coarse woody debris C fire loss (gC/m2/s)
! litterfall fluxes
#if (defined CROP)
real(r8), pointer :: grainc_to_litr1c(:) ! grain C litterfall to litter 1 C (gC/m2/s)
real(r8), pointer :: grainc_to_litr2c(:) ! grain C litterfall to litter 2 C (gC/m2/s)
real(r8), pointer :: grainc_to_litr3c(:) ! grain C litterfall to litter 3 C (gC/m2/s)
real(r8), pointer :: livestemc_to_litr1c(:) ! livestem C litterfall to litter 1 C (gC/m2/s)
real(r8), pointer :: livestemc_to_litr2c(:) ! livestem C litterfall to litter 2 C (gC/m2/s)
real(r8), pointer :: livestemc_to_litr3c(:) ! livestem C litterfall to litter 3 C (gC/m2/s)
#endif
real(r8), pointer :: leafc_to_litr1c(:) ! leaf C litterfall to litter 1 C (gC/m2/s)
real(r8), pointer :: leafc_to_litr2c(:) ! leaf C litterfall to litter 2 C (gC/m2/s)
real(r8), pointer :: leafc_to_litr3c(:) ! leaf C litterfall to litter 3 C (gC/m2/s)
real(r8), pointer :: frootc_to_litr1c(:) ! fine root C litterfall to litter 1 C (gC/m2/s)
real(r8), pointer :: frootc_to_litr2c(:) ! fine root C litterfall to litter 2 C (gC/m2/s)
real(r8), pointer :: frootc_to_litr3c(:) ! fine root C litterfall to litter 3 C (gC/m2/s)
! decomposition fluxes
real(r8), pointer :: cwdc_to_litr2c(:) ! decomp. of coarse woody debris C to litter 2 C (gC/m2/s)
real(r8), pointer :: cwdc_to_litr3c(:) ! decomp. of coarse woody debris C to litter 3 C (gC/m2/s)
real(r8), pointer :: litr1_hr(:) ! het. resp. from litter 1 C (gC/m2/s)
real(r8), pointer :: litr1c_to_soil1c(:) ! decomp. of litter 1 C to SOM 1 C (gC/m2/s)
real(r8), pointer :: litr2_hr(:) ! het. resp. from litter 2 C (gC/m2/s)
real(r8), pointer :: litr2c_to_soil2c(:) ! decomp. of litter 2 C to SOM 2 C (gC/m2/s)
real(r8), pointer :: litr3_hr(:) ! het. resp. from litter 3 C (gC/m2/s)
real(r8), pointer :: litr3c_to_soil3c(:) ! decomp. of litter 3 C to SOM 3 C (gC/m2/s)
real(r8), pointer :: soil1_hr(:) ! het. resp. from SOM 1 C (gC/m2/s)
real(r8), pointer :: soil1c_to_soil2c(:) ! decomp. of SOM 1 C to SOM 2 C (gC/m2/s)
real(r8), pointer :: soil2_hr(:) ! het. resp. from SOM 2 C (gC/m2/s)
real(r8), pointer :: soil2c_to_soil3c(:) ! decomp. of SOM 2 C to SOM 3 C (gC/m2/s)
real(r8), pointer :: soil3_hr(:) ! het. resp. from SOM 3 C (gC/m2/s)
real(r8), pointer :: soil3c_to_soil4c(:) ! decomp. of SOM 3 C to SOM 4 C (gC/m2/s)
real(r8), pointer :: soil4_hr(:) ! het. resp. from SOM 4 C (gC/m2/s)
! dynamic landcover fluxes
#ifdef CN
real(r8), pointer :: dwt_seedc_to_leaf(:) ! (gC/m2/s) seed source to PFT-level
real(r8), pointer :: dwt_seedc_to_deadstem(:) ! (gC/m2/s) seed source to PFT-level
real(r8), pointer :: dwt_conv_cflux(:) ! (gC/m2/s) conversion C flux (immediate loss to atm)
real(r8), pointer :: dwt_prod10c_gain(:) ! (gC/m2/s) addition to 10-yr wood product pool
real(r8), pointer :: dwt_prod100c_gain(:) ! (gC/m2/s) addition to 100-yr wood product pool
real(r8), pointer :: dwt_frootc_to_litr1c(:) ! (gC/m2/s) fine root to litter due to landcover change
real(r8), pointer :: dwt_frootc_to_litr2c(:) ! (gC/m2/s) fine root to litter due to landcover change
real(r8), pointer :: dwt_frootc_to_litr3c(:) ! (gC/m2/s) fine root to litter due to landcover change
real(r8), pointer :: dwt_livecrootc_to_cwdc(:) ! (gC/m2/s) live coarse root to CWD due to landcover change
real(r8), pointer :: dwt_deadcrootc_to_cwdc(:) ! (gC/m2/s) dead coarse root to CWD due to landcover change
real(r8), pointer :: dwt_closs(:) ! (gC/m2/s) total carbon loss from product pools and conversion
real(r8), pointer :: landuseflux(:) ! (gC/m2/s) dwt_closs+product_closs
real(r8), pointer :: landuptake(:) ! (gC/m2/s) nee-landuseflux
! wood product pool loss fluxes
real(r8), pointer :: prod10c_loss(:) ! (gC/m2/s) decomposition loss from 10-yr wood product pool
real(r8), pointer :: prod100c_loss(:) ! (gC/m2/s) decomposition loss from 100-yr wood product pool
real(r8), pointer :: product_closs(:) ! (gC/m2/s) total wood product carbon loss
#endif
! summary (diagnostic) flux variables, not involved in mass balance
real(r8), pointer :: lithr(:) ! (gC/m2/s) litter heterotrophic respiration
real(r8), pointer :: somhr(:) ! (gC/m2/s) soil organic matter heterotrophic respiration
real(r8), pointer :: hr(:) ! (gC/m2/s) total heterotrophic respiration
real(r8), pointer :: sr(:) ! (gC/m2/s) total soil respiration (HR + root resp)
real(r8), pointer :: er(:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic
real(r8), pointer :: litfire(:) ! (gC/m2/s) litter fire losses
real(r8), pointer :: somfire(:) ! (gC/m2/s) soil organic matter fire losses
real(r8), pointer :: totfire(:) ! (gC/m2/s) total ecosystem fire losses
real(r8), pointer :: nep(:) ! (gC/m2/s) net ecosystem production, excludes fire, landuse, and harvest flux, positive for sink
real(r8), pointer :: nbp(:) ! (gC/m2/s) net biome production, includes fire, landuse, and harvest flux, positive for sink
real(r8), pointer :: nee(:) ! (gC/m2/s) net ecosystem exchange of carbon, includes fire, landuse, harvest, and hrv_xsmrpool flux, positive for source
real(r8), pointer :: col_cinputs(:) ! (gC/m2/s) total column-level carbon inputs (for balance check)
real(r8), pointer :: col_coutputs(:) ! (gC/m2/s) total column-level carbon outputs (for balance check)
#if (defined CLAMP) && (defined CN)
! CLAMP summary (diagnostic) flux variables, not involved in mass balance
real(r8), pointer :: cwdc_hr(:) ! (gC/m2/s) col-level coarse woody debris C heterotrophic respiration
real(r8), pointer :: cwdc_loss(:) ! (gC/m2/s) col-level coarse woody debris C loss
real(r8), pointer :: litterc_loss(:) ! (gC/m2/s) col-level litter C loss
#endif
! new variables for fire
real(r8), pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss
end type column_cflux_type
!----------------------------------------------------
! column nitrogen flux variables structure
!----------------------------------------------------
type, public :: column_nflux_type
type(pft_nflux_type):: pnf_a !pft-level nitrogen flux variables averaged to the column
! new variables for CN code
! deposition fluxes
real(r8), pointer :: ndep_to_sminn(:) ! atmospheric N deposition to soil mineral N (gN/m2/s)
real(r8), pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s)
! column-level gap mortality fluxes
real(r8), pointer :: m_leafn_to_litr1n(:) ! leaf N mortality to litter 1 N (gC/m2/s)
real(r8), pointer :: m_leafn_to_litr2n(:) ! leaf N mortality to litter 2 N (gC/m2/s)
real(r8), pointer :: m_leafn_to_litr3n(:) ! leaf N mortality to litter 3 N (gC/m2/s)
real(r8), pointer :: m_frootn_to_litr1n(:) ! fine root N mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_frootn_to_litr2n(:) ! fine root N mortality to litter 2 N (gN/m2/s)
real(r8), pointer :: m_frootn_to_litr3n(:) ! fine root N mortality to litter 3 N (gN/m2/s)
real(r8), pointer :: m_livestemn_to_cwdn(:) ! live stem N mortality to coarse woody debris N (gN/m2/s)
real(r8), pointer :: m_deadstemn_to_cwdn(:) ! dead stem N mortality to coarse woody debris N (gN/m2/s)
real(r8), pointer :: m_livecrootn_to_cwdn(:) ! live coarse root N mortality to coarse woody debris N (gN/m2/s)
real(r8), pointer :: m_deadcrootn_to_cwdn(:) ! dead coarse root N mortality to coarse woody debris N (gN/m2/s)
real(r8), pointer :: m_retransn_to_litr1n(:) ! retranslocated N pool mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_leafn_storage_to_litr1n(:) ! leaf N storage mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_frootn_storage_to_litr1n(:) ! fine root N storage mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_livestemn_storage_to_litr1n(:) ! live stem N storage mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_deadstemn_storage_to_litr1n(:) ! dead stem N storage mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_livecrootn_storage_to_litr1n(:) ! live coarse root N storage mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_deadcrootn_storage_to_litr1n(:) ! dead coarse root N storage mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_leafn_xfer_to_litr1n(:) ! leaf N transfer mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_frootn_xfer_to_litr1n(:) ! fine root N transfer mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_livestemn_xfer_to_litr1n(:) ! live stem N transfer mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_deadstemn_xfer_to_litr1n(:) ! dead stem N transfer mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_livecrootn_xfer_to_litr1n(:) ! live coarse root N transfer mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: m_deadcrootn_xfer_to_litr1n(:) ! dead coarse root N transfer mortality to litter 1 N (gN/m2/s)
! column-level harvest fluxes
real(r8), pointer :: hrv_leafn_to_litr1n(:) ! leaf N harvest mortality to litter 1 N (gC/m2/s)
real(r8), pointer :: hrv_leafn_to_litr2n(:) ! leaf N harvest mortality to litter 2 N (gC/m2/s)
real(r8), pointer :: hrv_leafn_to_litr3n(:) ! leaf N harvest mortality to litter 3 N (gC/m2/s)
real(r8), pointer :: hrv_frootn_to_litr1n(:) ! fine root N harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_frootn_to_litr2n(:) ! fine root N harvest mortality to litter 2 N (gN/m2/s)
real(r8), pointer :: hrv_frootn_to_litr3n(:) ! fine root N harvest mortality to litter 3 N (gN/m2/s)
real(r8), pointer :: hrv_livestemn_to_cwdn(:) ! live stem N harvest mortality to coarse woody debris N (gN/m2/s)
real(r8), pointer :: hrv_deadstemn_to_prod10n(:) ! dead stem N harvest mortality to 10-year product pool (gN/m2/s)
real(r8), pointer :: hrv_deadstemn_to_prod100n(:) ! dead stem N harvest mortality to 100-year product pool (gN/m2/s)
real(r8), pointer :: hrv_livecrootn_to_cwdn(:) ! live coarse root N harvest mortality to coarse woody debris N (gN/m2/s)
real(r8), pointer :: hrv_deadcrootn_to_cwdn(:) ! dead coarse root N harvest mortality to coarse woody debris N (gN/m2/s)
real(r8), pointer :: hrv_retransn_to_litr1n(:) ! retranslocated N pool harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_leafn_storage_to_litr1n(:) ! leaf N storage harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_frootn_storage_to_litr1n(:) ! fine root N storage harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_livestemn_storage_to_litr1n(:) ! live stem N storage harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_deadstemn_storage_to_litr1n(:) ! dead stem N storage harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_livecrootn_storage_to_litr1n(:) ! live coarse root N storage harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_deadcrootn_storage_to_litr1n(:) ! dead coarse root N storage harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_leafn_xfer_to_litr1n(:) ! leaf N transfer harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_frootn_xfer_to_litr1n(:) ! fine root N transfer harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_livestemn_xfer_to_litr1n(:) ! live stem N transfer harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_deadstemn_xfer_to_litr1n(:) ! dead stem N transfer harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_livecrootn_xfer_to_litr1n(:) ! live coarse root N transfer harvest mortality to litter 1 N (gN/m2/s)
real(r8), pointer :: hrv_deadcrootn_xfer_to_litr1n(:) ! dead coarse root N transfer harvest mortality to litter 1 N (gN/m2/s)
! column-level fire fluxes
real(r8), pointer :: m_deadstemn_to_cwdn_fire(:) ! dead stem N to coarse woody debris N by fire (gN/m2/s)
real(r8), pointer :: m_deadcrootn_to_cwdn_fire(:) ! dead coarse root N to to woody debris N by fire (gN/m2/s)
real(r8), pointer :: m_litr1n_to_fire(:) ! litter 1 N fire loss (gN/m2/s)
real(r8), pointer :: m_litr2n_to_fire(:) ! litter 2 N fire loss (gN/m2/s)
real(r8), pointer :: m_litr3n_to_fire(:) ! litter 3 N fire loss (gN/m2/s)
real(r8), pointer :: m_cwdn_to_fire(:) ! coarse woody debris N fire loss (gN/m2/s)
! litterfall fluxes
#if (defined CROP)
real(r8), pointer :: livestemn_to_litr1n(:) ! livestem N litterfall to litter 1 N (gN/m2/s)
real(r8), pointer :: livestemn_to_litr2n(:) ! livestem N litterfall to litter 2 N (gN/m2/s)
real(r8), pointer :: livestemn_to_litr3n(:) ! livestem N litterfall to litter 3 N (gN/m2/s)
real(r8), pointer :: grainn_to_litr1n(:) ! grain N litterfall to litter 1 N (gN/m2/s)
real(r8), pointer :: grainn_to_litr2n(:) ! grain N litterfall to litter 2 N (gN/m2/s)
real(r8), pointer :: grainn_to_litr3n(:) ! grain N litterfall to litter 3 N (gN/m2/s)
#endif
real(r8), pointer :: leafn_to_litr1n(:) ! leaf N litterfall to litter 1 N (gN/m2/s)
real(r8), pointer :: leafn_to_litr2n(:) ! leaf N litterfall to litter 2 N (gN/m2/s)
real(r8), pointer :: leafn_to_litr3n(:) ! leaf N litterfall to litter 3 N (gN/m2/s)
real(r8), pointer :: frootn_to_litr1n(:) ! fine root N litterfall to litter 1 N (gN/m2/s)
real(r8), pointer :: frootn_to_litr2n(:) ! fine root N litterfall to litter 2 N (gN/m2/s)
real(r8), pointer :: frootn_to_litr3n(:) ! fine root N litterfall to litter 3 N (gN/m2/s)
! decomposition fluxes
real(r8), pointer :: cwdn_to_litr2n(:) ! decomp. of coarse woody debris N to litter 2 N (gN/m2/s)
real(r8), pointer :: cwdn_to_litr3n(:) ! decomp. of coarse woody debris N to litter 3 N (gN/m2/s)
real(r8), pointer :: litr1n_to_soil1n(:) ! decomp. of litter 1 N to SOM 1 N (gN/m2/s)
real(r8), pointer :: sminn_to_soil1n_l1(:) ! mineral N flux for decomp. of litter 1 to SOM 1 (gN/m2/s)
real(r8), pointer :: litr2n_to_soil2n(:) ! decomp. of litter 2 N to SOM 2 N (gN/m2/s)
real(r8), pointer :: sminn_to_soil2n_l2(:) ! mineral N flux for decomp. of litter 2 to SOM 2 (gN/m2/s)
real(r8), pointer :: litr3n_to_soil3n(:) ! decomp. of litter 3 N to SOM 3 N (gN/m2/s)
real(r8), pointer :: sminn_to_soil3n_l3(:) ! mineral N flux for decomp. of litter 3 to SOM 3 (gN/m2/s)
real(r8), pointer :: soil1n_to_soil2n(:) ! decomp. of SOM 1 N to SOM 2 N (gN/m2/s)
real(r8), pointer :: sminn_to_soil2n_s1(:) ! mineral N flux for decomp. of SOM 1 to SOM 2 (gN/m2/s)
real(r8), pointer :: soil2n_to_soil3n(:) ! decomp. of SOM 2 N to SOM 3 N (gN/m2/s)
real(r8), pointer :: sminn_to_soil3n_s2(:) ! mineral N flux for decomp. of SOM 2 to SOM 3 (gN/m2/s)
real(r8), pointer :: soil3n_to_soil4n(:) ! decomp. of SOM 3 N to SOM 4 N (gN/m2/s)
real(r8), pointer :: sminn_to_soil4n_s3(:) ! mineral N flux for decomp. of SOM 3 to SOM 4 (gN/m2/s)
real(r8), pointer :: soil4n_to_sminn(:) ! N mineralization for decomp. of SOM 4 (gN/m2/s)
! denitrification fluxes
real(r8), pointer :: sminn_to_denit_l1s1(:) ! denitrification for decomp. of litter 1 to SOM 1 (gN/m2/s)
real(r8), pointer :: sminn_to_denit_l2s2(:) ! denitrification for decomp. of litter 2 to SOM 2 (gN/m2/s)
real(r8), pointer :: sminn_to_denit_l3s3(:) ! denitrification for decomp. of litter 3 to SOM 3 (gN/m2/s)
real(r8), pointer :: sminn_to_denit_s1s2(:) ! denitrification for decomp. of SOM 1 to SOM 2 (gN/m2/s)
real(r8), pointer :: sminn_to_denit_s2s3(:) ! denitrification for decomp. of SOM 2 to SOM 3 (gN/m2/s)
real(r8), pointer :: sminn_to_denit_s3s4(:) ! denitrification for decomp. of SOM 3 to SOM 4 (gN/m2/s)
real(r8), pointer :: sminn_to_denit_s4(:) ! denitrification for decomp. of SOM 4 (gN/m2/s)
real(r8), pointer :: sminn_to_denit_excess(:) ! denitrification from excess mineral N pool (gN/m2/s)
! leaching fluxes
real(r8), pointer :: sminn_leached(:) ! soil mineral N pool loss to leaching (gN/m2/s)
! dynamic landcover fluxes
real(r8), pointer :: dwt_seedn_to_leaf(:) ! (gN/m2/s) seed source to PFT-level
real(r8), pointer :: dwt_seedn_to_deadstem(:) ! (gN/m2/s) seed source to PFT-level
real(r8), pointer :: dwt_conv_nflux(:) ! (gN/m2/s) conversion N flux (immediate loss to atm)
real(r8), pointer :: dwt_prod10n_gain(:) ! (gN/m2/s) addition to 10-yr wood product pool
real(r8), pointer :: dwt_prod100n_gain(:) ! (gN/m2/s) addition to 100-yr wood product pool
real(r8), pointer :: dwt_frootn_to_litr1n(:) ! (gN/m2/s) fine root to litter due to landcover change
real(r8), pointer :: dwt_frootn_to_litr2n(:) ! (gN/m2/s) fine root to litter due to landcover change
real(r8), pointer :: dwt_frootn_to_litr3n(:) ! (gN/m2/s) fine root to litter due to landcover change
real(r8), pointer :: dwt_livecrootn_to_cwdn(:) ! (gN/m2/s) live coarse root to CWD due to landcover change
real(r8), pointer :: dwt_deadcrootn_to_cwdn(:) ! (gN/m2/s) dead coarse root to CWD due to landcover change
real(r8), pointer :: dwt_nloss(:) ! (gN/m2/s) total nitrogen loss from product pools and conversion
! wood product pool loss fluxes
real(r8), pointer :: prod10n_loss(:) ! (gN/m2/s) decomposition loss from 10-yr wood product pool
real(r8), pointer :: prod100n_loss(:) ! (gN/m2/s) decomposition loss from 100-yr wood product pool
real(r8), pointer :: product_nloss(:) ! (gN/m2/s) total wood product nitrogen loss
! summary (diagnostic) flux variables, not involved in mass balance
real(r8), pointer :: potential_immob(:) ! potential N immobilization (gN/m2/s)
real(r8), pointer :: actual_immob(:) ! actual N immobilization (gN/m2/s)
real(r8), pointer :: sminn_to_plant(:) ! plant uptake of soil mineral N (gN/m2/s)
real(r8), pointer :: supplement_to_sminn(:) ! supplemental N supply (gN/m2/s)
real(r8), pointer :: gross_nmin(:) ! gross rate of N mineralization (gN/m2/s)
real(r8), pointer :: net_nmin(:) ! net rate of N mineralization (gN/m2/s)
real(r8), pointer :: denit(:) ! total rate of denitrification (gN/m2/s)
real(r8), pointer :: col_ninputs(:) ! column-level N inputs (gN/m2/s)
real(r8), pointer :: col_noutputs(:) ! column-level N outputs (gN/m2/s)
! new variables for fire
real(r8), pointer :: col_fire_nloss(:) ! total column-level fire N loss (gN/m2/s)
end type column_nflux_type
!----------------------------------------------------
! column VOC flux variables structure
!----------------------------------------------------
type, public :: column_vflux_type
type(pft_vflux_type):: pvf_a !pft-level VOC flux variables averaged to the column
end type column_vflux_type
!----------------------------------------------------
! column dust flux variables structure
!----------------------------------------------------
type, public :: column_dflux_type
type(pft_dflux_type):: pdf_a !pft-level dust flux variables averaged to the column
end type column_dflux_type
!----------------------------------------------------
! End definition of structures defined at the column_type level
!----------------------------------------------------
!*******************************************************************************
!*******************************************************************************
!----------------------------------------------------
! Begin definition of structures defined at the landunit_type level
!----------------------------------------------------
! landunit physical state variables structure
! note - landunit type can be vegetated (includes bare soil), deep lake,
! shallow lake, wetland, glacier or urban
!----------------------------------------------------
type, public :: landunit_pstate_type
type(column_pstate_type):: cps_a !column-level physical state variables averaged to landunit
! Urban variables
real(r8), pointer :: t_building(:) ! internal building temperature (K)
real(r8), pointer :: t_building_max(:) ! maximum internal building temperature (K)
real(r8), pointer :: t_building_min(:) ! minimum internal building temperature (K)
real(r8), pointer :: tk_wall(:,:) ! thermal conductivity of urban wall (W/m/K)
real(r8), pointer :: tk_roof(:,:) ! thermal conductivity of urban roof (W/m/K)
real(r8), pointer :: tk_improad(:,:) ! thermal conductivity of urban impervious road (W/m/K)
real(r8), pointer :: cv_wall(:,:) ! heat capacity of urban wall (J/m^3/K)
real(r8), pointer :: cv_roof(:,:) ! heat capacity of urban roof (J/m^3/K)
real(r8), pointer :: cv_improad(:,:) ! heat capacity of urban impervious road (J/m^3/K)
real(r8), pointer :: thick_wall(:) ! total thickness of urban wall (m)
real(r8), pointer :: thick_roof(:) ! total thickness of urban roof (m)
integer, pointer :: nlev_improad(:) ! number of impervious road layers (-)
real(r8), pointer :: vf_sr(:) ! view factor of sky for road
real(r8), pointer :: vf_wr(:) ! view factor of one wall for road
real(r8), pointer :: vf_sw(:) ! view factor of sky for one wall
real(r8), pointer :: vf_rw(:) ! view factor of road for one wall
real(r8), pointer :: vf_ww(:) ! view factor of opposing wall for one wall
real(r8), pointer :: taf(:) ! urban canopy air temperature (K)
real(r8), pointer :: qaf(:) ! urban canopy air specific humidity (kg/kg)
real(r8), pointer :: sabs_roof_dir(:,:) ! direct solar absorbed by roof per unit ground area per unit incident flux
real(r8), pointer :: sabs_roof_dif(:,:) ! diffuse solar absorbed by roof per unit ground area per unit incident flux
real(r8), pointer :: sabs_sunwall_dir(:,:) ! direct solar absorbed by sunwall per unit wall area per unit incident flux
real(r8), pointer :: sabs_sunwall_dif(:,:) ! diffuse solar absorbed by sunwall per unit wall area per unit incident flux
real(r8), pointer :: sabs_shadewall_dir(:,:) ! direct solar absorbed by shadewall per unit wall area per unit incident flux
real(r8), pointer :: sabs_shadewall_dif(:,:) ! diffuse solar absorbed by shadewall per unit wall area per unit incident flux
real(r8), pointer :: sabs_improad_dir(:,:) ! direct solar absorbed by impervious road per unit ground area per unit incident flux
real(r8), pointer :: sabs_improad_dif(:,:) ! diffuse solar absorbed by impervious road per unit ground area per unit incident flux
real(r8), pointer :: sabs_perroad_dir(:,:) ! direct solar absorbed by pervious road per unit ground area per unit incident flux
real(r8), pointer :: sabs_perroad_dif(:,:) ! diffuse solar absorbed by pervious road per unit ground area per unit incident flux
end type landunit_pstate_type
!----------------------------------------------------
! landunit energy state variables structure
!----------------------------------------------------
type, public :: landunit_estate_type
type(column_estate_type):: ces_a !column-level energy state variables averaged to landunit
end type landunit_estate_type
!----------------------------------------------------
! landunit water state variables structure
!----------------------------------------------------
type, public :: landunit_wstate_type
type(column_wstate_type):: cws_a !column-level water state variables averaged to landunit
end type landunit_wstate_type
!----------------------------------------------------
! landunit carbon state variables structure
!----------------------------------------------------
type, public :: landunit_cstate_type
type(column_cstate_type):: ccs_a !column-level carbon state variables averaged to landunit
end type landunit_cstate_type
!----------------------------------------------------
! landunit nitrogen state variables structure
!----------------------------------------------------
type, public :: landunit_nstate_type
type(column_nstate_type):: cns_a !column-level nitrogen state variables averaged to landunit
end type landunit_nstate_type
!----------------------------------------------------
! landunit VOC state variables structure
!----------------------------------------------------
type, public :: landunit_vstate_type
real(r8):: dummy_entry
end type landunit_vstate_type
!----------------------------------------------------
! landunit DGVM state variables structure
!----------------------------------------------------
type, public :: landunit_dgvstate_type
real(r8):: dummy_entry
end type landunit_dgvstate_type
!----------------------------------------------------
! landunit dust state variables structure
!----------------------------------------------------
type, public :: landunit_dstate_type
type(column_dstate_type):: cds_a !column-level dust state variables averaged to landunit
end type landunit_dstate_type
!----------------------------------------------------
! landunit energy flux variables structure
!----------------------------------------------------
type, public :: landunit_eflux_type
type(column_eflux_type):: cef_a ! column-level energy flux variables averaged to landunit
! Urban variables
real(r8), pointer :: eflx_traffic_factor(:) ! multiplicative traffic factor for sensible heat flux from urban traffic (-)
real(r8), pointer :: eflx_traffic(:) ! traffic sensible heat flux (W/m**2)
real(r8), pointer :: eflx_wasteheat(:) ! sensible heat flux from domestic heating/cooling sources of waste heat (W/m**2)
real(r8), pointer :: eflx_heat_from_ac(:) ! sensible heat flux to be put back into canyon due to removal by AC (W/m**2)
end type landunit_eflux_type
!----------------------------------------------------
! landunit momentum flux variables structure
!----------------------------------------------------
type, public :: landunit_mflux_type
type(pft_mflux_type):: pmf_a !pft-level momentum flux variables averaged to landunit
end type landunit_mflux_type
!----------------------------------------------------
! landunit water flux variables structure
!----------------------------------------------------
type, public :: landunit_wflux_type
type(column_wflux_type):: cwf_a !column-level water flux variables averaged to landunit
end type landunit_wflux_type
!----------------------------------------------------
! landunit carbon flux variables structure
!----------------------------------------------------
type, public :: landunit_cflux_type
type(column_cflux_type):: ccf_a !column-level carbon flux variables averaged to landunit
end type landunit_cflux_type
!----------------------------------------------------
! landunit nitrogen flux variables structure
!----------------------------------------------------
type, public :: landunit_nflux_type
type(column_nflux_type):: cnf_a !column-level nitrogen flux variables averaged to landunit
end type landunit_nflux_type
!----------------------------------------------------
! landunit VOC flux variables structure
!----------------------------------------------------
type, public :: landunit_vflux_type
type(pft_vflux_type):: pvf_a !pft-level VOC flux variables averaged to landunit
end type landunit_vflux_type
!----------------------------------------------------
! landunit dust flux variables structure
!----------------------------------------------------
type, public :: landunit_dflux_type
type(pft_dflux_type):: pdf_a !pft-level dust flux variables averaged to landunit
end type landunit_dflux_type
!----------------------------------------------------
! End definition of structures defined at the landunit_type level
!----------------------------------------------------
!*******************************************************************************
!*******************************************************************************
!----------------------------------------------------
! Begin definition of structures defined at the gridcell_type level
!----------------------------------------------------
! gridcell physical state variables structure
!----------------------------------------------------
type, public :: gridcell_pstate_type
type(column_pstate_type):: cps_a !column-level physical state variables averaged to gridcell
end type gridcell_pstate_type
!----------------------------------------------------
! gridcell energy state variables structure
!----------------------------------------------------
type, public :: gridcell_estate_type
type(column_estate_type):: ces_a !column-level energy state variables averaged to gridcell
real(r8), pointer :: gc_heat1(:) ! initial gridcell total heat content
real(r8), pointer :: gc_heat2(:) ! post land cover change total heat content
end type gridcell_estate_type
!----------------------------------------------------
! gridcell water state variables structure
!----------------------------------------------------
type, public :: gridcell_wstate_type
type(column_wstate_type):: cws_a !column-level water state variables averaged to gridcell
real(r8), pointer :: gc_liq1(:) ! initial gridcell total h2o liq content
real(r8), pointer :: gc_liq2(:) ! post land cover change total liq content
real(r8), pointer :: gc_ice1(:) ! initial gridcell total h2o liq content
real(r8), pointer :: gc_ice2(:) ! post land cover change total ice content
end type gridcell_wstate_type
!----------------------------------------------------
! gridcell carbon state variables structure
!----------------------------------------------------
type, public :: gridcell_cstate_type
type(column_cstate_type):: ccs_a !column-level carbon state variables averaged to gridcell
end type gridcell_cstate_type
!----------------------------------------------------
! gridcell nitrogen state variables structure
!----------------------------------------------------
type, public :: gridcell_nstate_type
type(column_nstate_type):: cns_a !column-level nitrogen state variables averaged to gridcell
end type gridcell_nstate_type
!----------------------------------------------------
! gridcell VOC state variables structure
!----------------------------------------------------
type, public :: gridcell_vstate_type
type(column_vstate_type):: cvs_a !column-level VOC state variables averaged to gridcell
end type gridcell_vstate_type
!----------------------------------------------------
! gridcell VOC emission factor variables structure (heald)
!----------------------------------------------------
type, public :: gridcell_efstate_type
real(r8), pointer :: efisop(:,:) ! isoprene emission factors
end type gridcell_efstate_type
!----------------------------------------------------
! gridcell dust state variables structure
!----------------------------------------------------
type, public :: gridcell_dstate_type
type(column_dstate_type):: cds_a !column-level dust state variables averaged to gridcell
end type gridcell_dstate_type
#if (defined CNDV)
!----------------------------------------------------
! gridcell DGVM state variables structure
!----------------------------------------------------
type, public :: gridcell_dgvstate_type
real(r8), pointer :: agdd20(:) !20-yr running mean of agdd
real(r8), pointer :: tmomin20(:) !20-yr running mean of tmomin
real(r8), pointer :: t10min(:) !ann minimum of 10-day running mean (K)
end type gridcell_dgvstate_type
#endif
!----------------------------------------------------
! gridcell energy flux variables structure
!----------------------------------------------------
type, public :: gridcell_eflux_type
type(column_eflux_type):: cef_a !column-level energy flux variables averaged to gridcell
real(r8), pointer :: eflx_sh_totg(:) ! total grid-level sensible heat flux
real(r8), pointer :: eflx_dynbal(:) ! dynamic land cover change conversion energy flux
end type gridcell_eflux_type
!----------------------------------------------------
! gridcell momentum flux variables structure
!-- -------------------------------------------------
type, public :: gridcell_mflux_type
type(pft_mflux_type):: pmf_a !pft-level momentum flux variables averaged to gridcell
end type gridcell_mflux_type
!----------------------------------------------------
! gridcell water flux variables structure
!----------------------------------------------------
type, public :: gridcell_wflux_type
type(column_wflux_type):: cwf_a !column-level water flux variables averaged to gridcell
real(r8), pointer :: qflx_runoffg(:) ! total grid-level liq runoff
real(r8), pointer :: qflx_snwcp_iceg(:) ! total grid-level ice runoff
real(r8), pointer :: qflx_liq_dynbal(:) ! liq dynamic land cover change conversion runoff flux
real(r8), pointer :: qflx_ice_dynbal(:) ! ice dynamic land cover change conversion runoff flux
end type gridcell_wflux_type
!----------------------------------------------------
! gridcell carbon flux variables structure
!----------------------------------------------------
type, public :: gridcell_cflux_type
type(column_cflux_type):: ccf_a !column-level carbon flux variables averaged to gridcell
end type gridcell_cflux_type
!----------------------------------------------------
! gridcell nitrogen flux variables structure
!----------------------------------------------------
type, public :: gridcell_nflux_type
type(column_nflux_type):: cnf_a !column-level nitrogen flux variables averaged to gridcell
end type gridcell_nflux_type
!----------------------------------------------------
! gridcell VOC flux variables structure
!----------------------------------------------------
type, public :: gridcell_vflux_type
type(pft_vflux_type):: pvf_a !pft-level VOC flux variables averaged to gridcell
end type gridcell_vflux_type
!----------------------------------------------------
! gridcell dust flux variables structure
!----------------------------------------------------
type, public :: gridcell_dflux_type
type(pft_dflux_type):: pdf_a !pft-level dust flux variables averaged to gridcell
end type gridcell_dflux_type
!----------------------------------------------------
! End definition of structures defined at the gridcell_type level
!----------------------------------------------------
!*******************************************************************************
!*******************************************************************************
!----------------------------------------------------
! Begin definition of structures defined at the CLM level
!----------------------------------------------------
! CLM physical state variables structure
!----------------------------------------------------
type, public :: model_pstate_type
type(column_pstate_type) :: cps_a !column-level physical state variables globally averaged
end type model_pstate_type
!----------------------------------------------------
! CLM energy state variables structure
!----------------------------------------------------
type, public :: model_estate_type
type(column_estate_type):: ces_a !column-level energy state variables globally averaged
end type model_estate_type
!----------------------------------------------------
! CLM water state variables structure
!----------------------------------------------------
type, public :: model_wstate_type
type(column_wstate_type):: cws_a !column-level water state variables globally averaged
end type model_wstate_type
!----------------------------------------------------
! CLM carbon state variables structure
!----------------------------------------------------
type, public :: model_cstate_type
type(column_cstate_type):: ccs_a !column-level carbon state variables globally averaged
end type model_cstate_type
!----------------------------------------------------
! CLM nitrogen state variables structure
!----------------------------------------------------
type, public :: model_nstate_type
type(column_nstate_type):: cns_a !column-level nitrogen state variables globally averaged
end type model_nstate_type
!----------------------------------------------------
! CLM VOC state variables structure
!----------------------------------------------------
type, public :: model_vstate_type
type(column_vstate_type):: cvs_a !column-level VOC state variables globally averaged
end type model_vstate_type
!----------------------------------------------------
! CLM dust state variables structure
!----------------------------------------------------
type, public :: model_dstate_type
type(column_dstate_type):: cds_a !column-level dust state variables globally averaged
end type model_dstate_type
!----------------------------------------------------
! CLM energy flux variables structure
!----------------------------------------------------
type, public :: model_eflux_type
type(column_eflux_type):: cef_a !column-level energy flux variables globally averaged
end type model_eflux_type
!----------------------------------------------------
! CLM momentum flux variables structure
!----------------------------------------------------
type, public :: model_mflux_type
type(pft_mflux_type):: pmf_a !pft-level momentum flux variables globally averaged
end type model_mflux_type
!----------------------------------------------------
! CLM water flux variables structure
!----------------------------------------------------
type, public :: model_wflux_type
type(column_wflux_type):: cwf_a !column-level water flux variables globally averaged
end type model_wflux_type
!----------------------------------------------------
! CLM carbon flux variables structure
!----------------------------------------------------
type, public :: model_cflux_type
type(column_cflux_type):: ccf_a !column-level carbon flux variables globally averaged
end type model_cflux_type
!----------------------------------------------------
! CLM nitrogen flux variables structure
!----------------------------------------------------
type, public :: model_nflux_type
type(column_nflux_type):: cnf_a !column-level nitrogen flux variables globally averaged
end type model_nflux_type
!----------------------------------------------------
! CLM VOC flux variables structure
!----------------------------------------------------
type, public :: model_vflux_type
type(pft_vflux_type):: pvf_a !pft-level VOC flux variables globally averaged
end type model_vflux_type
!----------------------------------------------------
! CLM dust flux variables structure
!----------------------------------------------------
type, public :: model_dflux_type
type(pft_dflux_type):: pdf_a !pft-level dust flux variables globally averaged
end type model_dflux_type
!----------------------------------------------------
! End definition of structures defined at the model_type level
!----------------------------------------------------
!*******************************************************************************
!----------------------------------------------------
! Begin definition of spatial scaling hierarchy
!----------------------------------------------------
!----------------------------------------------------
! define the pft structure
!----------------------------------------------------
type, public :: pft_type
! g/l/c/p hierarchy, local g/l/c/p cells only
integer, pointer :: column(:) !index into column level quantities
real(r8), pointer :: wtcol(:) !weight (relative to column)
integer, pointer :: landunit(:) !index into landunit level quantities
real(r8), pointer :: wtlunit(:) !weight (relative to landunit)
integer, pointer :: gridcell(:) !index into gridcell level quantities
real(r8), pointer :: wtgcell(:) !weight (relative to gridcell)
! topological mapping functionality
integer , pointer :: itype(:) !pft vegetation
integer , pointer :: mxy(:) !m index for laixy(i,j,m),etc.
real(r8), pointer :: area(:) !total land area for this pft (km^2)
! conservation check structures for the pft level
type(energy_balance_type) :: pebal !energy balance structure
type(water_balance_type) :: pwbal !water balance structure
type(carbon_balance_type) :: pcbal !carbon balance structure
type(nitrogen_balance_type) :: pnbal !nitrogen balance structure
#if (defined CNDV) || (defined CROP)
! DGVM state variables
type(pft_dgvstate_type) :: pdgvs !pft DGVM state variables
#endif
! CN ecophysiological variables
type(pft_epv_type) :: pepv !pft ecophysiological variables
! state variables defined at the pft level
type(pft_pstate_type) :: pps !physical state variables
type(pft_estate_type) :: pes !pft energy state
type(pft_wstate_type) :: pws !pft water state
type(pft_cstate_type) :: pcs !pft carbon state
type(pft_nstate_type) :: pns !pft nitrogen state
type(pft_vstate_type) :: pvs !pft VOC state
! flux variables defined at the pft level
type(pft_eflux_type) :: pef !pft energy flux
type(pft_mflux_type) :: pmf !pft momentum flux
type(pft_wflux_type) :: pwf !pft water flux
type(pft_cflux_type) :: pcf !pft carbon flux
type(pft_nflux_type) :: pnf !pft nitrogen flux
type(pft_vflux_type) :: pvf !pft VOC flux
type(pft_dflux_type) :: pdf !pft dust flux
type(pft_depvd_type) :: pdd !dry dep velocity
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
type(pft_cstate_type) :: pc13s !pft carbon-13 state
type(pft_cflux_type) :: pc13f !pft carbon-13 flux
#endif
end type pft_type
!----------------------------------------------------
! define the column structure
!----------------------------------------------------
type, public :: column_type
type(pft_type) :: p !plant functional type (pft) data structure
! g/l/c/p hierarchy, local g/l/c/p cells only
integer , pointer :: landunit(:) !index into landunit level quantities
real(r8), pointer :: wtlunit(:) !weight (relative to landunit)
integer , pointer :: gridcell(:) !index into gridcell level quantities
real(r8), pointer :: wtgcell(:) !weight (relative to gridcell)
integer , pointer :: pfti(:) !beginning pft index for each column
integer , pointer :: pftf(:) !ending pft index for each column
integer , pointer :: npfts(:) !number of pfts for each column
! topological mapping functionality
integer , pointer :: itype(:) !column type
real(r8), pointer :: area(:) !total land area for this column (km^2)
! conservation check structures for the column level
type(energy_balance_type) :: cebal !energy balance structure
type(water_balance_type) :: cwbal !water balance structure
type(carbon_balance_type) :: ccbal !carbon balance structure
type(nitrogen_balance_type) :: cnbal !nitrogen balance structure
! state variables defined at the column level
type(column_pstate_type) :: cps !column physical state variables
type(column_estate_type) :: ces !column energy state
type(column_wstate_type) :: cws !column water state
type(column_cstate_type) :: ccs !column carbon state
type(column_nstate_type) :: cns !column nitrogen state
type(column_dstate_type) :: cds !column dust state
! flux variables defined at the column level
type(column_eflux_type) :: cef !column energy flux
type(column_mflux_type) :: cmf !column momentum flux
type(column_wflux_type) :: cwf !column water flux
type(column_cflux_type) :: ccf !column carbon flux
type(column_nflux_type) :: cnf !column nitrogen flux
type(column_vflux_type) :: cvf !column VOC flux
type(column_dflux_type) :: cdf !column dust flux
#if (defined CNDV)
! dgvm variables defined at the column level
type (column_dgvstate_type) :: cdgvs !column DGVM structure
#endif
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
type(column_cstate_type) :: cc13s !column carbon-13 state
type(column_cflux_type) :: cc13f !column carbon-13 flux
#endif
end type column_type
!----------------------------------------------------
! define the geomorphological land unit structure
!----------------------------------------------------
type, public :: landunit_type
type(column_type) :: c !column data structure (soil/snow/canopy columns)
! g/l/c/p hierarchy, local g/l/c/p cells only
integer , pointer :: gridcell(:) !index into gridcell level quantities
real(r8), pointer :: wtgcell(:) !weight (relative to gridcell)
integer , pointer :: coli(:) !beginning column index per landunit
integer , pointer :: colf(:) !ending column index for each landunit
integer , pointer :: ncolumns(:) !number of columns for each landunit
integer , pointer :: pfti(:) !beginning pft index for each landunit
integer , pointer :: pftf(:) !ending pft index for each landunit
integer , pointer :: npfts(:) !number of pfts for each landunit
real(r8), pointer :: area(:) !total land area for this landunit (km^2)
! Urban canyon related properties
real(r8), pointer :: canyon_hwr(:) ! urban landunit canyon height to width ratio (-)
real(r8), pointer :: wtroad_perv(:) ! urban landunit weight of pervious road column to total road (-)
real(r8), pointer :: wtlunit_roof(:) ! weight of roof with respect to urban landunit (-)
! Urban related info MV - this should be moved to land physical state - MV
real(r8), pointer :: ht_roof(:) ! height of urban roof (m)
real(r8), pointer :: wind_hgt_canyon(:)! height above road at which wind in canyon is to be computed (m)
real(r8), pointer :: z_0_town(:) ! urban landunit momentum roughness length (m)
real(r8), pointer :: z_d_town(:) ! urban landunit displacement height (m)
! topological mapping functionality
integer , pointer :: itype(:) !landunit type
logical , pointer :: ifspecial(:) !BOOL: true=>landunit is not vegetated
logical , pointer :: lakpoi(:) !BOOL: true=>lake point
logical , pointer :: urbpoi(:) !BOOL: true=>urban point
! conservation check structures for the landunit level
type(energy_balance_type) :: lebal !energy balance structure
type(water_balance_type) :: lwbal !water balance structure
type(carbon_balance_type) :: lcbal !carbon balance structure
type(nitrogen_balance_type) :: lnbal !nitrogen balance structure
! state variables defined at the land unit level
type(landunit_pstate_type) :: lps !land unit physical state variables
type(landunit_estate_type) :: les !average of energy states all columns
type(landunit_wstate_type) :: lws !average of water states all columns
type(landunit_cstate_type) :: lcs !average of carbon states all columns
type(landunit_nstate_type) :: lns !average of nitrogen states all columns
type(landunit_vstate_type) :: lvs !average of VOC states all columns
type(landunit_dstate_type) :: lds !average of dust states all columns
! flux variables defined at the landunit level
type(landunit_eflux_type) :: lef !average of energy fluxes all columns
type(landunit_mflux_type) :: lmf !average of momentum fluxes all columns
type(landunit_wflux_type) :: lwf !average of water fluxes all columns
type(landunit_cflux_type) :: lcf !average of carbon fluxes all columns
type(landunit_nflux_type) :: lnf !average of nitrogen fluxes all columns
type(landunit_vflux_type) :: lvf !average of VOC fluxes all columns
type(landunit_dflux_type) :: ldf !average of dust fluxes all columns
end type landunit_type
!----------------------------------------------------
! define the gridcell structure
!----------------------------------------------------
type, public :: gridcell_type
type(landunit_type) :: l !geomorphological landunits
! g/l/c/p hierarchy, local g/l/c/p cells only
integer, pointer :: luni(:) !beginning landunit index
integer, pointer :: lunf(:) !ending landunit index
integer, pointer :: nlandunits(:) !number of landunit for each gridcell
integer, pointer :: coli(:) !beginning column index
integer, pointer :: colf(:) !ending column index
integer, pointer :: ncolumns(:) !number of columns for each gridcell
integer, pointer :: pfti(:) !beginning pft index
integer, pointer :: pftf(:) !ending pft index
integer, pointer :: npfts(:) !number of pfts for each gridcell
! topological mapping functionality, local 1d gdc arrays
integer , pointer :: gindex(:) !global index
real(r8), pointer :: area(:) !total land area, gridcell (km^2)
real(r8), pointer :: lat(:) !latitude (radians)
real(r8), pointer :: lon(:) !longitude (radians)
real(r8), pointer :: latdeg(:) !latitude (degrees)
real(r8), pointer :: londeg(:) !longitude (degrees)
integer , pointer :: gindex_a(:) !"atm" global index
real(r8), pointer :: lat_a(:) !"atm" latitude (radians) for albedo
real(r8), pointer :: lon_a(:) !"atm" longitude (radians) for albedo
real(r8), pointer :: latdeg_a(:) !"atm" latitude (degrees) for albedo
real(r8), pointer :: londeg_a(:) !"atm" longitude (degrees) for albedo
! conservation check structures for the gridcell level
type(energy_balance_type) :: gebal !energy balance structure
type(water_balance_type) :: gwbal !water balance structure
type(carbon_balance_type) :: gcbal !carbon balance structure
type(nitrogen_balance_type) :: gnbal !nitrogen balance structure
#if (defined CNDV)
! dgvm variables defined at the gridcell level
type(gridcell_dgvstate_type):: gdgvs !gridcell DGVM structure
#endif
! state variables defined at the gridcell level
type(gridcell_pstate_type) :: gps !gridcell physical state variables
type(gridcell_estate_type) :: ges !average of energy states all landunits
type(gridcell_wstate_type) :: gws !average of water states all landunits
type(gridcell_cstate_type) :: gcs !average of carbon states all landunits
type(gridcell_nstate_type) :: gns !average of nitrogen states all landus
type(gridcell_vstate_type) :: gvs !average of VOC states all landunits
type(gridcell_efstate_type):: gve !gridcell VOC emission factors
type(gridcell_dstate_type) :: gds !average of dust states all landunits
! flux variables defined at the gridcell level
type(gridcell_eflux_type) :: gef !average of energy fluxes all landunits
type(gridcell_wflux_type) :: gwf !average of water fluxes all landunits
type(gridcell_cflux_type) :: gcf !average of carbon fluxes all landunits
type(gridcell_nflux_type) :: gnf !average of nitrogen fluxes all landus
type(gridcell_vflux_type) :: gvf !average of VOC fluxes all landunits
type(gridcell_dflux_type) :: gdf !average of dust fluxes all landunits
end type gridcell_type
!----------------------------------------------------
! define the top-level (model) structure
!----------------------------------------------------
type, public :: model_type
! lower level in hierarch
type(gridcell_type) :: g !gridicell data structure
integer :: ngridcells !number of gridcells for this process
real(r8) :: area !total land area for all gridcells (km^2)
! conservation check structures for the clm (global) level
type(energy_balance_type) :: mebal !energy balance structure
type(water_balance_type) :: mwbal !water balance structure
type(carbon_balance_type) :: mcbal !carbon balnace structure
type(nitrogen_balance_type) :: mnbal !nitrogen balance structure
! globally average state variables
type(model_pstate_type) :: mps !clm physical state variables
type(model_estate_type) :: mes !average of energy states all gridcells
type(model_wstate_type) :: mws !average of water states all gridcells
type(model_cstate_type) :: mcs !average of carbon states all gridcells
type(model_nstate_type) :: mns !average of nitrogen states all gcells
type(model_vstate_type) :: mvs !average of VOC states all gridcells
type(model_dstate_type) :: mds !average of dust states all gridcells
! globally averaged flux variables
type(model_eflux_type) :: mef !average of energy fluxes all gridcells
type(model_wflux_type) :: mwf !average of water fluxes all gridcells
type(model_cflux_type) :: mcf !average of carbon fluxes all gridcells
type(model_nflux_type) :: mnf !average of nitrogen fluxes all gcells
type(model_vflux_type) :: mvf !average of VOC fluxes all gridcells
type(model_dflux_type) :: mdf !average of dust fluxes all gridcells
end type model_type
type atm2lnd_type
real(r8), pointer :: forc_t(:) !atmospheric temperature (Kelvin)
real(r8), pointer :: forc_u(:) !atm wind speed, east direction (m/s)
real(r8), pointer :: forc_v(:) !atm wind speed, north direction (m/s)
real(r8), pointer :: forc_wind(:) !atmospheric wind speed
real(r8), pointer :: forc_q(:) !atmospheric specific humidity (kg/kg)
real(r8), pointer :: forc_hgt(:) !atmospheric reference height (m)
real(r8), pointer :: forc_hgt_u(:) !obs height of wind [m] (new)
real(r8), pointer :: forc_hgt_t(:) !obs height of temperature [m] (new)
real(r8), pointer :: forc_hgt_q(:) !obs height of humidity [m] (new)
real(r8), pointer :: forc_pbot(:) !atmospheric pressure (Pa)
real(r8), pointer :: forc_th(:) !atm potential temperature (Kelvin)
real(r8), pointer :: forc_vp(:) !atmospheric vapor pressure (Pa)
real(r8), pointer :: forc_rho(:) !density (kg/m**3)
real(r8), pointer :: forc_rh(:) !atmospheric relative humidity (%)
real(r8), pointer :: forc_psrf(:) !surface pressure (Pa)
real(r8), pointer :: forc_pco2(:) !CO2 partial pressure (Pa)
real(r8), pointer :: forc_lwrad(:) !downwrd IR longwave radiation (W/m**2)
real(r8), pointer :: forc_solad(:,:) !direct beam radiation (numrad)
!(vis=forc_sols , nir=forc_soll )
real(r8), pointer :: forc_solai(:,:) !diffuse radiation (numrad)
!(vis=forc_solsd, nir=forc_solld)
real(r8), pointer :: forc_solar(:) !incident solar radiation
real(r8), pointer :: forc_rain(:) !rain rate [mm/s]
real(r8), pointer :: forc_snow(:) !snow rate [mm/s]
real(r8), pointer :: forc_ndep(:) !nitrogen deposition rate (gN/m2/s)
real(r8), pointer :: rainf(:) !ALMA rain+snow [mm/s]
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
real(r8), pointer :: forc_pc13o2(:) !C13O2 partial pressure (Pa)
#endif
real(r8), pointer :: forc_po2(:) !O2 partial pressure (Pa)
real(r8), pointer :: forc_aer(:,:) ! aerosol deposition array
end type atm2lnd_type
type(atm2lnd_type), public, target, save :: clm_a2l
!----------------------------------------------------
! End definition of spatial scaling hierarchy
!----------------------------------------------------
!*******************************************************************************
!*******************************************************************************
!----------------------------------------------------
! Declare single instance of clmtype
!----------------------------------------------------
type(model_type) , public, target , save :: clm3
!----------------------------------------------------
! Declare single instance of array of ecophysiological constant types
!----------------------------------------------------
type(pft_epc_type), public, target, save :: pftcon
#if (defined CNDV) || (defined CROP)
!----------------------------------------------------
! Declare single instance of array of dgvm ecophysiological constant types
!----------------------------------------------------
type(pft_dgvepc_type), public, target, save :: dgv_pftcon
#endif
character(len=8), parameter, public :: gratm = 'atmgrid' ! name of atmgrid
character(len=8), parameter, public :: grlnd = 'lndgrid' ! name of lndgrid
character(len=8), parameter, public :: nameg = 'gridcell' ! name of gridcells
character(len=8), parameter, public :: namel = 'landunit' ! name of landunits
character(len=8), parameter, public :: namec = 'column' ! name of columns
character(len=8), parameter, public :: namep = 'pft' ! name of pfts
character(len=8), parameter, public :: allrof = 'allrof' ! name of rtm, runoff
!
!EOP
!-----------------------------------------------------------------------
contains
subroutine clmtype_mod 1,4
end subroutine clmtype_mod
end module clmtype
MODULE module_sf_clm 2
!October 15, 2012
!Jiming Jin: initial coupling WRF with CLM
!Yaqiong Lu and Jiming Jin: CLM version 4.0 update with WRF
!
!------------------------------------------------------
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varpar, only: numpft, clm_varpar_mod,nlevgrnd, nlevsoi,nlevlak,nlevsno,maxpatch_pft
use clm_varcon, only: hvap, hsub,tfrz, vkc, sb ,&
snowage_drdt0,ndep,organic,fmax,efisop
use module_cam_support, only: endrun
!
CONTAINS
!
subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & 1,28
,shxy ,qfx ,lhxy ,soiflx ,qgh &
,gsw, swdown,ra_sw_physics &
,history_interval ,flwdsxy ,smstav ,smstot ,qsfxy &
,qdnxy ,ivgtyp ,isltyp ,vegfra ,albxy &
,znt ,z0 ,tmn ,xland ,xice &
,emiss ,snowc ,qsfc ,prec ,maxpatch &
,num_soil_layers ,dt ,dzs ,nstep &
,smois ,tslb ,snow ,canwat ,chs &
,chs2 &
,sh2o ,snowh ,forc_uxy ,forc_vxy ,shdmin &
,shdmax ,acsnom ,acsnow ,dx ,xlat &
,xlong,ht &
,ids,ide, jds,jde, kds,kde &
,ims,ime, jms,jme, kms,kme &
,its,ite, jts,jte, kts,kte &
,inest, sf_urban_physics, &
!Optional urban
CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, &
tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d, & !H urban
uc_urb2d, & !H urban
xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d, & !H urban
trl_urb3d,tbl_urb3d,tgl_urb3d, & !H urban
sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d,ts_urb2d, & !H urban
psim_urb2d,psih_urb2d,u10_urb2d,v10_urb2d, & !O urban
GZ1OZ0_urb2d, AKMS_URB2D, & !O urban
th2_urb2d,q2_urb2d,ust_urb2d, & !O urban
declin_urb,cosz_urb2d,omg_urb2d, & !I urban
xlat_urb2d, & !I urban
num_roof_layers, num_wall_layers, & !I urban
num_road_layers, DZR, DZB, DZG, & !I urban
FRC_URB2D, UTYPE_URB2D & ! urban
! subgrids
,numc,nump,sabv,sabg,lwup,snl, &
snowdp,wtc,wtp,h2osno,t_grnd,t_veg, &
h2ocan,h2ocan_col,t2m_max,t2m_min,t2clm , &
t_ref2m,h2osoi_liq_s1, &
h2osoi_liq_s2,h2osoi_liq_s3,h2osoi_liq_s4, &
h2osoi_liq_s5,h2osoi_liq1,h2osoi_liq2, &
h2osoi_liq3,h2osoi_liq4,h2osoi_liq5,h2osoi_liq6, &
h2osoi_liq7,h2osoi_liq8,h2osoi_liq9,h2osoi_liq10, &
h2osoi_ice_s1,h2osoi_ice_s2, &
h2osoi_ice_s3,h2osoi_ice_s4,h2osoi_ice_s5, &
h2osoi_ice1,h2osoi_ice2,h2osoi_ice3,h2osoi_ice4, &
h2osoi_ice5,h2osoi_ice6,h2osoi_ice7, &
h2osoi_ice8,h2osoi_ice9,h2osoi_ice10, &
t_soisno_s1,t_soisno_s2,t_soisno_s3,t_soisno_s4, &
t_soisno_s5,t_soisno1,t_soisno2,t_soisno3, &
t_soisno4,t_soisno5,t_soisno6,t_soisno7, &
t_soisno8,t_soisno9,t_soisno10, &
dzsnow1,dzsnow2,dzsnow3,dzsnow4,dzsnow5, &
snowrds1,snowrds2,snowrds3,snowrds4,snowrds5, &
t_lake1,t_lake2,t_lake3,t_lake4,t_lake5, &
t_lake6,t_lake7,t_lake8,t_lake9,t_lake10, &
h2osoi_vol1,h2osoi_vol2,h2osoi_vol3, &
h2osoi_vol4,h2osoi_vol5,h2osoi_vol6, &
h2osoi_vol7,h2osoi_vol8, &
h2osoi_vol9,h2osoi_vol10, &
q_ref2m, &
ALBEDOsubgrid,LHsubgrid,HFXsubgrid,LWUPsubgrid, &
Q2subgrid,SABVsubgrid,SABGsubgrid,NRAsubgrid,SWUPsubgrid,&
LHsoi,LHveg,LHtran,&
alswvisdir, alswvisdif, alswnirdir, alswnirdif, & ! clm
swvisdir, swvisdif, swnirdir, swnirdif & ! clm
#ifdef CN
!CROP&CN restart and outputs
,dyntlai,dyntsai,dyntop,dynbot &
,htmx,croplive,gdd1020,gdd820,gdd020,grainc,grainc_storage &
,grainc_xfer,grainn,grainn_storage,grainn_xfer,days_active &
,onset_flag,onset_counter,onset_gddflag,onset_fdd,onset_gdd &
,onset_swi,offset_flag,offset_counter,offset_fdd,offset_swi &
,dayl,annavg_t2m,tempavg_t2m,tempsum_potential_gpp &
,annsum_potential_gpp,tempmax_retransn,annmax_retransn &
,prev_leafc_to_litter,prev_frootc_to_litter,tempsum_npp &
,annsum_npp,leafc,leafc_storage,leafc_xfer,frootc &
,frootc_storage,frootc_xfer,livestemc,livestemc_storage &
,livestemc_xfer,deadstemc,deadstemc_storage,deadstemc_xfer &
,livecrootc,livecrootc_storage,livecrootc_xfer,deadcrootc &
,deadcrootc_storage,deadcrootc_xfer,cpool,pft_ctrunc &
,leafn,leafn_storage,leafn_xfer,frootn,frootn_storage &
,frootn_xfer,livestemn,livestemn_storage,livestemn_xfer &
,deadstemn,deadstemn_storage,deadstemn_xfer,livecrootn &
,livecrootn_storage,livecrootn_xfer,deadcrootn &
,deadcrootn_storage,deadcrootn_xfer,npool,pft_ntrunc &
,gresp_storage,gresp_xfer,xsmrpool,annsum_counter &
,cannsum_npp,cannavg_t2m,wf,me,mean_fire_prob,cwdc,litr1c &
,litr2c,litr3c,soil1c,soil2c,soil3c,soil4c,seedc,col_ctrunc &
,prod10c,prod100c,cwdn,litr1n,litr2n,litr3n,soil1n,soil2n &
,soil3n,soil4n,seedn,col_ntrunc,prod10n,prod100n,sminn &
,totlitc,dwt_seedc_to_leaf,dwt_seedc_to_deadstem,dwt_conv_cflux &
,dwt_prod10c_gain,dwt_prod100c_gain,prod100c_loss,dwt_frootc_to_litr1c &
,dwt_frootc_to_litr2c,dwt_frootc_to_litr3c,dwt_livecrootc_to_cwdc &
,dwt_deadcrootc_to_cwdc,dwt_seedn_to_leaf,dwt_seedn_to_deadstem &
,dwt_conv_nflux,dwt_prod10n_gain,dwt_prod100n_gain,prod100n_loss &
,dwt_frootn_to_litr1n,dwt_frootn_to_litr2n, dwt_frootn_to_litr3n &
, dwt_livecrootn_to_cwdn,dwt_deadcrootn_to_cwdn,retransn &
#endif
)
USE module_date_time
USE module_sf_urban, only: urban
USE module_configure
implicit none
integer, intent(in) :: ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte
integer,intent(in) :: num_soil_layers,maxpatch,nstep,sf_urban_physics,&
ra_sw_physics,history_interval
real,dimension(ims:ime,1:num_soil_layers,jms:jme ),intent(inout) ::&
smois, & ! total soil moisture
sh2o, & ! new soil liquid
tslb ! TSLB STEMP
real,intent(in) :: dt,dx
real(r8) :: dtt
real, dimension(1:num_soil_layers), intent(in)::dzs
real,dimension(ims:ime,jms:jme ),intent(inout) ::&
smstav ,smstot &
,znt ,snowc ,qsfc ,snow ,snowh &
,canwat ,acsnom ,acsnow, emiss, z0
real,dimension(ims:ime,jms:jme ),intent(in) ::&
vegfra, tmn,shdmin,shdmax
real,dimension(ims:ime,jms:jme ),intent(in) ::&
qgh,chs,chs2
real(r8) :: efisop_buf(6)
logical :: found = .false.
integer, dimension(ims:ime,jms:jme ),intent(inout) :: numc,nump
real, dimension(ims:ime,jms:jme ),intent(inout) :: soiflx,sabv,sabg,lwup,t2m_max,t2m_min
integer, dimension(ims:ime,1:maxpatch,jms:jme ) :: snl,snl1
real, dimension(ims:ime,1:maxpatch,jms:jme ),intent(inout) :: &
snowdp,wtc,wtp,h2osno,t_grnd,t_veg, &
h2ocan,h2ocan_col, &
t_ref2m,h2osoi_liq_s1, &
h2osoi_liq_s2,h2osoi_liq_s3,h2osoi_liq_s4, &
h2osoi_liq_s5,h2osoi_liq1,h2osoi_liq2, &
h2osoi_liq3,h2osoi_liq4,h2osoi_liq5,h2osoi_liq6, &
h2osoi_liq7,h2osoi_liq8,h2osoi_liq9,h2osoi_liq10, &
h2osoi_ice_s1,h2osoi_ice_s2, &
h2osoi_ice_s3,h2osoi_ice_s4,h2osoi_ice_s5, &
h2osoi_ice1,h2osoi_ice2,h2osoi_ice3,h2osoi_ice4, &
h2osoi_ice5,h2osoi_ice6,h2osoi_ice7, &
h2osoi_ice8,h2osoi_ice9,h2osoi_ice10, &
t_soisno_s1,t_soisno_s2,t_soisno_s3,t_soisno_s4, &
t_soisno_s5,t_soisno1,t_soisno2,t_soisno3, &
t_soisno4,t_soisno5,t_soisno6,t_soisno7, &
t_soisno8,t_soisno9,t_soisno10, &
dzsnow1,dzsnow2,dzsnow3,dzsnow4,dzsnow5, &
snowrds1,snowrds2,snowrds3,snowrds4,snowrds5, &
t_lake1,t_lake2,t_lake3,t_lake4,t_lake5, &
t_lake6,t_lake7,t_lake8,t_lake9,t_lake10, &
h2osoi_vol1,h2osoi_vol2,h2osoi_vol3, &
h2osoi_vol4,h2osoi_vol5,h2osoi_vol6, &
h2osoi_vol7,h2osoi_vol8, &
h2osoi_vol9,h2osoi_vol10, &
q_ref2m, &
ALBEDOsubgrid,LHsubgrid,HFXsubgrid,LWUPsubgrid, &
Q2subgrid,SABVsubgrid,SABGsubgrid,NRAsubgrid, &
SWUPsubgrid,LHsoi,LHveg,LHtran
real(r8) :: gti_buf
#ifdef CN
real, dimension(ims:ime,1:maxpatch,jms:jme),intent(in) :: dyntlai,dyntsai,dyntop,dynbot
!ADD_NEW_VAR
integer, dimension(ims:ime,1:maxpatch,jms:jme ),intent(inout) :: croplive
real,dimension(ims:ime,1:maxpatch,jms:jme),intent(inout) :: &
htmx,gdd1020,gdd820,gdd020,grainc,grainc_storage &
,grainc_xfer,grainn,grainn_storage,grainn_xfer,days_active &
,onset_flag,onset_counter,onset_gddflag,onset_fdd,onset_gdd &
,onset_swi,offset_flag,offset_counter,offset_fdd,offset_swi &
,dayl,annavg_t2m,tempavg_t2m,tempsum_potential_gpp &
,annsum_potential_gpp,tempmax_retransn,annmax_retransn &
,prev_leafc_to_litter,prev_frootc_to_litter,tempsum_npp &
,annsum_npp,leafc,leafc_storage,leafc_xfer,frootc &
,frootc_storage,frootc_xfer,livestemc,livestemc_storage &
,livestemc_xfer,deadstemc,deadstemc_storage,deadstemc_xfer &
,livecrootc,livecrootc_storage,livecrootc_xfer,deadcrootc &
,deadcrootc_storage,deadcrootc_xfer,cpool,pft_ctrunc &
,leafn,leafn_storage,leafn_xfer,frootn,frootn_storage &
,frootn_xfer,livestemn,livestemn_storage,livestemn_xfer &
,deadstemn,deadstemn_storage,deadstemn_xfer,livecrootn &
,livecrootn_storage,livecrootn_xfer,deadcrootn &
,deadcrootn_storage,deadcrootn_xfer,npool,pft_ntrunc &
,gresp_storage,gresp_xfer,xsmrpool,annsum_counter &
,cannsum_npp,cannavg_t2m,wf,me,mean_fire_prob,cwdc,litr1c &
,litr2c,litr3c,soil1c,soil2c,soil3c,soil4c,seedc,col_ctrunc &
,prod10c,prod100c,cwdn,litr1n,litr2n,litr3n,soil1n,soil2n &
,soil3n,soil4n,seedn,col_ntrunc,prod10n,prod100n,sminn &
,totlitc,dwt_seedc_to_leaf,dwt_seedc_to_deadstem,dwt_conv_cflux &
,dwt_prod10c_gain,dwt_prod100c_gain,prod100c_loss,dwt_frootc_to_litr1c &
,dwt_frootc_to_litr2c,dwt_frootc_to_litr3c,dwt_livecrootc_to_cwdc &
,dwt_deadcrootc_to_cwdc,dwt_seedn_to_leaf,dwt_seedn_to_deadstem &
,dwt_conv_nflux,dwt_prod10n_gain,dwt_prod100n_gain,prod100n_loss &
,dwt_frootn_to_litr1n,dwt_frootn_to_litr2n, dwt_frootn_to_litr3n &
, dwt_livecrootn_to_cwdn,dwt_deadcrootn_to_cwdn,retransn
#endif
!!!
integer :: i,j,m,inest,k
real, dimension(ims:ime, kms:kme,jms:jme),intent(in) ::&
forc_txy,forc_uxy,forc_vxy,forc_qxy,zgcmxy,ps
real :: flwdsxy(ims:ime,jms:jme) !downward longwave rad onto surface (W/m**2)
real :: gsw(ims:ime,jms:jme) !downward solar rad onto surface (W/m**2)
real :: swdown(ims:ime,jms:jme)
real, dimension(ims:ime,jms:jme),intent(in) :: swvisdir, swvisdif, swnirdir,swnirdif
real, dimension(ims:ime,jms:jme),intent(out):: alswvisdir,alswvisdif,alswnirdir,alswnirdif
real :: xlat (ims:ime,jms:jme)
real :: xlong(ims:ime,jms:jme)
real :: ht(ims:ime,jms:jme)
real :: xland (ims:ime,jms:jme)
real :: xice (ims:ime,jms:jme)
real :: prec (ims:ime,jms:jme) !total precipitation rate (mm; accumlated precipitation within DT)
integer :: ivgtyp(ims:ime,jms:jme)
integer :: isltyp (ims:ime,jms:jme)
real :: albxy(ims:ime,jms:jme)
real :: tsxy(ims:ime,jms:jme)
real :: t2clm(ims:ime,jms:jme)
real :: shxy(ims:ime,jms:jme)
real :: lhxy(ims:ime,jms:jme)
real :: qfx(ims:ime,jms:jme) ! kg/(sm^2) =>mm/s
real :: qsfxy(ims:ime,jms:jme)
real :: qdnxy(ims:ime,jms:jme)
real(r8) :: alswvisdir_buf,alswvisdif_buf,alswnirdir_buf,alswnirdif_buf
real(r8) :: swvisdir_buf,swvisdif_buf,swnirdir_buf,swnirdif_buf
real(r8) :: albxy_buf
real(r8) :: tsxy_buf,trefxy_buf
real(r8) :: shxy_buf
real(r8) :: lhxy_buf
real(r8) :: qsfxy_buf
real(r8) :: qdnxy_buf
real(r8) :: soiflx_buf
real(r8) :: sabv_buf
real(r8) :: sabg_buf
real(r8) :: lwup_buf
real(r8) :: znt_buf
real(r8) :: rhoxy_buf
real(r8) :: swd_buf
real(r8) :: forc_sols_buf
real(r8) :: forc_soll_buf
real(r8) :: forc_solsd_buf
real(r8) :: forc_solld_buf
real(r8) :: area_buf
real(r8) :: forc_pbot_buf
real(r8) :: forc_txy_buf
real(r8) :: forc_uxy_buf
real(r8) :: forc_vxy_buf
real(r8) :: forc_qxy_buf
real(r8) :: zgcmxy_buf
real(r8) :: prec_buf
real(r8) :: flwdsxy_buf
real(r8) :: forc_psrfxy_buf
!ADD_NEW_VAR
real(r8) :: forc_ndepxy_buf
!!!
real(r8) :: xlat_buf
real(r8) :: xlon_buf
real(r8),dimension(maxpatch,-nlevsno+1:nlevgrnd) :: dzclm
real(r8),dimension(maxpatch,-nlevsno+1:nlevgrnd) :: zclm
real(r8),dimension(maxpatch,-nlevsno:nlevgrnd) :: ziclm
real(r8),dimension(maxpatch,-nlevsno+1:nlevgrnd) :: &
h2osoi_liq_buf, &
h2osoi_ice_buf, &
t_soisno_buf
real(r8),dimension(maxpatch,-nlevsno+1:0) ::snw_rds_buf
real(r8),dimension(maxpatch,1:num_soil_layers) :: &
t_lake_buf, h2osoi_vol_buf
integer :: lndmsk
!------------------------------------------------------------------------
real(r8),dimension(maxpatch) :: organic_buf
real(r8), dimension(maxpatch) :: &
snowdp_buf,wtc_buf,wtp_buf,h2osno_buf,t_grnd_buf,t_veg_buf, &
h2ocan_buf,h2ocan_col_buf, &
t_ref2m_buf, q_ref2m_buf, &
albedosubgrid_buf, lhsubgrid_buf, hfxsubgrid_buf, lwupsubgrid_buf, &
q2subgrid_buf,sabgsubgrid_buf,sabvsubgrid_buf,nrasubgrid_buf,swupsubgrid_buf,&
lhsoi_buf,lhveg_buf,lhtran_buf,tlai_buf,tsai_buf,htop_buf,hbot_buf
#ifdef CN
!CROP&CN buf variables
integer,dimension(maxpatch) :: croplive_buf
real(r8), dimension(maxpatch) :: &
htmx_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf&
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf
#endif
! ----------------------------------------------------------------------
! DECLARATIONS START - urban
! ----------------------------------------------------------------------
! input variables surface_driver --> lsm
INTEGER, INTENT(IN) :: num_roof_layers
INTEGER, INTENT(IN) :: num_wall_layers
INTEGER, INTENT(IN) :: num_road_layers
REAL, OPTIONAL, DIMENSION(1:num_roof_layers), INTENT(IN) :: DZR
REAL, OPTIONAL, DIMENSION(1:num_wall_layers), INTENT(IN) :: DZB
REAL, OPTIONAL, DIMENSION(1:num_road_layers), INTENT(IN) :: DZG
REAL, OPTIONAL, INTENT(IN) :: DECLIN_URB
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D
! input variables lsm --> urban
INTEGER :: UTYPE_URB ! urban type [urban=1, suburban=2, rural=3]
REAL :: TA_URB ! potential temp at 1st atmospheric level [K]
REAL :: QA_URB ! mixing ratio at 1st atmospheric level [kg/kg]
REAL :: UA_URB ! wind speed at 1st atmospheric level [m/s]
REAL :: U1_URB ! u at 1st atmospheric level [m/s]
REAL :: V1_URB ! v at 1st atmospheric level [m/s]
REAL :: SSG_URB ! downward total short wave radiation [W/m/m]
REAL :: LLG_URB ! downward long wave radiation [W/m/m]
REAL :: RAIN_URB ! precipitation [mm/h]
REAL :: RHOO_URB ! air density [kg/m^3]
REAL :: ZA_URB ! first atmospheric level [m]
REAL :: DELT_URB ! time step [s]
REAL :: SSGD_URB ! downward direct short wave radiation [W/m/m]
REAL :: SSGQ_URB ! downward diffuse short wave radiation [W/m/m]
REAL :: XLAT_URB ! latitude [deg]
REAL :: COSZ_URB ! cosz
REAL :: OMG_URB ! hour angle
REAL :: ZNT_URB ! roughness length [m]
REAL :: TR_URB
REAL :: TB_URB
REAL :: TG_URB
REAL :: TC_URB
REAL :: QC_URB
REAL :: UC_URB
REAL :: XXXR_URB
REAL :: XXXB_URB
REAL :: XXXG_URB
REAL :: XXXC_URB
REAL, DIMENSION(1:num_roof_layers) :: TRL_URB ! roof layer temp [K]
REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K]
REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K]
LOGICAL :: LSOLAR_URB
! state variable surface_driver <--> lsm <--> urban
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UC_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D
!
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D
REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D
REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D
REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF
! output variable lsm --> surface_driver
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D
!
REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D
!
REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D
REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FRC_URB2D
INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D
! output variables urban --> lsm
REAL :: TS_URB ! surface radiative temperature [K]
REAL :: QS_URB ! surface humidity [-]
REAL :: SH_URB ! sensible heat flux [W/m/m]
REAL :: LH_URB ! latent heat flux [W/m/m]
REAL :: LH_KINEMATIC_URB ! latent heat flux, kinetic [kg/m/m/s]
REAL :: SW_URB ! upward short wave radiation flux [W/m/m]
REAL :: ALB_URB ! time-varying albedo [fraction]
REAL :: LW_URB ! upward long wave radiation flux [W/m/m]
REAL :: G_URB ! heat flux into the ground [W/m/m]
REAL :: RN_URB ! net radiation [W/m/m]
REAL :: PSIM_URB ! shear f for momentum [-]
REAL :: PSIH_URB ! shear f for heat [-]
REAL :: GZ1OZ0_URB ! shear f for heat [-]
REAL :: U10_URB ! wind u component at 10 m [m/s]
REAL :: V10_URB ! wind v component at 10 m [m/s]
REAL :: TH2_URB ! potential temperature at 2 m [K]
REAL :: Q2_URB ! humidity at 2 m [-]
REAL :: CHS_URB
REAL :: CHS2_URB
REAL :: UST_URB
! ----------------------------------------------------------------------
! DECLARATIONS END - urban
! ----------------------------------------------------------------------
CHARACTER(len=24) :: nextstep_date, cdate,simulation_start_date
INTEGER simulation_start_year , &
simulation_start_month , &
simulation_start_day , &
simulation_start_hour , &
simulation_start_minute , &
simulation_start_second
integer :: myr,mon,mday,mhr,mint,msc,mtsec,myr1,mon1,mday1,mhr1,mint1,msc1,mtsec1
integer :: myrs,mons,mdays,mhrs,mints,mscs,mtsecs
integer :: julyr,julday, julyr1,julday1
integer :: mbdate
integer :: msec,msec1
integer :: ns
real(r8) :: calday,calday1
real :: gmt,gmt1
integer(selected_int_kind(12)) :: idts
integer :: idt
real(r8) :: dsqmin, dsq
character*256 :: msg
real :: mh_urb,stdh_urb,lp_urb,hgt_urb,frc_urb,lb_urb,check
real, dimension(4) :: lf_urb
! ----------------------------------------------------------------------
call clm_varpar_mod
call CLMDebug('Now in clmdrv')
! if((nlevsoi /= num_soil_layers) .or. (nlevlak/= num_soil_layers)) then
! print*,'nlevsoi and nlevlak must be equal to num_soil_layers in CLM; Stop in module_sf_clm.F'
! call endrun()
! end if
dtt = dt
write(msg,*) 'dt=',dt,'jts=',jts,'jte=',jte,'its=',its,'ite=',ite
call CLMDebug(msg)
CALL nl_get_simulation_start_year ( 1, simulation_start_year )
CALL nl_get_simulation_start_month ( 1, simulation_start_month )
CALL nl_get_simulation_start_day ( 1, simulation_start_day )
CALL nl_get_simulation_start_hour ( 1, simulation_start_hour )
CALL nl_get_simulation_start_minute ( 1, simulation_start_minute )
CALL nl_get_simulation_start_second ( 1, simulation_start_second )
WRITE ( simulation_start_date(1:19) , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
simulation_start_year,simulation_start_month,simulation_start_day,&
simulation_start_hour,simulation_start_minute,simulation_start_second
simulation_start_date(1:24) = simulation_start_date(1:19)//'.0000'
CALL split_date_char (simulation_start_date, myrs, mons, mdays, mhrs, mints, mscs, mtsecs)
idt = nint(dtt)*nstep
idts = nint(dtt)*nstep
if(idt/=idts) then
print*,'The integer idt and idts is too large; Stop in module_sf_clm.F', idt,idts
call endrun()
end if
CALL geth_newdate (cdate(1:19), simulation_start_date(1:19), idt) ! dt in seconds
cdate(1:24) = cdate(1:19)//'.0000'
CALL split_date_char (cdate, myr, mon, mday, mhr, mint, msc, mtsec )
CALL geth_newdate (nextstep_date(1:19), cdate(1:19), nint(dtt)) ! dtt in seconds
nextstep_date(1:24) = nextstep_date(1:19)//'.0000'
CALL split_date_char (nextstep_date, myr1, mon1, mday1, mhr1, mint1, msc1, mtsec1)
CALL get_julgmt(cdate,julyr,julday, gmt) !module_date_time.F ../share/
CALL get_julgmt(nextstep_date,julyr1,julday1, gmt1)
msec = mhr*3600 + mint*60
msec1 = mhr1*3600 + mint1*60
calday = julday + gmt/24.0
calday1= julday1 + gmt1/24.0
mbdate = myrs*10000 + mons*100 + mdays
!write(6,*) 'at nstep=',nstep,'snowage_drdt0(1,31,8)=',snowage_drdt0(1,31,8)
do j=jts,jte
do i=its,ite
if(xland(i,j) == 1.0) then
lndmsk = 1
else
lndmsk = 0
end if
if(lndmsk == 1) then
qsfxy_buf = qsfxy(i,j)
qdnxy_buf = qdnxy(i,j)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
xlon_buf = xlong(i,j) + 360.0
xlat_buf = xlat(i,j)
albxy_buf = albxy(i,j)
if(gsw(i,j)>0.0.and.albxy_buf<0.99.and.albxy_buf>0.0)then
swd_buf = gsw(i,j)/(1.-albxy_buf)
swdown(i,j) = gsw(i,j)/(1.-albxy_buf)
else
swd_buf = 0.0
swdown(i,j) = 0.0
end if
if(ra_sw_physics .ne. 3) then !if not CAM scheme, the use 0.35/0.15 for coupling --ylu
forc_sols_buf = swd_buf*0.35
forc_soll_buf = swd_buf*0.35
forc_solsd_buf = swd_buf*0.15
forc_solld_buf = swd_buf*0.15
else !if use cam radiation, then we can directly use the seperate swd --ylu
forc_sols_buf = swvisdir(i,j)
forc_soll_buf = swnirdir(i,j)
forc_solsd_buf = swvisdif(i,j)
forc_solld_buf = swnirdif(i,j)
end if
area_buf = dx*dx/1.e6 !(km^2)
forc_pbot_buf = ps(i,1,j) !Pa
forc_txy_buf = forc_txy(i,1,j)
forc_uxy_buf = forc_uxy(i,1,j)
forc_vxy_buf = forc_vxy(i,1,j)
forc_qxy_buf = forc_qxy(i,1,j)
zgcmxy_buf = zgcmxy(i,1,j)
prec_buf = prec(i,j)/dtt ! mm/s
flwdsxy_buf = flwdsxy(i,j)
forc_psrfxy_buf= ps(i,1,j) ! Pa
!ADD_NEW_VAR
forc_ndepxy_buf=ndep/(86400._r8 * 365._r8)
!!!
efisop_buf(1:6) = efisop(1:6)
gti_buf = fmax
soiflx(i,j) = 0.0
sabv(i,j) = 0.0
sabg(i,j) = 0.0
lwup(i,j) = 0.0
soiflx_buf = 0.0
sabv_buf = 0.0
sabg_buf = 0.0
lwup_buf = 0.0
swvisdir_buf = swvisdir(i,j)
swvisdif_buf = swvisdif(i,j)
swnirdir_buf = swnirdir(i,j)
swnirdif_buf = swnirdif(i,j)
do m=1,maxpatch
do k =1,nlevgrnd
zclm(m,k) = 0.025*(exp(0.5*(k-0.5))-1.)
end do
dzclm(m,1) = 0.5*(zclm(m,1)+zclm(m,2))
do k = 2,nlevgrnd-1
dzclm(m,k)= 0.5*(zclm(m,k+1)-zclm(m,k-1))
enddo
dzclm(m,nlevgrnd) = zclm(m,nlevgrnd)-zclm(m,nlevgrnd-1)
ziclm(m,0) = 0.0
do k =1,nlevgrnd-1
ziclm(m,k) = 0.5*(zclm(m,k) + zclm(m,k+1))
end do
ziclm(m,nlevgrnd) = zclm(m,nlevgrnd) + 0.5*dzclm(m,nlevgrnd)
dzclm(m,-4) = dzsnow5(i,m,j)
dzclm(m,-3) = dzsnow4(i,m,j)
dzclm(m,-2) = dzsnow3(i,m,j)
dzclm(m,-1) = dzsnow2(i,m,j)
dzclm(m,0) = dzsnow1(i,m,j)
do k=0,-nlevsno+1, -1
zclm(m,k) = ziclm(m,k) - 0.5*dzclm(m,k)
ziclm(m,k-1) = ziclm(m,k) - dzclm(m,k)
end do
snl1(i,m,j) = snl(i,m,j)
snowdp_buf(m) = snowdp(i,m,j)
! snowage_buf(m) = snowage(i,m,j)
snw_rds_buf(m,-4) = snowrds5(i,m,j)
snw_rds_buf(m,-3) = snowrds4(i,m,j)
snw_rds_buf(m,-2) = snowrds3(i,m,j)
snw_rds_buf(m,-1) = snowrds2(i,m,j)
snw_rds_buf(m,0) = snowrds1(i,m,j)
h2osoi_liq_buf(m,-4) = h2osoi_liq_s5(i,m,j)
h2osoi_liq_buf(m,-3) = h2osoi_liq_s4(i,m,j)
h2osoi_liq_buf(m,-2) = h2osoi_liq_s3(i,m,j)
h2osoi_liq_buf(m,-1) = h2osoi_liq_s2(i,m,j)
h2osoi_liq_buf(m,0) = h2osoi_liq_s1(i,m,j)
h2osoi_liq_buf(m,1) = h2osoi_liq1(i,m,j)
h2osoi_liq_buf(m,2) = h2osoi_liq2(i,m,j)
h2osoi_liq_buf(m,3) = h2osoi_liq3(i,m,j)
h2osoi_liq_buf(m,4) = h2osoi_liq4(i,m,j)
h2osoi_liq_buf(m,5) = h2osoi_liq5(i,m,j)
h2osoi_liq_buf(m,6) = h2osoi_liq6(i,m,j)
h2osoi_liq_buf(m,7) = h2osoi_liq7(i,m,j)
h2osoi_liq_buf(m,8) = h2osoi_liq8(i,m,j)
h2osoi_liq_buf(m,9) = h2osoi_liq9(i,m,j)
h2osoi_liq_buf(m,10) = h2osoi_liq10(i,m,j)
h2osoi_ice_buf(m,-4) = h2osoi_ice_s5(i,m,j)
h2osoi_ice_buf(m,-3) = h2osoi_ice_s4(i,m,j)
h2osoi_ice_buf(m,-2) = h2osoi_ice_s3(i,m,j)
h2osoi_ice_buf(m,-1) = h2osoi_ice_s2(i,m,j)
h2osoi_ice_buf(m,0) = h2osoi_ice_s1(i,m,j)
h2osoi_ice_buf(m,1) = h2osoi_ice1(i,m,j)
h2osoi_ice_buf(m,2) = h2osoi_ice2(i,m,j)
h2osoi_ice_buf(m,3) = h2osoi_ice3(i,m,j)
h2osoi_ice_buf(m,4) = h2osoi_ice4(i,m,j)
h2osoi_ice_buf(m,5) = h2osoi_ice5(i,m,j)
h2osoi_ice_buf(m,6) = h2osoi_ice6(i,m,j)
h2osoi_ice_buf(m,7) = h2osoi_ice7(i,m,j)
h2osoi_ice_buf(m,8) = h2osoi_ice8(i,m,j)
h2osoi_ice_buf(m,9) = h2osoi_ice9(i,m,j)
h2osoi_ice_buf(m,10) = h2osoi_ice10(i,m,j)
t_soisno_buf(m,-4) = t_soisno_s5(i,m,j)
t_soisno_buf(m,-3) = t_soisno_s4(i,m,j)
t_soisno_buf(m,-2) = t_soisno_s3(i,m,j)
t_soisno_buf(m,-1) = t_soisno_s2(i,m,j)
t_soisno_buf(m,0) = t_soisno_s1(i,m,j)
t_soisno_buf(m,1) = t_soisno1(i,m,j)
t_soisno_buf(m,2) = t_soisno2(i,m,j)
t_soisno_buf(m,3) = t_soisno3(i,m,j)
t_soisno_buf(m,4) = t_soisno4(i,m,j)
t_soisno_buf(m,5) = t_soisno5(i,m,j)
t_soisno_buf(m,6) = t_soisno6(i,m,j)
t_soisno_buf(m,7) = t_soisno7(i,m,j)
t_soisno_buf(m,8) = t_soisno8(i,m,j)
t_soisno_buf(m,9) = t_soisno9(i,m,j)
t_soisno_buf(m,10) = t_soisno10(i,m,j)
t_lake_buf(m,1) = t_lake1(i,m,j)
t_lake_buf(m,2) = t_lake2(i,m,j)
t_lake_buf(m,3) = t_lake3(i,m,j)
t_lake_buf(m,4) = t_lake4(i,m,j)
t_lake_buf(m,5) = t_lake5(i,m,j)
t_lake_buf(m,6) = t_lake6(i,m,j)
t_lake_buf(m,7) = t_lake7(i,m,j)
t_lake_buf(m,8) = t_lake8(i,m,j)
t_lake_buf(m,9) = t_lake9(i,m,j)
t_lake_buf(m,10) = t_lake10(i,m,j)
h2osoi_vol_buf(m,1) = h2osoi_vol1(i,m,j)
h2osoi_vol_buf(m,2) = h2osoi_vol2(i,m,j)
h2osoi_vol_buf(m,3) = h2osoi_vol3(i,m,j)
h2osoi_vol_buf(m,4) = h2osoi_vol4(i,m,j)
h2osoi_vol_buf(m,5) = h2osoi_vol5(i,m,j)
h2osoi_vol_buf(m,6) = h2osoi_vol6(i,m,j)
h2osoi_vol_buf(m,7) = h2osoi_vol7(i,m,j)
h2osoi_vol_buf(m,8) = h2osoi_vol8(i,m,j)
h2osoi_vol_buf(m,9) = h2osoi_vol9(i,m,j)
h2osoi_vol_buf(m,10) = h2osoi_vol10(i,m,j)
t_grnd_buf(m) = t_grnd(i,m,j)
t_veg_buf(m) = t_veg(i,m,j)
h2ocan_buf(m) = h2ocan(i,m,j)
h2ocan_col_buf(m) = h2ocan_col(i,m,j)
h2osno_buf(m) = h2osno(i,m,j)
albedosubgrid_buf(m) = albedosubgrid(i,m,j)
lhsubgrid_buf(m) = lhsubgrid(i,m,j)
hfxsubgrid_buf(m) = hfxsubgrid(i,m,j)
lwupsubgrid_buf(m)= lwupsubgrid(i,m,j)
q2subgrid_buf(m) = q2subgrid(i,m,j)
!ylu 01/14/09
sabvsubgrid_buf(m) = sabvsubgrid(i,m,j)
sabgsubgrid_buf(m) = sabgsubgrid(i,m,j)
nrasubgrid_buf(m) = nrasubgrid(i,m,j)
swupsubgrid_buf(m) = swupsubgrid(i,m,j)
!ylu 04/07/09 add three component of LH to output file
lhsoi_buf(m) = lhsoi(i,m,j)
lhveg_buf(m) = lhveg(i,m,j)
lhtran_buf(m) = lhtran(i,m,j)
!!!
#ifdef CN
!ADD_NEW_VAR 02/14/2011
tlai_buf(m) = dyntlai(i,m,j)
tsai_buf(m) = dyntsai(i,m,j)
htop_buf(m) = dyntop(i,m,j)
hbot_buf(m) = dynbot(i,m,j)
#endif
organic_buf(m) = organic(m)
t_ref2m_buf(m) = t_ref2m(i,m,j)
q_ref2m_buf(m) = q_ref2m(i,m,j)
#ifdef CN
!CROP CN VARS
!ylu 05/31/11
htmx_buf(m) = htmx(i,m,j)
croplive_buf(m) = croplive(i,m,j)
gdd1020_buf(m) = gdd1020(i,m,j)
gdd820_buf(m) = gdd820(i,m,j)
gdd020_buf(m) = gdd020(i,m,j)
grainc_buf(m) = grainc(i,m,j)
grainc_storage_buf(m) = grainc_storage(i,m,j)
grainc_xfer_buf(m) = grainc_xfer(i,m,j)
grainn_buf(m) = grainn(i,m,j)
grainn_storage_buf(m) = grainn_storage(i,m,j)
grainn_xfer_buf(m) = grainn_xfer(i,m,j)
days_active_buf(m) = days_active(i,m,j)
onset_flag_buf(m) = onset_flag(i,m,j)
onset_counter_buf(m) = onset_counter(i,m,j)
onset_gddflag_buf(m) = onset_gddflag(i,m,j)
onset_fdd_buf(m) = onset_fdd(i,m,j)
onset_gdd_buf(m) = onset_gdd(i,m,j)
onset_swi_buf(m) = onset_swi(i,m,j)
offset_flag_buf(m) = offset_flag(i,m,j)
offset_counter_buf(m) = offset_counter(i,m,j)
offset_fdd_buf(m) = offset_fdd(i,m,j)
offset_swi_buf(m) = offset_swi(i,m,j)
dayl_buf(m) = dayl(i,m,j)
annavg_t2m_buf(m) = annavg_t2m(i,m,j)
tempavg_t2m_buf(m) = tempavg_t2m(i,m,j)
tempsum_potential_gpp_buf(m) = tempsum_potential_gpp(i,m,j)
annsum_potential_gpp_buf(m) = annsum_potential_gpp(i,m,j)
tempmax_retransn_buf(m) = tempmax_retransn(i,m,j)
annmax_retransn_buf(m) = annmax_retransn(i,m,j)
prev_leafc_to_litter_buf(m) = prev_leafc_to_litter(i,m,j)
prev_frootc_to_litter_buf(m) = prev_frootc_to_litter(i,m,j)
tempsum_npp_buf(m) = tempsum_npp(i,m,j)
annsum_npp_buf(m) = annsum_npp(i,m,j)
leafc_buf(m) = leafc(i,m,j)
leafc_storage_buf(m) = leafc_storage(i,m,j)
leafc_xfer_buf(m) = leafc_xfer(i,m,j)
frootc_buf(m) = frootc(i,m,j)
frootc_storage_buf(m) = frootc_storage(i,m,j)
frootc_xfer_buf(m) = frootc_xfer(i,m,j)
livestemc_buf(m) = livestemc(i,m,j)
livestemc_storage_buf(m) = livestemc_storage(i,m,j)
livestemc_xfer_buf(m) = livestemc_xfer(i,m,j)
deadstemc_buf(m) = deadstemc(i,m,j)
deadstemc_storage_buf(m) = deadstemc_storage(i,m,j)
deadstemc_xfer_buf(m) = deadstemc_xfer(i,m,j)
livecrootc_buf(m) = livecrootc(i,m,j)
livecrootc_storage_buf(m) = livecrootc_storage(i,m,j)
livecrootc_xfer_buf(m) = livecrootc_xfer(i,m,j)
deadcrootc_buf(m) = deadcrootc(i,m,j)
deadcrootc_storage_buf(m) = deadcrootc_storage(i,m,j)
deadcrootc_xfer_buf(m) = deadcrootc_xfer(i,m,j)
cpool_buf(m) = cpool(i,m,j)
pft_ctrunc_buf(m) = pft_ctrunc(i,m,j)
leafn_buf(m) = leafn(i,m,j)
leafn_storage_buf(m) = leafn_storage(i,m,j)
leafn_xfer_buf(m) = leafn_xfer(i,m,j)
frootn_buf(m) = frootn(i,m,j)
frootn_storage_buf(m) = frootn_storage(i,m,j)
frootn_xfer_buf(m) = frootn_xfer(i,m,j)
livestemn_buf(m) = livestemn(i,m,j)
livestemn_storage_buf(m) = livestemn_storage(i,m,j)
livestemn_xfer_buf(m) = livestemn_xfer(i,m,j)
deadstemn_buf(m) = deadstemn(i,m,j)
deadstemn_storage_buf(m) = deadstemn_storage(i,m,j)
deadstemn_xfer_buf(m) = deadstemn_xfer(i,m,j)
livecrootn_buf(m) = livecrootn(i,m,j)
livecrootn_storage_buf(m) = livecrootn_storage(i,m,j)
livecrootn_xfer_buf(m) = livecrootn_xfer(i,m,j)
deadcrootn_buf(m) = deadcrootn(i,m,j)
deadcrootn_storage_buf(m) = deadcrootn_storage(i,m,j)
deadcrootn_xfer_buf(m) = deadcrootn_xfer(i,m,j)
npool_buf(m) = npool(i,m,j)
pft_ntrunc_buf(m) = pft_ntrunc(i,m,j)
gresp_storage_buf(m) = gresp_storage(i,m,j)
gresp_xfer_buf(m) = gresp_xfer(i,m,j)
xsmrpool_buf(m) = xsmrpool(i,m,j)
annsum_counter_buf(m) = annsum_counter(i,m,j)
cannsum_npp_buf(m) = cannsum_npp(i,m,j)
cannavg_t2m_buf(m) = cannavg_t2m(i,m,j)
wf_buf(m) = wf(i,m,j)
me_buf(m) = me(i,m,j)
mean_fire_prob_buf(m) = mean_fire_prob(i,m,j)
cwdc_buf(m) = cwdc(i,m,j)
litr1c_buf(m) = litr1c(i,m,j)
litr2c_buf(m) = litr2c(i,m,j)
litr3c_buf(m) = litr3c(i,m,j)
soil1c_buf(m) = soil1c(i,m,j)
soil2c_buf(m) = soil2c(i,m,j)
soil3c_buf(m) = soil3c(i,m,j)
soil4c_buf(m) = soil4c(i,m,j)
seedc_buf(m) = seedc(i,m,j)
col_ctrunc_buf(m) = col_ctrunc(i,m,j)
prod10c_buf(m) = prod10c(i,m,j)
prod100c_buf(m) = prod100c(i,m,j)
cwdn_buf(m) = cwdn(i,m,j)
litr1n_buf(m) = litr1n(i,m,j)
litr2n_buf(m) = litr2n(i,m,j)
litr3n_buf(m) = litr3n(i,m,j)
soil1n_buf(m) = soil1n(i,m,j)
soil2n_buf(m) = soil2n(i,m,j)
soil3n_buf(m) = soil3n(i,m,j)
soil4n_buf(m) = soil4n(i,m,j)
seedn_buf(m) = seedn(i,m,j)
col_ntrunc_buf(m) = col_ntrunc(i,m,j)
prod10n_buf(m) = prod10n(i,m,j)
prod100n_buf(m) = prod100n(i,m,j)
sminn_buf(m) = sminn(i,m,j)
totlitc_buf(m) = totlitc(i,m,j)
dwt_seedc_to_leaf_buf(m) = dwt_seedc_to_leaf(i,m,j)
dwt_seedc_to_deadstem_buf(m) = dwt_seedc_to_deadstem(i,m,j)
dwt_conv_cflux_buf(m) = dwt_conv_cflux(i,m,j)
dwt_prod10c_gain_buf(m) = dwt_prod10c_gain(i,m,j)
dwt_prod100c_gain_buf(m) = dwt_prod100c_gain(i,m,j)
prod100c_loss_buf(m) = prod100c_loss(i,m,j)
dwt_frootc_to_litr1c_buf(m) = dwt_frootc_to_litr1c(i,m,j)
dwt_frootc_to_litr2c_buf(m) = dwt_frootc_to_litr2c(i,m,j)
dwt_frootc_to_litr3c_buf(m) = dwt_frootc_to_litr3c(i,m,j)
dwt_livecrootc_to_cwdc_buf(m) = dwt_livecrootc_to_cwdc(i,m,j)
dwt_deadcrootc_to_cwdc_buf(m) = dwt_deadcrootc_to_cwdc(i,m,j)
dwt_seedn_to_leaf_buf(m) = dwt_seedn_to_leaf(i,m,j)
dwt_seedn_to_deadstem_buf(m) = dwt_seedn_to_deadstem(i,m,j)
dwt_conv_nflux_buf(m) = dwt_conv_nflux(i,m,j)
dwt_prod10n_gain_buf(m) = dwt_prod10n_gain(i,m,j)
dwt_prod100n_gain_buf(m) = dwt_prod100n_gain(i,m,j)
prod100n_loss_buf(m) = prod100n_loss(i,m,j)
dwt_frootn_to_litr1n_buf(m) = dwt_frootn_to_litr1n(i,m,j)
dwt_frootn_to_litr2n_buf(m) = dwt_frootn_to_litr2n(i,m,j)
dwt_frootn_to_litr3n_buf(m) = dwt_frootn_to_litr3n(i,m,j)
dwt_livecrootn_to_cwdn_buf(m) = dwt_livecrootn_to_cwdn(i,m,j)
dwt_deadcrootn_to_cwdn_buf(m) = dwt_deadcrootn_to_cwdn(i,m,j)
retransn_buf(m) = retransn(i,m,j)
#endif
end do !!!!!!!!!!!!!!!!! m=1, maxpatch
! if(lndmsk == 1) then
call clm(forc_txy_buf ,forc_uxy_buf ,forc_vxy_buf &
,forc_qxy_buf ,zgcmxy_buf ,prec_buf &
,flwdsxy_buf ,forc_sols_buf ,forc_soll_buf &
,forc_solsd_buf ,forc_solld_buf ,forc_pbot_buf &
,forc_psrfxy_buf ,ivgtyp(i,j) ,isltyp(i,j) &
,lndmsk ,xlat_buf ,xlon_buf &
,area_buf ,dtt ,myr &
,mon ,mday ,msec &
,calday ,myr1 ,mon1 &
,mday1 ,msec1 ,calday1 &
,mbdate ,qsfxy_buf ,qdnxy_buf &
,snl1(i,:,j) ,snowdp_buf ,snw_rds_buf &
,dzclm ,zclm ,ziclm &
,h2osno_buf ,h2osoi_liq_buf ,h2osoi_ice_buf &
,t_grnd_buf ,t_soisno_buf ,t_lake_buf &
,t_veg_buf ,h2ocan_buf ,h2ocan_col_buf &
,h2osoi_vol_buf ,wtc_buf ,wtp_buf &
,numc(i,j) ,nump(i,j) &
,t_ref2m_buf ,albxy_buf ,tsxy_buf, trefxy_buf &
,shxy_buf ,lhxy_buf ,nstep &
,inest ,i ,j &
,soiflx_buf ,sabv_buf ,sabg_buf &
,lwup_buf ,znt_buf ,q_ref2m_buf &
,rhoxy_buf &
,albedosubgrid_buf ,lhsubgrid_buf ,hfxsubgrid_buf &
,lwupsubgrid_buf ,q2subgrid_buf ,sabvsubgrid_buf &
,sabgsubgrid_buf ,nrasubgrid_buf ,swupsubgrid_buf &
,lhsoi_buf ,lhveg_buf ,lhtran_buf &
,organic_buf ,efisop_buf ,gti_buf &
,alswnirdir_buf ,alswnirdif_buf,alswvisdir_buf,alswvisdif_buf&
#ifdef CN
!CROP and CN restart and outputs
,forc_ndepxy_buf ,organic_buf ,tlai_buf ,tsai_buf,htop_buf,hbot_buf & !ADD_NEW_VAR
,htmx_buf,croplive_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf &
#endif
)
if(albxy_buf == 1) albxy_buf = 0.991
albxy(i,j) = albxy_buf
call CLMDebug('get albxy')
snowh(i,j) = sum(snowdp_buf(1:numc(i,j))*wtc_buf(1:numc(i,j)))
call CLMDebug('get snowh')
snow(i,j) = sum(h2osno_buf(1:numc(i,j))*wtc_buf(1:numc(i,j)))
call CLMDebug('get snow')
canwat(i,j) = sum(h2ocan_buf(1:nump(i,j))*wtp_buf(1:nump(i,j)))
call CLMDebug('get canwat')
if (ivgtyp(i,j) /= 16 .and. ivgtyp(i,j) /= 24) then
do k=1,nlevgrnd
smois(i,k,j) = sum(h2osoi_vol_buf(1:numc(i,j),k)*wtc_buf(1:numc(i,j)))
tslb (i,k,j) = sum(t_soisno_buf(1:numc(i,j),k)*wtc_buf(1:numc(i,j)))
end do !over levels
end if
call CLMDebug('get tslb')
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
tsxy(i,j) = tsxy_buf
qsfxy(i,j) = qsfxy_buf
qdnxy(i,j) = qdnxy_buf
soiflx(i,j) = soiflx_buf
sabv(i,j) = sabv_buf
sabg(i,j) = sabg_buf
lwup(i,j) = lwup_buf
znt(i,j) = znt_buf
z0(i,j) = znt(i,j)
alswvisdir(i,j) = alswvisdir_buf
alswvisdif(i,j) = alswvisdif_buf
alswnirdir(i,j) = alswnirdir_buf
alswnirdif(i,j) = alswnirdif_buf
t2clm(i,j) = trefxy_buf
!Accumulate T2 MAX/MIN between history interval --Yaqiong Lu
if(mod(dt*(nstep-1),60.*history_interval)==0) then
t2m_max(i,j) = 0.0
t2m_min(i,j) = 999.0
else
t2m_max(i,j) = max(t2m_max(i,j),t2clm(i,j)) !the t2m_max/min will save the max/min along each history interval chunk.
t2m_min(i,j) = min(t2m_min(i,j),t2clm(i,j))
end if
call CLMDebug('module clm mark1')
emiss(i,j) = lwup(i,j)/(sb * tsxy(i,j)**4)
shxy(i,j) = shxy_buf
lhxy(i,j) = lhxy_buf
if(tsxy(i,j)>=tfrz) then
qfx(i,j) = lhxy_buf/hvap ! heat flux (W/m^2)=>mass flux(kg/(sm^2))
else
qfx(i,j) = lhxy_buf/hsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2))
end if
qsfc(i,j) = forc_qxy(i,1,j) +qfx(i,j)/(rhoxy_buf*chs(i,j))
do m=1,maxpatch
snowdp(i,m,j) = snowdp_buf(m)
! snowage(i,m,j) = snowage_buf(m)
snl(i,m,j) = snl1(i,m,j)
dzsnow5(i,m,j) = dzclm(m,-4)
dzsnow4(i,m,j) = dzclm(m,-3)
dzsnow3(i,m,j) = dzclm(m,-2)
dzsnow2(i,m,j) = dzclm(m,-1)
dzsnow1(i,m,j) = dzclm(m,0)
snowrds5(i,m,j) = snw_rds_buf(m,-4)
snowrds4(i,m,j) = snw_rds_buf(m,-3)
snowrds3(i,m,j) = snw_rds_buf(m,-2)
snowrds2(i,m,j) = snw_rds_buf(m,-1)
snowrds1(i,m,j) = snw_rds_buf(m,0)
h2osno(i,m,j) = h2osno_buf(m)
t_grnd(i,m,j) = t_grnd_buf(m)
t_veg(i,m,j) = t_veg_buf(m)
h2ocan(i,m,j) = h2ocan_buf(m)
h2ocan_col(i,m,j) = h2ocan_col_buf(m)
wtc(i,m,j) = wtc_buf(m)
wtp(i,m,j) = wtp_buf(m)
call CLMDebug('module clm mark2')
h2osoi_liq_s5(i,m,j) = h2osoi_liq_buf(m,-4)
h2osoi_liq_s4(i,m,j) = h2osoi_liq_buf(m,-3)
h2osoi_liq_s3(i,m,j) = h2osoi_liq_buf(m,-2)
h2osoi_liq_s2(i,m,j) = h2osoi_liq_buf(m,-1)
h2osoi_liq_s1(i,m,j) = h2osoi_liq_buf(m,0)
h2osoi_liq1(i,m,j) = h2osoi_liq_buf(m,1)
h2osoi_liq2(i,m,j) = h2osoi_liq_buf(m,2)
h2osoi_liq3(i,m,j) = h2osoi_liq_buf(m,3)
h2osoi_liq4(i,m,j) = h2osoi_liq_buf(m,4)
h2osoi_liq5(i,m,j) = h2osoi_liq_buf(m,5)
h2osoi_liq6(i,m,j) = h2osoi_liq_buf(m,6)
h2osoi_liq7(i,m,j) = h2osoi_liq_buf(m,7)
h2osoi_liq8(i,m,j) = h2osoi_liq_buf(m,8)
h2osoi_liq9(i,m,j) = h2osoi_liq_buf(m,9)
h2osoi_liq10(i,m,j) = h2osoi_liq_buf(m,10)
h2osoi_ice_s5(i,m,j) = h2osoi_ice_buf(m,-4)
h2osoi_ice_s4(i,m,j) = h2osoi_ice_buf(m,-3)
h2osoi_ice_s3(i,m,j) = h2osoi_ice_buf(m,-2)
h2osoi_ice_s2(i,m,j) = h2osoi_ice_buf(m,-1)
h2osoi_ice_s1(i,m,j) = h2osoi_ice_buf(m,0)
h2osoi_ice1(i,m,j) = h2osoi_ice_buf(m,1)
h2osoi_ice2(i,m,j) = h2osoi_ice_buf(m,2)
h2osoi_ice3(i,m,j) = h2osoi_ice_buf(m,3)
h2osoi_ice4(i,m,j) = h2osoi_ice_buf(m,4)
h2osoi_ice5(i,m,j) = h2osoi_ice_buf(m,5)
h2osoi_ice6(i,m,j) = h2osoi_ice_buf(m,6)
h2osoi_ice7(i,m,j) = h2osoi_ice_buf(m,7)
h2osoi_ice8(i,m,j) = h2osoi_ice_buf(m,8)
h2osoi_ice9(i,m,j) = h2osoi_ice_buf(m,9)
h2osoi_ice10(i,m,j) = h2osoi_ice_buf(m,10)
call CLMDebug('module clm mark3')
t_soisno_s5(i,m,j) = t_soisno_buf(m,-4)
t_soisno_s4(i,m,j) = t_soisno_buf(m,-3)
t_soisno_s3(i,m,j) = t_soisno_buf(m,-2)
t_soisno_s2(i,m,j) = t_soisno_buf(m,-1)
t_soisno_s1(i,m,j) = t_soisno_buf(m,0)
t_soisno1(i,m,j) = t_soisno_buf(m,1)
t_soisno2(i,m,j) = t_soisno_buf(m,2)
t_soisno3(i,m,j) = t_soisno_buf(m,3)
t_soisno4(i,m,j) = t_soisno_buf(m,4)
t_soisno5(i,m,j) = t_soisno_buf(m,5)
t_soisno6(i,m,j) = t_soisno_buf(m,6)
t_soisno7(i,m,j) = t_soisno_buf(m,7)
t_soisno8(i,m,j) = t_soisno_buf(m,8)
t_soisno9(i,m,j) = t_soisno_buf(m,9)
t_soisno10(i,m,j) = t_soisno_buf(m,10)
t_lake1(i,m,j) = t_lake_buf(m,1)
t_lake2(i,m,j) = t_lake_buf(m,2)
t_lake3(i,m,j) = t_lake_buf(m,3)
t_lake4(i,m,j) = t_lake_buf(m,4)
t_lake5(i,m,j) = t_lake_buf(m,5)
t_lake6(i,m,j) = t_lake_buf(m,6)
t_lake7(i,m,j) = t_lake_buf(m,7)
t_lake8(i,m,j) = t_lake_buf(m,8)
t_lake9(i,m,j) = t_lake_buf(m,9)
t_lake10(i,m,j) = t_lake_buf(m,10)
h2osoi_vol1(i,m,j) = h2osoi_vol_buf(m,1)
h2osoi_vol2(i,m,j) = h2osoi_vol_buf(m,2)
h2osoi_vol3(i,m,j) = h2osoi_vol_buf(m,3)
h2osoi_vol4(i,m,j) = h2osoi_vol_buf(m,4)
h2osoi_vol5(i,m,j) = h2osoi_vol_buf(m,5)
h2osoi_vol6(i,m,j) = h2osoi_vol_buf(m,6)
h2osoi_vol7(i,m,j) = h2osoi_vol_buf(m,7)
h2osoi_vol8(i,m,j) = h2osoi_vol_buf(m,8)
h2osoi_vol9(i,m,j) = h2osoi_vol_buf(m,9)
h2osoi_vol10(i,m,j) = h2osoi_vol_buf(m,10)
call CLMDebug('module clm mark4')
t_ref2m(i,m,j) = t_ref2m_buf(m)
q_ref2m(i,m,j) = q_ref2m_buf(m)
!!!!New patch-level variables
albedosubgrid(i,m,j)= albedosubgrid_buf(m)
lhsubgrid(i,m,j) = lhsubgrid_buf(m)
hfxsubgrid(i,m,j) = hfxsubgrid_buf(m)
lwupsubgrid(i,m,j) = lwupsubgrid_buf(m)
q2subgrid(i,m,j) = q2subgrid_buf(m)
!!ylu 01/14/09
sabvsubgrid(i,m,j) = sabvsubgrid_buf(m)
sabgsubgrid(i,m,j) = sabgsubgrid_buf(m)
nrasubgrid(i,m,j) = nrasubgrid_buf(m)
swupsubgrid(i,m,j) = swupsubgrid_buf(m)
!ylu 04/07/09
lhsoi(i,m,j) = lhsoi_buf(m)
lhveg(i,m,j) = lhveg_buf(m)
lhtran(i,m,j) = lhtran_buf(m)
#ifdef CN
dyntlai(i,m,j) = tlai_buf(m)
dyntsai(i,m,j) = tsai_buf(m)
dyntop(i,m,j) = htop_buf(m)
dynbot(i,m,j) = hbot_buf(m)
call CLMDebug('module clm mark5')
!CROP CN VARS
!ylu 05/31/11
htmx(i,m,j) = htmx_buf(m)
croplive(i,m,j) = croplive_buf(m)
gdd1020(i,m,j) = gdd1020_buf(m)
gdd820(i,m,j) = gdd820_buf(m)
gdd020(i,m,j) = gdd020_buf(m)
grainc(i,m,j) = grainc_buf(m)
grainc_storage(i,m,j) = grainc_storage_buf(m)
grainc_xfer(i,m,j) = grainc_xfer_buf(m)
grainn(i,m,j) = grainn_buf(m)
grainn_storage(i,m,j) = grainn_storage_buf(m)
grainn_xfer(i,m,j) = grainn_xfer_buf(m)
days_active(i,m,j) = days_active_buf(m)
onset_flag(i,m,j) = onset_flag_buf(m)
onset_counter(i,m,j) = onset_counter_buf(m)
onset_gddflag(i,m,j) = onset_gddflag_buf(m)
onset_fdd(i,m,j) = onset_fdd_buf(m)
onset_gdd(i,m,j) = onset_gdd_buf(m)
onset_swi(i,m,j) = onset_swi_buf(m)
offset_flag(i,m,j) = offset_flag_buf(m)
offset_counter(i,m,j) = offset_counter_buf(m)
offset_fdd(i,m,j) = offset_fdd_buf(m)
offset_swi(i,m,j) = offset_swi_buf(m)
dayl(i,m,j) = dayl_buf(m)
annavg_t2m(i,m,j) = annavg_t2m_buf(m)
tempavg_t2m(i,m,j) = tempavg_t2m_buf(m)
tempsum_potential_gpp(i,m,j) = tempsum_potential_gpp_buf(m)
annsum_potential_gpp(i,m,j) = annsum_potential_gpp_buf(m)
tempmax_retransn(i,m,j) = tempmax_retransn_buf(m)
annmax_retransn(i,m,j) = annmax_retransn_buf(m)
prev_leafc_to_litter(i,m,j) = prev_leafc_to_litter_buf(m)
prev_frootc_to_litter(i,m,j) = prev_frootc_to_litter_buf(m)
tempsum_npp(i,m,j) = tempsum_npp_buf(m)
annsum_npp(i,m,j) = annsum_npp_buf(m)
leafc(i,m,j) = annsum_npp_buf(m)
leafc_storage(i,m,j) = leafc_storage_buf(m)
leafc_xfer(i,m,j) = leafc_xfer_buf(m)
frootc(i,m,j) = frootc_buf(m)
frootc_storage(i,m,j) = frootc_storage_buf(m)
frootc_xfer(i,m,j) = frootc_xfer_buf(m)
livestemc(i,m,j) = livestemc_buf(m)
livestemc_storage(i,m,j) = livestemc_storage_buf(m)
livestemc_xfer(i,m,j) = livestemc_xfer_buf(m)
deadstemc(i,m,j) = deadstemc_buf(m)
deadstemc_storage(i,m,j) = deadstemc_storage_buf(m)
deadstemc_xfer(i,m,j) = deadstemc_xfer_buf(m)
livecrootc(i,m,j) = livecrootc_buf(m)
livecrootc_storage(i,m,j) = livecrootc_storage_buf(m)
livecrootc_xfer(i,m,j) = livecrootc_xfer_buf(m)
deadcrootc(i,m,j) = deadcrootc_buf(m)
deadcrootc_storage(i,m,j) = deadcrootc_storage_buf(m)
deadcrootc_xfer(i,m,j) = deadcrootc_xfer_buf(m)
cpool(i,m,j) = cpool_buf(m)
pft_ctrunc(i,m,j) = pft_ctrunc_buf(m)
leafn(i,m,j) = leafn_buf(m)
leafn_storage(i,m,j) = leafn_storage_buf(m)
leafn_xfer(i,m,j) = leafn_xfer_buf(m)
frootn(i,m,j) = frootn_buf(m)
frootn_storage(i,m,j) = frootn_storage_buf(m)
frootn_xfer(i,m,j) = frootn_xfer_buf(m)
livestemn(i,m,j) = livestemn_buf(m)
livestemn_storage(i,m,j) = livestemn_storage_buf(m)
livestemn_xfer(i,m,j) = livestemn_xfer_buf(m)
deadstemn(i,m,j) = deadstemn_buf(m)
deadstemn_storage(i,m,j) = deadstemn_storage_buf(m)
deadstemn_xfer(i,m,j) = deadstemn_xfer_buf(m)
livecrootn(i,m,j) = livecrootn_buf(m)
livecrootn_storage(i,m,j) = livecrootn_storage_buf(m)
livecrootn_xfer(i,m,j) = livecrootn_xfer_buf(m)
deadcrootn(i,m,j) = deadcrootn_buf(m)
deadcrootn_storage(i,m,j) = deadcrootn_storage_buf(m)
deadcrootn_xfer(i,m,j) = deadcrootn_xfer_buf(m)
npool(i,m,j) = npool_buf(m)
pft_ntrunc(i,m,j) = pft_ntrunc_buf(m)
gresp_storage(i,m,j) = gresp_storage_buf(m)
gresp_xfer(i,m,j) = gresp_xfer_buf(m)
xsmrpool(i,m,j) = xsmrpool_buf(m)
annsum_counter(i,m,j) = annsum_counter_buf(m)
cannsum_npp(i,m,j) = cannsum_npp_buf(m)
cannavg_t2m(i,m,j) = cannavg_t2m_buf(m)
wf(i,m,j) = wf_buf(m)
me(i,m,j) = me_buf(m)
mean_fire_prob(i,m,j) = mean_fire_prob_buf(m)
cwdc(i,m,j) = cwdc_buf(m)
litr1c(i,m,j) = litr1c_buf(m)
litr2c(i,m,j) = litr2c_buf(m)
litr3c(i,m,j) = litr3c_buf(m)
soil1c(i,m,j) = soil1c_buf(m)
soil2c(i,m,j) = soil2c_buf(m)
soil3c(i,m,j) = soil3c_buf(m)
soil4c(i,m,j) = soil4c_buf(m)
seedc(i,m,j) = seedc_buf(m)
col_ctrunc(i,m,j) = col_ctrunc_buf(m)
prod10c(i,m,j) = prod10c_buf(m)
prod100c(i,m,j) = prod100c_buf(m)
cwdn(i,m,j) = cwdn_buf(m)
litr1n(i,m,j) = litr1n_buf(m)
litr2n(i,m,j) = litr2n_buf(m)
litr3n(i,m,j) = litr3n_buf(m)
soil1n(i,m,j) = soil1n_buf(m)
soil2n(i,m,j) = soil2n_buf(m)
soil3n(i,m,j) = soil3n_buf(m)
soil4n(i,m,j) = soil4n_buf(m)
seedn(i,m,j) = seedn_buf(m)
col_ntrunc(i,m,j) = col_ntrunc_buf(m)
prod10n(i,m,j) = prod10n_buf(m)
prod100n(i,m,j) = prod100n_buf(m)
sminn(i,m,j) = sminn_buf(m)
totlitc(i,m,j) = totlitc_buf(m)
dwt_seedc_to_leaf(i,m,j) = dwt_seedc_to_leaf_buf(m)
dwt_seedc_to_deadstem(i,m,j) = dwt_seedc_to_deadstem_buf(m)
dwt_conv_cflux(i,m,j) = dwt_conv_cflux_buf(m)
dwt_prod10c_gain(i,m,j) = dwt_prod10c_gain_buf(m)
dwt_prod100c_gain(i,m,j) = dwt_prod100c_gain_buf(m)
prod100c_loss(i,m,j) = prod100c_loss_buf(m)
dwt_frootc_to_litr1c(i,m,j) = dwt_frootc_to_litr1c_buf(m)
dwt_frootc_to_litr2c(i,m,j) = dwt_frootc_to_litr2c_buf(m)
dwt_frootc_to_litr3c(i,m,j) = dwt_frootc_to_litr3c_buf(m)
dwt_livecrootc_to_cwdc(i,m,j) = dwt_livecrootc_to_cwdc_buf(m)
dwt_deadcrootc_to_cwdc(i,m,j) = dwt_deadcrootc_to_cwdc_buf(m)
dwt_seedn_to_leaf(i,m,j) = dwt_seedn_to_leaf_buf(m)
dwt_seedn_to_deadstem(i,m,j) = dwt_seedn_to_deadstem_buf(m)
dwt_conv_nflux(i,m,j) = dwt_conv_nflux_buf(m)
dwt_prod10n_gain(i,m,j) = dwt_prod10n_gain_buf(m)
dwt_prod100n_gain(i,m,j) = dwt_prod100n_gain_buf(m)
prod100n_loss(i,m,j) = prod100n_loss_buf(m)
dwt_frootn_to_litr1n(i,m,j) = dwt_frootn_to_litr1n_buf(m)
dwt_frootn_to_litr2n(i,m,j) = dwt_frootn_to_litr2n_buf(m)
dwt_frootn_to_litr3n(i,m,j) = dwt_frootn_to_litr3n_buf(m)
dwt_livecrootn_to_cwdn(i,m,j) = dwt_livecrootn_to_cwdn_buf(m)
dwt_deadcrootn_to_cwdn(i,m,j) = dwt_deadcrootn_to_cwdn_buf(m)
retransn(i,m,j) = retransn_buf(m)
#endif
end do !!!!!!!!!!!!! m = 1, maxpatch
end if
call CLMDebug('good before call urban')
IF (sf_urban_physics == 1 ) THEN ! Beginning of UCM CALL if block
!--------------------------------------
! URBAN CANOPY MODEL START - urban
!--------------------------------------
! Input variables lsm --> urban
IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. &
IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN
! Call urban
forc_sols_buf = swd_buf*0.35
forc_soll_buf = swd_buf*0.35
forc_solsd_buf = swd_buf*0.15
forc_solld_buf = swd_buf*0.15
area_buf = dx*dx/1.e6 !(km^2)
forc_pbot_buf = ps(i,1,j) ! Pa
forc_txy_buf = forc_txy(i,1,j)
forc_uxy_buf = forc_uxy(i,1,j)
forc_vxy_buf = forc_vxy(i,1,j)
forc_qxy_buf = forc_qxy(i,1,j)
zgcmxy_buf = zgcmxy(i,1,j)
prec_buf = prec(i,j)/dtt ! mm/s
flwdsxy_buf = flwdsxy(i,j)
forc_psrfxy_buf= ps(i,1,j) ! Pa
!
UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial)
TA_URB = forc_txy(i,1,j) ! [K]
QA_URB = forc_qxy(i,1,j) ! [kg/kg]
UA_URB = SQRT(forc_uxy(i,1,j)**2.+forc_vxy(i,1,j)**2.)
U1_URB = forc_uxy(i,1,j)
V1_URB = forc_vxy(i,1,j)
IF(UA_URB < 1.) UA_URB=1. ! [m/s]
SSG_URB = swd_buf ! [W/m/m]
SSGD_URB = 0.8*swd_buf ! [W/m/m]
SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m]
LLG_URB = flwdsxy(i,j) ! [W/m/m]
RAIN_URB = prec(i,j) ! [mm]
RHOO_URB = ps(i,1,j)/(287.04 * forc_txy(i,1,j) * (1.0+ 0.61 * forc_qxy(i,1,j))) ![kg/m/m/m]
ZA_URB = zgcmxy_buf ! [m]
DELT_URB = DT ! [sec]
XLAT_URB = XLAT_URB2D(I,J) ! [deg]
COSZ_URB = COSZ_URB2D(I,J) !
OMG_URB = OMG_URB2D(I,J) !
ZNT_URB = ZNT(I,J)
LSOLAR_URB = .FALSE.
TR_URB = TR_URB2D(I,J)
TB_URB = TB_URB2D(I,J)
TG_URB = TG_URB2D(I,J)
TC_URB = TC_URB2D(I,J)
QC_URB = QC_URB2D(I,J)
UC_URB = UC_URB2D(I,J)
DO K = 1,num_roof_layers
TRL_URB(K) = TRL_URB3D(I,K,J)
END DO
DO K = 1,num_wall_layers
TBL_URB(K) = TBL_URB3D(I,K,J)
END DO
DO K = 1,num_road_layers
TGL_URB(K) = TGL_URB3D(I,K,J)
END DO
XXXR_URB = XXXR_URB2D(I,J)
XXXB_URB = XXXB_URB2D(I,J)
XXXG_URB = XXXG_URB2D(I,J)
XXXC_URB = XXXC_URB2D(I,J)
!
CHS_URB = CHS(I,J)
CHS2_URB = CHS2(I,J)
! Jin
IF (PRESENT(CMR_SFCDIF)) THEN
CMR_URB = CMR_SFCDIF(I,J)
CHR_URB = CHR_SFCDIF(I,J)
CMC_URB = CMC_SFCDIF(I,J)
CHC_URB = CHC_SFCDIF(I,J)
ENDIF
! initialize NUDAPT variables to zero
lp_urb = 0.
lb_urb = 0.
hgt_urb = 0.
mh_urb = 0.
stdh_urb = 0.
do k = 1,4
lf_urb(k) = 0.
enddo
frc_urb = FRC_URB2D(I,J)
check = 0.
!
! Call urban
CALL urban(LSOLAR_URB, & ! I
num_roof_layers,num_wall_layers,num_road_layers, & ! C
DZR,DZB,DZG, & ! C
UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I
SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB, & ! I
ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB, & ! I
XLAT_URB,DELT_URB,ZNT_URB, & ! I
CHS_URB, CHS2_URB, & ! I
TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB, & ! H
TRL_URB,TBL_URB,TGL_URB, & ! H
XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB, & ! H
TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB, & ! O
SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O
GZ1OZ0_URB, & !O
CMR_URB, CHR_URB, CMC_URB, CHC_URB, &
U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O
UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0
hgt_urb,frc_urb,lb_urb, check)
TS_URB2D(I,J) = TS_URB
albxy(i,j) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*albxy_buf ![-]
shxy(i,j) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*shxy_buf ![W/m/m]
qfx(i,j) = FRC_URB2D(I,J)*LH_KINEMATIC_URB &
+ (1-FRC_URB2D(I,J))*qfx(i,j) ![kg/m/m/s]
lhxy(i,j) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*lhxy_buf ![W/m/m]
soiflx(i,j) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*soiflx_buf ![W/m/m]
tsxy(i,j) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*tsxy_buf ![K]
qsfc(i,j) = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*qsfc(i,j) ![-]
! Renew Urban State Varialbes
TR_URB2D(I,J) = TR_URB
TB_URB2D(I,J) = TB_URB
TG_URB2D(I,J) = TG_URB
TC_URB2D(I,J) = TC_URB
QC_URB2D(I,J) = QC_URB
UC_URB2D(I,J) = UC_URB
DO K = 1,num_roof_layers
TRL_URB3D(I,K,J) = TRL_URB(K)
END DO
DO K = 1,num_wall_layers
TBL_URB3D(I,K,J) = TBL_URB(K)
END DO
DO K = 1,num_road_layers
TGL_URB3D(I,K,J) = TGL_URB(K)
END DO
XXXR_URB2D(I,J) = XXXR_URB
XXXB_URB2D(I,J) = XXXB_URB
XXXG_URB2D(I,J) = XXXG_URB
XXXC_URB2D(I,J) = XXXC_URB
SH_URB2D(I,J) = SH_URB
LH_URB2D(I,J) = LH_URB
G_URB2D(I,J) = G_URB
RN_URB2D(I,J) = RN_URB
PSIM_URB2D(I,J) = PSIM_URB
PSIH_URB2D(I,J) = PSIH_URB
GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB
U10_URB2D(I,J) = U10_URB
V10_URB2D(I,J) = V10_URB
TH2_URB2D(I,J) = TH2_URB
Q2_URB2D(I,J) = Q2_URB
UST_URB2D(I,J) = UST_URB
AKMS_URB2D(I,J) = vkc * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J))
IF (PRESENT(CMR_SFCDIF)) THEN
CMR_SFCDIF(I,J) = CMR_URB
CHR_SFCDIF(I,J) = CHR_URB
CMC_SFCDIF(I,J) = CMC_URB
CHC_SFCDIF(I,J) = CHC_URB
ENDIF
END IF
ENDIF ! end of urban CALL if block
do m=1,maxpatch
if(snl(i,m,j)<-10 .or. snl(i,m,j) >10) found=.true.
end do
if(found) then
write(6,*) 'in module_sf_clm, right after clm(), found snl ERROR! at i=',i,'j=',j
found=.false.
end if
end do ! of i loop
end do ! of j loop
do i=its,ite
do j=jts,jte
do m=1,maxpatch
if(snl(i,m,j)<-10 .or. snl(i,m,j) >10) found=.true.
end do
if(found) then
write(6,*) 'in module_sf_clm, finish all clm loop, found snl ERROR! at i=',i,'j=',j
write(6,*) 'snl(',i,':',j,')=',snl(i,:,j)
found=.false.
end if
end do
end do
call CLMDebug('clmdrv() success finished') !DEL
end subroutine clmdrv
!------------------------------------------------------------------------
subroutine clminit(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & 1,18
SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW, &
ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,SH2O,ZS,DZS, &
FNDSOILW, FNDSNOWH, &
num_soil_layers, restart, &
allowed_to_read , &
ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte, &
maxpatch &
,numc,nump,snl, &
snowdp,wtc,wtp,h2osno,t_grnd,t_veg, &
h2ocan,h2ocan_col,t2m_max,t2m_min, &
t_ref2m,h2osoi_liq_s1, &
h2osoi_liq_s2,h2osoi_liq_s3,h2osoi_liq_s4, &
h2osoi_liq_s5,h2osoi_liq1,h2osoi_liq2, &
h2osoi_liq3,h2osoi_liq4,h2osoi_liq5,h2osoi_liq6, &
h2osoi_liq7,h2osoi_liq8,h2osoi_liq9,h2osoi_liq10, &
h2osoi_ice_s1,h2osoi_ice_s2, &
h2osoi_ice_s3,h2osoi_ice_s4,h2osoi_ice_s5, &
h2osoi_ice1,h2osoi_ice2,h2osoi_ice3,h2osoi_ice4, &
h2osoi_ice5,h2osoi_ice6,h2osoi_ice7, &
h2osoi_ice8,h2osoi_ice9,h2osoi_ice10, &
t_soisno_s1,t_soisno_s2,t_soisno_s3,t_soisno_s4, &
t_soisno_s5,t_soisno1,t_soisno2,t_soisno3, &
t_soisno4,t_soisno5,t_soisno6,t_soisno7, &
t_soisno8,t_soisno9,t_soisno10, &
dzsnow1,dzsnow2,dzsnow3,dzsnow4,dzsnow5, &
snowrds1,snowrds2,snowrds3,snowrds4,snowrds5, &
t_lake1,t_lake2,t_lake3,t_lake4,t_lake5, &
t_lake6,t_lake7,t_lake8,t_lake9,t_lake10, &
h2osoi_vol1,h2osoi_vol2,h2osoi_vol3, &
h2osoi_vol4,h2osoi_vol5,h2osoi_vol6, &
h2osoi_vol7,h2osoi_vol8, &
h2osoi_vol9,h2osoi_vol10, &
ht,xland,xice &
,albedosubgrid,lhsubgrid,hfxsubgrid,lwupsubgrid,q2subgrid &
,sabvsubgrid,sabgsubgrid,nrasubgrid,swupsubgrid, &
lhsoi,lhveg,lhtran &
!#ifdef CN
! ,dyntlai,dyntsai,dyntop,dynbot & !ADD_NEW_VAR
!#endif
)
USE module_wrf_error
use clm_varcon, only :snowage_tau,snowage_kappa,snowage_drdt0 &
,ss_alb_snw_drc,asm_prm_snw_drc &
,ext_cff_mss_snw_drc,ss_alb_snw_dfs,asm_prm_snw_dfs &
,ext_cff_mss_snw_dfs &
,xx_ss_alb_snw_drc &
,xx_asm_prm_snw_drc &
,xx_ext_cff_mss_snw_drc &
,xx_ss_alb_snw_dfs &
,xx_asm_prm_snw_dfs &
,xx_ext_cff_mss_snw_dfs &
,xx_snowage_tau &
,xx_snowage_kappa &
,xx_snowage_drdt0 &
,idx_Mie_snw_mx &
,idx_T_max &
,idx_Tgrd_max &
,idx_rhos_max &
,numrad_snw
!New in CLM4_crop
!#if (defined CROP)
! USE CropIniMod , only : initialcrop
!#endif
implicit none
INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte
logical, external :: wrf_dm_on_monitor
integer :: ix
INTEGER, INTENT(IN) :: num_soil_layers,maxpatch
LOGICAL , INTENT(IN) :: restart , allowed_to_read
REAL, DIMENSION( num_soil_layers), INTENT(INOUT) :: zs, dzs
REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
INTENT(INOUT) :: SMOIS, & !Total soil moisture
SH2O, & !liquid soil moisture
TSLB !STEMP
REAL, DIMENSION( ims:ime, jms:jme ) , &
INTENT(INOUT) :: SNOW, &
SNOWH, &
SNOWC, &
CANWAT, &
SMSTAV, &
SMSTOT, &
SFCRUNOFF, &
UDRUNOFF, &
ACSNOW, &
VEGFRA, &
ACSNOM
REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: HT
INTEGER, DIMENSION( ims:ime, jms:jme ) , &
INTENT(IN) :: IVGTYP, &
ISLTYP
REAL, DIMENSION( ims:ime, jms:jme ) , &
INTENT(IN) :: XLAND,xice
LOGICAL, DIMENSION( ims:ime, jms:jme ) :: lake
LOGICAL, INTENT(IN) :: FNDSOILW , &
FNDSNOWH
integer, dimension(ims:ime,jms:jme ),intent(inout) :: numc,nump
integer, dimension(ims:ime,1:maxpatch,jms:jme ),intent(inout) :: snl
real, dimension(ims:ime,jms:jme ),intent(inout) :: t2m_max,t2m_min
real, dimension(ims:ime,1:maxpatch,jms:jme ),intent(inout) :: &
snowdp,wtc,wtp,h2osno,t_grnd,t_veg, &
h2ocan,h2ocan_col, &
t_ref2m,h2osoi_liq_s1, &
h2osoi_liq_s2,h2osoi_liq_s3,h2osoi_liq_s4, &
h2osoi_liq_s5,h2osoi_liq1,h2osoi_liq2, &
h2osoi_liq3,h2osoi_liq4,h2osoi_liq5,h2osoi_liq6, &
h2osoi_liq7,h2osoi_liq8,h2osoi_liq9,h2osoi_liq10, &
h2osoi_ice_s1,h2osoi_ice_s2, &
h2osoi_ice_s3,h2osoi_ice_s4,h2osoi_ice_s5, &
h2osoi_ice1,h2osoi_ice2,h2osoi_ice3,h2osoi_ice4, &
h2osoi_ice5,h2osoi_ice6,h2osoi_ice7, &
h2osoi_ice8,h2osoi_ice9,h2osoi_ice10, &
t_soisno_s1,t_soisno_s2,t_soisno_s3,t_soisno_s4, &
t_soisno_s5,t_soisno1,t_soisno2,t_soisno3, &
t_soisno4,t_soisno5,t_soisno6,t_soisno7, &
t_soisno8,t_soisno9,t_soisno10, &
dzsnow1,dzsnow2,dzsnow3,dzsnow4,dzsnow5, &
snowrds1,snowrds2,snowrds3,snowrds4,snowrds5, &
t_lake1,t_lake2,t_lake3,t_lake4,t_lake5, &
t_lake6,t_lake7,t_lake8,t_lake9,t_lake10, &
h2osoi_vol1,h2osoi_vol2,h2osoi_vol3, &
h2osoi_vol4,h2osoi_vol5,h2osoi_vol6, &
h2osoi_vol7,h2osoi_vol8, &
h2osoi_vol9,h2osoi_vol10, &
ALBEDOsubgrid,LHsubgrid,HFXsubgrid,LWUPsubgrid, &
Q2subgrid,SABVsubgrid,SABGsubgrid,NRAsubgrid,SWUPsubgrid,&
LHsoi,LHveg,LHtran
#ifdef CN
real, dimension(ims:ime,1:maxpatch,jms:jme ),intent(inout) :: dyntlai,dyntsai,dyntop,dynbot !ADD_NEW_VAR
#endif
INTEGER :: L
REAL :: BX, SMCMAX, PSISAT, FREE
INTEGER :: errflag
INTEGER :: itf,jtf,j,i,k,m
LOGICAL :: opened
integer :: lu_unit
call CLMDebug('Now in clminit.')
IF ( wrf_dm_on_monitor() ) THEN
DO i=10,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
lu_unit=i
GOTO 2011
ENDIF
ENDDO
lu_unit = -1
2011 CONTINUE
if(lu_unit<0) then
write(6,*) 'Can not assign unit to read CLM input data in clminit'
call endrun()
end if
open(lu_unit,file='CLM_ALB_ICE_DRC_DATA')
read(lu_unit,*) ((ss_alb_snw_drc(i,j),j=1,numrad_snw),i=1,idx_Mie_snw_mx)
close(lu_unit)
open(lu_unit,file='CLM_ASM_ICE_DRC_DATA')
read(lu_unit,*) ((asm_prm_snw_drc(i,j),j=1,numrad_snw),i=1,idx_Mie_snw_mx)
close(lu_unit)
open(lu_unit,file='CLM_EXT_ICE_DRC_DATA')
read(lu_unit,*) ((ext_cff_mss_snw_drc(i,j),j=1,numrad_snw),i=1,idx_Mie_snw_mx)
close(lu_unit)
open(lu_unit,file='CLM_ALB_ICE_DFS_DATA')
read(lu_unit,*) ((ss_alb_snw_dfs(i,j),j=1,numrad_snw),i=1,idx_Mie_snw_mx)
close(lu_unit)
open(lu_unit,file='CLM_ASM_ICE_DFS_DATA')
read(lu_unit,*) ((asm_prm_snw_dfs(i,j),j=1,numrad_snw),i=1,idx_Mie_snw_mx)
close(lu_unit)
open(lu_unit,file='CLM_EXT_ICE_DFS_DATA')
read(lu_unit,*) ((ext_cff_mss_snw_dfs(i,j),j=1,numrad_snw),i=1,idx_Mie_snw_mx)
close(lu_unit)
open(lu_unit,file='CLM_TAU_DATA')
read(lu_unit,*) &
(((snowage_tau(i,j,k),i=1,idx_T_max),j=1,idx_Tgrd_max),k=1,idx_rhos_max)
close(lu_unit)
open(lu_unit,file='CLM_KAPPA_DATA')
read(lu_unit,*) &
(((snowage_kappa(i,j,k),i=1,idx_T_max),j=1,idx_Tgrd_max),k=1,idx_rhos_max)
close(lu_unit)
open(lu_unit,file='CLM_DRDSDT0_DATA')
read(lu_unit,*)&
(((snowage_drdt0(i,j,k),i=1,idx_T_max),j=1,idx_Tgrd_max),k=1,idx_rhos_max)
close(lu_unit)
END IF
ix = 0
do i=1, idx_Mie_snw_mx
do j=1, numrad_snw
ix = ix + 1
xx_ss_alb_snw_drc(ix) = ss_alb_snw_drc(i,j)
xx_asm_prm_snw_drc(ix) = asm_prm_snw_drc(i,j)
xx_ext_cff_mss_snw_drc(ix) = ext_cff_mss_snw_drc(i,j)
xx_ss_alb_snw_dfs(ix) = ss_alb_snw_dfs(i,j)
xx_asm_prm_snw_dfs(ix) = asm_prm_snw_dfs(i,j)
xx_ext_cff_mss_snw_dfs(ix) = ext_cff_mss_snw_dfs(i,j)
end do
end do
ix = 0
do i=1,idx_T_max
do j=1,idx_Tgrd_max
do k=1,idx_rhos_max
ix = ix + 1
xx_snowage_tau(ix) = snowage_tau(i,j,k)
xx_snowage_kappa(ix) = snowage_kappa(i,j,k)
xx_snowage_drdt0(ix) = snowage_drdt0(i,j,k)
end do
end do
end do
CALL wrf_dm_bcast_real(xx_ss_alb_snw_drc, numrad_snw*idx_Mie_snw_mx )
CALL wrf_dm_bcast_real(xx_asm_prm_snw_drc, numrad_snw*idx_Mie_snw_mx )
CALL wrf_dm_bcast_real(xx_ext_cff_mss_snw_drc, numrad_snw*idx_Mie_snw_mx )
CALL wrf_dm_bcast_real(xx_ss_alb_snw_dfs, numrad_snw*idx_Mie_snw_mx )
CALL wrf_dm_bcast_real(xx_asm_prm_snw_dfs, numrad_snw*idx_Mie_snw_mx )
CALL wrf_dm_bcast_real(xx_ext_cff_mss_snw_dfs, numrad_snw*idx_Mie_snw_mx )
CALL wrf_dm_bcast_real(xx_snowage_tau, idx_T_max*idx_Tgrd_max*idx_rhos_max)
CALL wrf_dm_bcast_real(xx_snowage_kappa,idx_T_max*idx_Tgrd_max*idx_rhos_max)
CALL wrf_dm_bcast_real(xx_snowage_drdt0,idx_T_max*idx_Tgrd_max*idx_rhos_max)
IF(restart) return
itf=min0(ite,ide-1)
jtf=min0(jte,jde-1)
errflag = 0
DO j = jts,jtf
DO i = its,itf
IF ( ISLTYP( i,j ) .LT. 1 ) THEN
errflag = 1
WRITE(wrf_err_message,*)"CLM: clminit: out of range ISLTYP ",i,j,ISLTYP( i,j )
CALL wrf_message(wrf_err_message)
ENDIF
ENDDO
ENDDO
IF ( errflag .EQ. 1 ) THEN
CALL wrf_error_fatal( "CLM: clminit: out of range value "// &
"of ISLTYP. Is this field in the input?" )
ENDIF
!------------------------------------------------------------------------------
DO j = jts,jtf
DO i = its,itf
if((xland(i,j)-1.5).ge.0.)then
If(xice(i,j).eq.1)print*,' SEA-ICE AT WATER POINT, i=',i,'j=',j
smstav(i,j)=1.0
smstot(i,j)=1.0
smois(i,:,j)=1.0
tslb(i,:,j)=273.16
else if(xice(i,j).eq.1.)then
smstav(i,j)=1.0
smstot(i,j)=1.0
smois(i,:,j)=1.0
endif
snowh(i,j)=snow(i,j)*0.005 ! SNOW in kg/m^2 and SNOWH in m
snowdp(i,:,j) = snowh(i,j)
ENDDO
ENDDO
do i=its,itf
do j=jts,jtf
snl(i,:,j) = 0 !-999.0
h2osoi_liq_s5(i,:,j) = -999.0
h2osoi_liq_s4(i,:,j) = -999.0
h2osoi_liq_s3(i,:,j) = -999.0
h2osoi_liq_s2(i,:,j) = -999.0
h2osoi_liq_s1(i,:,j) = -999.0
h2osoi_liq1(i,:,j) = -999.0
h2osoi_liq2(i,:,j) = -999.0
h2osoi_liq3(i,:,j) = -999.0
h2osoi_liq4(i,:,j) = -999.0
h2osoi_liq5(i,:,j) = -999.0
h2osoi_liq6(i,:,j) = -999.0
h2osoi_liq7(i,:,j) = -999.0
h2osoi_liq8(i,:,j) = -999.0
h2osoi_liq9(i,:,j) = -999.0
h2osoi_liq10(i,:,j) = -999.0
h2osoi_ice_s5(i,:,j) = -999.0
h2osoi_ice_s4(i,:,j) = -999.0
h2osoi_ice_s3(i,:,j) = -999.0
h2osoi_ice_s2(i,:,j) = -999.0
h2osoi_ice_s1(i,:,j) = -999.0
h2osoi_ice1(i,:,j) = -999.0
h2osoi_ice2(i,:,j) = -999.0
h2osoi_ice3(i,:,j) = -999.0
h2osoi_ice4(i,:,j) = -999.0
h2osoi_ice5(i,:,j) = -999.0
h2osoi_ice6(i,:,j) = -999.0
h2osoi_ice7(i,:,j) = -999.0
h2osoi_ice8(i,:,j) = -999.0
h2osoi_ice9(i,:,j) = -999.0
h2osoi_ice10(i,:,j) = -999.0
! snowage(i,:,j)= 0.0
!Could this be the snow bug?
! if(ivgtyp(i,j).eq.24) then
! h2osno(i,:,j) = 1000.0 ! mm
! else
h2osno(i,:,j) = snow(i,j) ! mm
! end if
end do
end do
! write(6,*) '-------in clminit--------'
! write(6,*) 'snl=',snl
! call CLMDebug('clminit mark1')
!------------------------------------------------------------------------------
do i=its,itf
do j=jts,jtf
numc(i,j) = 0
nump(i,j) = 0
wtc(i,:,j) = 0.0
wtp(i,:,j) = 0.0
#ifdef CN
dyntlai(i,:,j) = 0.0
dyntsai(i,:,j) = 0.0
dyntop(i,:,j) = 0.0
dynbot(i,:,j) = 0.0
#endif
end do
end do
!------------------------------------------------------------------------------
do i=its,itf
do j=jts,jtf
! if(ivgtyp(i,j)==16.and.ht(i,j)>=1.e-5) then
!!!!!!Lakes Disabled. See comments above.
if(0 == 1) then
!!!!!!
lake(i,j) = .true.
else
lake(i,j) = .false.
end if
end do
end do
!------------------------------------------------------------------------------
! for snow
do m=1,maxpatch
do i=its,itf
do j=jts,jtf
dzsnow1(i,m,j) = 0.0
dzsnow2(i,m,j) = 0.0
dzsnow3(i,m,j) = 0.0
dzsnow4(i,m,j) = 0.0
dzsnow5(i,m,j) = 0.0
if(snowdp(i,m,j).lt.0.01) then
snl(i,m,j) = 0
dzsnow1(i,m,j) = 0.0
dzsnow2(i,m,j) = 0.0
dzsnow3(i,m,j) = 0.0
dzsnow4(i,m,j) = 0.0
dzsnow5(i,m,j) = 0.0
else
if(snowdp(i,m,j).ge.0.01.and.snowdp(i,m,j).le.0.03) then
snl(i,m,j) = -1
dzsnow1(i,m,j) = snowdp(i,m,j)
else if(snowdp(i,m,j).gt.0.03.and.snowdp(i,m,j).le.0.04) then
snl(i,m,j) = -2
dzsnow2(i,m,j) = snowdp(i,m,j)/2.
dzsnow1(i,m,j) = snowdp(i,m,j)/2.
else if(snowdp(i,m,j).gt.0.04.and.snowdp(i,m,j).le.0.07) then
snl(i,m,j) = -2
dzsnow2(i,m,j) = 0.02
dzsnow1(i,m,j) = snowdp(i,m,j)- dzsnow2(i,m,j)
else if(snowdp(i,m,j).gt.0.07.and.snowdp(i,m,j).le.0.12) then
snl(i,m,j) = -3
dzsnow3(i,m,j) = 0.02
dzsnow2(i,m,j) = (snowdp(i,m,j) - 0.02)/2.0
dzsnow1(i,m,j) = (snowdp(i,m,j) - 0.02)/2.0
else if(snowdp(i,m,j).gt.0.12.and.snowdp(i,m,j).le.0.18) then
snl(i,m,j) = -3
dzsnow3(i,m,j) = 0.02
dzsnow2(i,m,j) = 0.05
dzsnow1(i,m,j)= snowdp(i,m,j)-dzsnow3(i,m,j)-dzsnow2(i,m,j)
else if(snowdp(i,m,j).gt.0.18.and.snowdp(i,m,j).le.0.29) then
snl(i,m,j) = -4
dzsnow4(i,m,j) = 0.02
dzsnow3(i,m,j) = 0.05
dzsnow2(i,m,j) = (snowdp(i,m,j)-dzsnow4(i,m,j)-dzsnow3(i,m,j))/2.0
dzsnow1(i,m,j) = dzsnow2(i,m,j)
else if(snowdp(i,m,j).gt.0.29.and.snowdp(i,m,j).le.0.41) then
snl(i,m,j) = -4
dzsnow4(i,m,j) = 0.02
dzsnow3(i,m,j) = 0.05
dzsnow2(i,m,j) = 0.11
dzsnow1(i,m,j) = snowdp(i,m,j)-dzsnow4(i,m,j)-dzsnow3(i,m,j)-dzsnow2(i,m,j)
else if(snowdp(i,m,j).gt.0.41.and.snowdp(i,m,j).le.0.64) then
snl(i,m,j) = -5
dzsnow5(i,m,j) = 0.02
dzsnow4(i,m,j) = 0.05
dzsnow3(i,m,j) = 0.11
dzsnow2(i,m,j) = (snowdp(i,m,j)-dzsnow5(i,m,j)-dzsnow4(i,m,j)-dzsnow3(i,m,j))/2.0
dzsnow1(i,m,j) = (snowdp(i,m,j)-dzsnow5(i,m,j)-dzsnow4(i,m,j)-dzsnow3(i,m,j))/2.0
else if(snowdp(i,m,j).gt.0.64) then
snl(i,m,j) = -5
dzsnow5(i,m,j) = 0.02
dzsnow4(i,m,j)= 0.05
dzsnow3(i,m,j) = 0.11
dzsnow2(i,m,j) = 0.23
dzsnow1(i,m,j) = snowdp(i,m,j)-dzsnow5(i,m,j)-dzsnow4(i,m,j)-dzsnow3(i,m,j)-dzsnow2(i,m,j)
end if
end if ! start from snowdp(i,m,j).lt.0.01
end do
end do
end do
!write(6,*) 'after assign snl=',snl
!------------------------------------------------------------------------------
!snow radius
do m=1,maxpatch
do i=its,itf
do j=jts,jtf
if(snl(i,m,j) == -5) then
snowrds1(i,m,j) = 54.526 !snw_rds_min = 54.526
snowrds2(i,m,j) = 54.526
snowrds3(i,m,j) = 54.526
snowrds4(i,m,j) = 54.526
snowrds5(i,m,j) = 54.526
else if(snl(i,m,j) == -4) then
snowrds1(i,m,j) = 54.526
snowrds2(i,m,j) = 54.526
snowrds3(i,m,j) = 54.526
snowrds4(i,m,j) = 54.526
snowrds5(i,m,j) = 0.0
else if(snl(i,m,j) == -3) then
snowrds1(i,m,j) = 54.526
snowrds2(i,m,j) = 54.526
snowrds3(i,m,j) = 54.526
snowrds4(i,m,j) = 0.0
snowrds5(i,m,j) = 0.0
else if(snl(i,m,j) == -2) then
snowrds1(i,m,j) = 54.526
snowrds2(i,m,j) = 54.526
snowrds3(i,m,j) = 0.0
snowrds4(i,m,j) = 0.0
snowrds5(i,m,j) = 0.0
else if(snl(i,m,j) == -1) then
snowrds1(i,m,j) = 54.526
snowrds2(i,m,j) = 0.0
snowrds3(i,m,j) = 0.0
snowrds4(i,m,j) = 0.0
snowrds5(i,m,j) = 0.0
else if(snl(i,m,j) == 0) then
snowrds1(i,m,j) = 0.0
snowrds2(i,m,j) = 0.0
snowrds3(i,m,j) = 0.0
snowrds4(i,m,j) = 0.0
snowrds5(i,m,j) = 0.0
end if
end do
end do
end do
!------------------------------------------------------------------------------
do i=its,itf
do j=jts,jtf
h2ocan(i,:,j) = 0.0
h2ocan_col(i,:,j) = 0.0
sfcrunoff(i,j) = 0.0
udrunoff(i,j) = 0.0
end do
end do
!------------------------------------------------------------------------------
! initialize temperature and moisture
do i=its,itf
do j=jts,jtf
t_soisno_s5(i,:,j) = -999.0
t_soisno_s4(i,:,j) = -999.0
t_soisno_s3(i,:,j) = -999.0
t_soisno_s2(i,:,j) = -999.0
t_soisno_s1(i,:,j) = -999.0
t_soisno1(i,:,j) = -999.0
t_soisno2(i,:,j) = -999.0
t_soisno3(i,:,j) = -999.0
t_soisno4(i,:,j) = -999.0
t_soisno5(i,:,j) = -999.0
t_soisno6(i,:,j) = -999.0
t_soisno7(i,:,j) = -999.0
t_soisno8(i,:,j) = -999.0
t_soisno9(i,:,j) = -999.0
t_soisno10(i,:,j) = -999.0
t_lake1(i,:,j) = -999.0
t_lake2(i,:,j) = -999.0
t_lake3(i,:,j) = -999.0
t_lake4(i,:,j) = -999.0
t_lake5(i,:,j) = -999.0
t_lake6(i,:,j) = -999.0
t_lake7(i,:,j) = -999.0
t_lake8(i,:,j) = -999.0
t_lake9(i,:,j) = -999.0
t_lake10(i,:,j) = -999.0
end do
end do
do i=its,itf
do j=jts,jtf
do k=1,num_soil_layers
if(ivgtyp(i,j).eq.24.and.tslb(i,k,j) .gt.tfrz) tslb(i,k,j)=tfrz
end do
t_soisno_s5(i,:,j) = tslb(i,1,j)
t_soisno_s4(i,:,j) = tslb(i,1,j)
t_soisno_s3(i,:,j) = tslb(i,1,j)
t_soisno_s2(i,:,j) = tslb(i,1,j)
t_soisno_s1(i,:,j) = tslb(i,1,j)
t_soisno1(i,:,j) = tslb(i,1,j)
t_soisno2(i,:,j) = tslb(i,2,j)
t_soisno3(i,:,j) = tslb(i,3,j)
t_soisno4(i,:,j) = tslb(i,4,j)
t_soisno5(i,:,j) = tslb(i,5,j)
t_soisno6(i,:,j) = tslb(i,6,j)
t_soisno7(i,:,j) = tslb(i,7,j)
t_soisno8(i,:,j) = tslb(i,8,j)
t_soisno9(i,:,j) = tslb(i,9,j)
t_soisno10(i,:,j)= tslb(i,10,j)
t_grnd(i,:,j) = tslb(i,1,j)
t_veg(i,:,j) = tslb(i,1,j)
end do
end do
do i=its,itf
do j=jts,jtf
if(lake(i,j)) then
t_lake1(i,:,j) = 277.0
t_lake2(i,:,j) = 277.0
t_lake3(i,:,j) = 277.0
t_lake4(i,:,j) = 277.0
t_lake5(i,:,j) = 277.0
t_lake6(i,:,j) = 277.0
t_lake7(i,:,j) = 277.0
t_lake8(i,:,j) = 277.0
t_lake9(i,:,j) = 277.0
t_lake10(i,:,j) = 277.0
t_grnd(i,:,j) = 277.0
end if
end do
end do
call CLMDebug('clminit mark2')
! for moisture
do i=its,itf
do j=jts,jtf
h2osoi_vol1(i,:,j) = smois(i,1,j)
h2osoi_vol2(i,:,j) = smois(i,2,j)
h2osoi_vol3(i,:,j) = smois(i,3,j)
h2osoi_vol4(i,:,j) = smois(i,4,j)
h2osoi_vol5(i,:,j) = smois(i,5,j)
h2osoi_vol6(i,:,j) = smois(i,6,j)
h2osoi_vol7(i,:,j) = smois(i,7,j)
h2osoi_vol8(i,:,j) = smois(i,8,j)
h2osoi_vol9(i,:,j) = smois(i,9,j)
h2osoi_vol10(i,:,j) = smois(i,10,j)
h2osoi_liq_s5(i,:,j) = 0.0
h2osoi_liq_s4(i,:,j) = 0.0
h2osoi_liq_s3(i,:,j) = 0.0
h2osoi_liq_s2(i,:,j) = 0.0
h2osoi_liq_s1(i,:,j) = 0.0
h2osoi_ice_s5(i,:,j) = 1.0
h2osoi_ice_s4(i,:,j) = 1.0
h2osoi_ice_s3(i,:,j) = 1.0
h2osoi_ice_s2(i,:,j) = 1.0
h2osoi_ice_s1(i,:,j) = 1.0
do m = 1, maxpatch
if(t_soisno1(i,m,j) <tfrz.and.t_soisno1(i,m,j)/=-999.0) then
h2osoi_ice1(i,m,j) = dzs(1)*0.917e3*h2osoi_vol1(i,m,j)
h2osoi_liq1(i,m,j) = 0.0
else if (t_soisno1(i,m,j) >= tfrz) then
h2osoi_ice1(i,m,j) = 0.0
h2osoi_liq1(i,m,j) = dzs(1)*1000.0*h2osoi_vol1(i,m,j)
end if
if(t_soisno2(i,m,j) <tfrz.and.t_soisno2(i,m,j)/=-999.0) then
h2osoi_ice2(i,m,j) = dzs(2)*0.917e3*h2osoi_vol2(i,m,j)
h2osoi_liq2(i,m,j) = 0.0
else if (t_soisno2(i,m,j) >= tfrz) then
h2osoi_ice2(i,m,j) = 0.0
h2osoi_liq2(i,m,j) = dzs(2)*1000.0*h2osoi_vol2(i,m,j)
end if
if(t_soisno3(i,m,j) <tfrz.and.t_soisno3(i,m,j)/=-999.0) then
h2osoi_ice3(i,m,j) = dzs(3)*0.917e3*h2osoi_vol3(i,m,j)
h2osoi_liq3(i,m,j) = 0.0
else if (t_soisno3(i,m,j) >= tfrz) then
h2osoi_ice3(i,m,j) = 0.0
h2osoi_liq3(i,m,j) = dzs(3)*1000.0*h2osoi_vol3(i,m,j)
end if
if(t_soisno4(i,m,j) <tfrz.and.t_soisno4(i,m,j)/=-999.0) then
h2osoi_ice4(i,m,j) = dzs(4)*0.917e4*h2osoi_vol4(i,m,j)
h2osoi_liq4(i,m,j) = 0.0
else if (t_soisno4(i,m,j) >= tfrz) then
h2osoi_ice4(i,m,j) = 0.0
h2osoi_liq4(i,m,j) = dzs(4)*1000.0*h2osoi_vol4(i,m,j)
end if
if(t_soisno5(i,m,j) <tfrz.and.t_soisno5(i,m,j)/=-999.0) then
h2osoi_ice5(i,m,j) = dzs(5)*0.917e4*h2osoi_vol5(i,m,j)
h2osoi_liq5(i,m,j) = 0.0
else if (t_soisno5(i,m,j) >= tfrz) then
h2osoi_ice5(i,m,j) = 0.0
h2osoi_liq5(i,m,j) = dzs(5)*1000.0*h2osoi_vol5(i,m,j)
end if
if(t_soisno6(i,m,j) <tfrz.and.t_soisno6(i,m,j)/=-999.0) then
h2osoi_ice6(i,m,j) = dzs(6)*0.917e4*h2osoi_vol6(i,m,j)
h2osoi_liq6(i,m,j) = 0.0
else if (t_soisno6(i,m,j) >= tfrz) then
h2osoi_ice6(i,m,j) = 0.0
h2osoi_liq6(i,m,j) = dzs(6)*1000.0*h2osoi_vol6(i,m,j)
end if
if(t_soisno7(i,m,j) <tfrz.and.t_soisno7(i,m,j)/=-999.0) then
h2osoi_ice7(i,m,j) = dzs(7)*0.917e4*h2osoi_vol7(i,m,j)
h2osoi_liq7(i,m,j) = 0.0
else if (t_soisno7(i,m,j) >= tfrz) then
h2osoi_ice7(i,m,j) = 0.0
h2osoi_liq7(i,m,j) = dzs(7)*1000.0*h2osoi_vol7(i,m,j)
end if
if(t_soisno8(i,m,j) <tfrz.and.t_soisno8(i,m,j)/=-999.0) then
h2osoi_ice8(i,m,j) = dzs(8)*0.917e4*h2osoi_vol8(i,m,j)
h2osoi_liq8(i,m,j) = 0.0
else if (t_soisno8(i,m,j) >= tfrz) then
h2osoi_ice8(i,m,j) = 0.0
h2osoi_liq8(i,m,j) = dzs(8)*1000.0*h2osoi_vol8(i,m,j)
end if
if(t_soisno9(i,m,j) <tfrz.and.t_soisno9(i,m,j)/=-999.0) then
h2osoi_ice9(i,m,j) = dzs(9)*0.917e4*h2osoi_vol9(i,m,j)
h2osoi_liq9(i,m,j) = 0.0
else if (t_soisno9(i,m,j) >= tfrz) then
h2osoi_ice9(i,m,j) = 0.0
h2osoi_liq9(i,m,j) = dzs(9)*1000.0*h2osoi_vol9(i,m,j)
end if
if(t_soisno10(i,m,j) <tfrz.and.t_soisno10(i,m,j)/=-999.0) then
h2osoi_ice10(i,m,j) = dzs(10)*0.917e4*h2osoi_vol10(i,m,j)
h2osoi_liq10(i,m,j) = 0.0
else if (t_soisno10(i,m,j) >= tfrz) then
h2osoi_ice10(i,m,j) = 0.0
h2osoi_liq10(i,m,j) = dzs(10)*1000.0*h2osoi_vol10(i,m,j)
end if
end do
end do
end do
!------------------------------------------------------------------------------
call CLMDebug('clminit mark 4')
do i=its,itf
do j=jts,jtf
t2m_max(i,j) = tslb(i,1,j)
t2m_min(i,j) = tslb(i,1,j)
t_ref2m(i,:,j) = tslb(i,1,j)
albedosubgrid(i,:,j) = 0.0
lhsubgrid(i,:,j) = 0.0
hfxsubgrid(i,:,j) = 0.0
lwupsubgrid(i,:,j) = 0.0
q2subgrid(i,:,j) = 0.0
sabvsubgrid(i,:,j) = 0.0
sabgsubgrid(i,:,j) = 0.0
nrasubgrid(i,:,j) = 0.0
swupsubgrid(i,:,j) = 0.0
!!
lhsoi(i,:,j) = 0.0
lhveg(i,:,j) = 0.0
lhtran(i,:,j) = 0.0
end do
end do
do i=its,itf
do j=jts,jtf
do k=1, num_soil_layers
if(tslb(i,k,j) >= tfrz ) then
sh2o(i,k,j) = smois(i,k,j)
else
sh2o(i,k,j) = 0.0
end if
end do
end do
end do
call CLMDebug('clminit done')
!------------------------------------------------------------------------------
END SUBROUTINE clminit
!------------------------------------------------------------------------------
END MODULE module_sf_clm
module decompMod 26,3
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: decompMod
!
! !USES:
use shr_kind_mod, only : r8 => shr_kind_r8
use clm_varpar , only : lsmlon, lsmlat, maxpatch, maxpatch_pft, &
npatch_crop, npatch_urban, npatch_glacier
use clm_varsur , only : numlon
implicit none
integer, public :: ncells
integer, public :: nlunits
integer, public :: ncols
integer, public :: npfts
public initDecomp ! initializes land surface decomposition
! into clumps and processors
public get_gcell_info ! updates gridcell, landunits, columns and
! pfts counters
public get_gcell_xyind ! returns ixy and jxy for each grid cell
public get_proc_bounds ! beg and end gridcell, landunit, column,
! pft indices for this processor
save
private
type gcell_decomp
integer :: gsn ! corresponding cell index in south->north gridcell array
integer :: li ! beginning landunit index
integer :: lf ! ending landunit index
integer :: ci ! beginning column index
integer :: cf ! ending column index
integer :: pi ! beginning pft index
integer :: pf ! ending pft index
end type gcell_decomp
type(gcell_decomp), allocatable :: gcelldc(:)
contains
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: initDecomp
!
! !INTERFACE:
subroutine initDecomp 1,3
!
! !DESCRIPTION:
! This subroutine initializes the land surface decomposition into a clump
! data structure.
!
! !USES:
use clmtype
!
! !ARGUMENTS:
implicit none
! weights
!
! !LOCAL VARIABLES:
integer :: ppc ! min number of pfts per clump
integer :: lpc ! min number of landunits per clump
integer :: ppclump ! min pfts per clump
integer :: i,j,cid,pid ! indices
integer :: gi,li,ci,pi ! indices
integer :: gf,lf,cf,pf ! indices
integer :: g,l,c,p,n,m ! indices
integer :: gdc,gsn ! indices
integer :: nzero ! first clump with zero gridcells
! integer :: ncells ! total gridcells
! integer :: nlunits ! total landunits
! integer :: ncols ! total columns
! integer :: npfts ! total pfts
integer :: nveg ! number of pfts in vegetated landunit
integer :: numg ! total number of gridcells across all
! processors
integer :: numl ! total number of landunits across all
! processors
integer :: numc ! total number of columns across all
! processors
integer :: nump ! total number of pfts across all
! processors
logical :: error = .false. ! temporary for finding full clump
integer :: ilunits, icols, ipfts ! temporaries
integer :: ng ! temporaries
integer :: nl ! temporaries
integer :: nc ! temporaries
integer :: np ! temporaries
integer :: ier ! error code
character*256 :: msg
integer :: begg,endg
begg=1
endg=1
!
! !CALLED FROM:
! subroutine initialize
!
! !REVISION HISTORY:
! 2002.09.11 Forrest Hoffman Creation.
!
!EOP
!------------------------------------------------------------------------------
! Find total global number of grid cells, landunits, columns and pfts
ncells = 0
nlunits = 0
ncols = 0
npfts = 0
msg= ''
write(msg,*) 'lsmlat=',lsmlat,'numlon=',numlon
call CLMDebug(msg)
do g = begg,endg
call get_gcell_info (g, nlunits=ilunits, ncols=icols, npfts=ipfts)
ncells = ncells + 1
nlunits = nlunits + ilunits
ncols = ncols + icols
npfts = npfts + ipfts
end do
end subroutine initDecomp
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: get_gcell_info
!
! !INTERFACE:
subroutine get_gcell_info (g, nlunits, ncols, npfts, & 3,1
nveg, wtveg, ncrop, wtcrop)
!
use clm_varsur , only: wtxy
! !DESCRIPTION:
! Obtain gridcell properties.
!
! !ARGUMENTS:
implicit none
integer ,intent(in) :: g ! weights
integer , optional, intent(out) :: nlunits ! number of landunits
integer , optional, intent(out) :: ncols ! number of columns
integer , optional, intent(out) :: npfts ! number of pfts
integer , optional, intent(out) :: nveg ! number of vegetated pfts
! in naturally vegetated
! landunit
real(r8), optional, intent(out) :: wtveg ! weight (relative to
! gridcell) of naturally
! vegetated landunit
integer , optional, intent(out) :: ncrop ! number of crop pfts in
! crop landunit
real(r8), optional, intent(out) :: wtcrop ! weight (relative to
! gridcell) of crop landunit
!
! !CALLED FROM:
! subroutines initDecomp
!
! !REVISION HISTORY:
! 2002.09.11 Mariana Vertenstein Creation.
!
!EOP
!
! !LOCAL VARIABLES:
integer :: m ! loop index
integer :: nvegl ! number of vegetated pfts in naturally vegetated landunit
real(r8) :: wtvegl ! weight (relative to gridcell) of vegetated landunit
integer :: nvegc ! number of crop pfts in crop landunit
real(r8) :: wtvegc ! weight (relative to gridcell) of crop landunit
integer :: ilunits ! number of landunits in gridcell
integer :: icols ! number of columns in gridcell
integer :: ipfts ! number of pfts in gridcell
!------------------------------------------------------------------------------
! Initialize pfts, columns and landunits counters for gridcell
ipfts = 0
icols = 0
ilunits = 0
! Set total number of pfts in gridcell
do m = 1,maxpatch
if (wtxy(g,m) > 0.0) ipfts = ipfts + 1
end do
! Set naturally vegetated landunit
nvegl = 0
wtvegl = 0.0
do m = 1, maxpatch_pft
if (wtxy(g,m) > 0.0) then
nvegl = nvegl + 1
wtvegl = wtvegl + wtxy(g,m)
end if
end do
if (nvegl > 0) ilunits = ilunits + 1
#if (defined NOCOMPETE)
if (nvegl > 0) icols = icols + nvegl ! each pft on vegetated landunit has its own column
#else
if (nvegl > 0) icols = icols + 1 ! the vegetated landunit has one column
#endif
! Set special landunits
do m = npatch_urban, npatch_glacier
if (wtxy(g,m) > 0.0) ilunits = ilunits + 1
if (wtxy(g,m) > 0.0) icols = icols + 1
end do
! Set crop landunit if appropriate
nvegc = 0
wtvegc = 0.0
do m = npatch_glacier+1, npatch_crop
if (wtxy(g,m) > 0.0) then
nvegc = nvegc + 1
wtvegc = wtvegc + wtxy(g,m)
end if
end do
if (nvegc > 0) ilunits = ilunits + 1
if (nvegc > 0) icols = icols + nvegc
if (present(nlunits)) nlunits = ilunits
if (present(ncols)) ncols = icols
if (present(npfts)) npfts = ipfts
if (present(nveg)) nveg = nvegl
if (present(wtveg)) wtveg = wtvegl
if (present(ncrop)) ncrop = nvegc
if (present(wtcrop)) wtcrop = wtvegc
end subroutine get_gcell_info
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: get_proc_bounds
!
! !INTERFACE:
subroutine get_proc_bounds (begg, endg, begl, endl, begc, endc, & 26
begp, endp)
!
! !ARGUMENTS:
implicit none
integer,optional, intent(out) :: begp, endp ! proc beginning and ending
! pft indices
integer,optional, intent(out) :: begc, endc ! proc beginning and ending
! column indices
integer,optional, intent(out) :: begl, endl ! proc beginning and ending
! landunit indices
integer,optional, intent(out) :: begg, endg ! proc beginning and ending
! gridcell indices
! !DESCRIPTION:
! Retrieve gridcell, landunit, column, and pft bounds for process.
!
! !REVISION HISTORY:
! 2003.09.12 Mariana Vertenstein Creation.
!
!EOP
!------------------------------------------------------------------------------
if(present(begp)) begp = 1
if(present(endp)) endp = npfts
if(present(begc)) begc = 1
if(present(endc)) endc = ncols
if(present(begl)) begl = 1
if(present(endl)) endl = nlunits
if(present(begg)) begg = 1
if(present(endg)) endg = 1
end subroutine get_proc_bounds
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: get_gcell_xyind
!
! !INTERFACE:
subroutine get_gcell_xyind(lbg, ubg) 1
!
! !DESCRIPTION:
! Retrieve x,y indices of a gridcell.
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbg
integer, intent(in) :: ubg
!
! !REVISION HISTORY:
! 2003.09.12 Mariana Vertenstein Creation.
!
!EOP
!
! !LOCAL VARIABLES:
integer :: g ! indices
integer :: i, j
integer :: ier ! error code
!------------------------------------------------------------------------------
!dir$ concurrent
!cdir nodep
allocate(gcelldc(ncells), stat=ier)
g = 0
do j=1,lsmlat
numlon(j) = lsmlon
end do
do j = 1, lsmlat
do i = 1, numlon(j)
g = g + 1
end do
end do
do g = lbg,ubg
end do
deallocate(gcelldc)
end subroutine get_gcell_xyind
end module decompMod
!==============================================================================
subroutine CLMDebug( str ) 173
IMPLICIT NONE
CHARACTER*(*), str
#if (defined DEBUGCLM)
print*, TRIM(str)
call flush(6)
#endif
end subroutine CLMDebug
module clmtypeInitMod 2,4
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: clmtypeInitMod
!
! !DESCRIPTION:
! Allocate clmtype components and initialize them to signaling NaN.
!
! !USES:
use shr_kind_mod, only : r8 => shr_kind_r8
use nanMod , only : nan, bigint
use clmtype
use clm_varpar , only : maxpatch_pft, nlevsno, nlevgrnd, numrad, nlevlak, &
numpft, ndst, nvoc, nlevurb, nlevsoi
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: initClmtype
!
! !REVISION HISTORY:
! Created by Peter Thornton and Mariana Vertenstein
! Modified by Colette L. Heald (05/06) for VOC emission factors
! 3/17/08 David Lawrence, changed nlevsoi to nlevgrnd where appropriate
!
! !PRIVATE MEMBER FUNCTIONS:
private :: init_pft_type
private :: init_column_type
private :: init_landunit_type
private :: init_gridcell_type
private :: init_energy_balance_type
private :: init_water_balance_type
private :: init_pft_ecophys_constants
#if (defined CNDV) || (defined CROP)
private :: init_pft_DGVMecophys_constants
#endif
private :: init_pft_pstate_type
private :: init_pft_epv_type
#if (defined CNDV) || (defined CROP)
private :: init_pft_pdgvstate_type
#endif
private :: init_pft_vstate_type
private :: init_pft_estate_type
private :: init_pft_wstate_type
private :: init_pft_cstate_type
private :: init_pft_nstate_type
private :: init_pft_eflux_type
private :: init_pft_mflux_type
private :: init_pft_wflux_type
private :: init_pft_cflux_type
private :: init_pft_nflux_type
private :: init_pft_vflux_type
private :: init_pft_dflux_type
private :: init_pft_depvd_type
private :: init_column_pstate_type
private :: init_column_estate_type
private :: init_column_wstate_type
private :: init_column_cstate_type
private :: init_column_nstate_type
private :: init_column_eflux_type
private :: init_column_wflux_type
private :: init_column_cflux_type
private :: init_column_nflux_type
private :: init_landunit_pstate_type
private :: init_landunit_eflux_type
private :: init_gridcell_pstate_type
private :: init_gridcell_efstate_type
private :: init_gridcell_wflux_type
!ylu add these two subroutine was called but not declared in clm4
private :: init_gridcell_wstate_type
private :: init_gridcell_estate_type
private :: init_atm2lnd_type
!have to deallocate all the allocated vars at every time step
private :: dealloc_pft_type
private :: dealloc_column_type
private :: dealloc_landunit_type
private :: dealloc_gridcell_type
private :: dealloc_energy_balance_type
private :: dealloc_water_balance_type
private :: dealloc_pft_ecophys_constants
#if (defined CNDV) || (defined CROP)
private :: dealloc_pft_DGVMecophys_constants
#endif
private :: dealloc_pft_pstate_type
private :: dealloc_pft_epv_type
#if (defined CNDV) || (defined CROP)
private :: dealloc_pft_pdgvstate_type
#endif
private :: dealloc_pft_vstate_type
private :: dealloc_pft_estate_type
private :: dealloc_pft_wstate_type
private :: dealloc_pft_cstate_type
private :: dealloc_pft_nstate_type
private :: dealloc_pft_eflux_type
private :: dealloc_pft_mflux_type
private :: dealloc_pft_wflux_type
private :: dealloc_pft_cflux_type
private :: dealloc_pft_nflux_type
private :: dealloc_pft_vflux_type
private :: dealloc_pft_dflux_type
private :: dealloc_pft_depvd_type
private :: dealloc_column_pstate_type
private :: dealloc_column_estate_type
private :: dealloc_column_wstate_type
private :: dealloc_column_cstate_type
private :: dealloc_column_nstate_type
private :: dealloc_column_eflux_type
private :: dealloc_column_wflux_type
private :: dealloc_column_cflux_type
private :: dealloc_column_nflux_type
private :: dealloc_landunit_pstate_type
private :: dealloc_landunit_eflux_type
private :: dealloc_gridcell_pstate_type
private :: dealloc_gridcell_efstate_type
private :: dealloc_gridcell_wflux_type
!ylu add these two subroutine was called but not declared in clm4
private :: dealloc_gridcell_wstate_type
private :: dealloc_gridcell_estate_type
private :: dealloc_atm2lnd_type
!EOP
!----------------------------------------------------
contains
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: initClmtype
!
! !INTERFACE:
subroutine initClmtype() 1,97
!
! !DESCRIPTION:
! Initialize clmtype components to signaling nan
! The following clmtype components should NOT be initialized here
! since they are set in routine clm_map which is called before this
! routine is invoked
! *%area, *%wt, *%wtlnd, *%wtxy, *%ixy, *%jxy, *%mxy, %snindex
! *%ifspecial, *%ityplun, *%itype
! *%pfti, *%pftf, *%pftn
! *%coli, *%colf, *%coln
! *%luni, *%lunf, *%lunn
!
! !USES:
use decompMod , only : get_proc_bounds
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!
! LOCAL VARAIBLES:
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
!------------------------------------------------------------------------
! Determine necessary indices
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
call init_pft_type (begp, endp, clm3%g%l%c%p)
call init_column_type (begc, endc, clm3%g%l%c)
call init_landunit_type(begl, endl, clm3%g%l)
call init_gridcell_type(begg, endg, clm3%g)
! pft ecophysiological constants
call init_pft_ecophys_constants()
#if (defined CNDV)
! pft DGVM-specific ecophysiological constants
call init_pft_DGVMecophys_constants()
#endif
! energy balance structures (all levels)
call init_energy_balance_type(begp, endp, clm3%g%l%c%p%pebal)
call init_energy_balance_type(begc, endc, clm3%g%l%c%cebal)
call init_energy_balance_type(begl, endl, clm3%g%l%lebal)
call init_energy_balance_type(begg, endg, clm3%g%gebal)
call init_energy_balance_type(1, 1, clm3%mebal)
! water balance structures (all levels)
call init_water_balance_type(begp, endp, clm3%g%l%c%p%pwbal)
call init_water_balance_type(begc, endc, clm3%g%l%c%cwbal)
call init_water_balance_type(begl, endl, clm3%g%l%lwbal)
call init_water_balance_type(begg, endg, clm3%g%gwbal)
call init_water_balance_type(1, 1, clm3%mwbal)
! carbon balance structures (pft and column levels)
call init_carbon_balance_type(begp, endp, clm3%g%l%c%p%pcbal)
call init_carbon_balance_type(begc, endc, clm3%g%l%c%ccbal)
! nitrogen balance structures (pft and column levels)
call init_nitrogen_balance_type(begp, endp, clm3%g%l%c%p%pnbal)
call init_nitrogen_balance_type(begc, endc, clm3%g%l%c%cnbal)
! pft physical state variables at pft level and averaged to the column
call init_pft_pstate_type(begp, endp, clm3%g%l%c%p%pps)
call init_pft_pstate_type(begc, endc, clm3%g%l%c%cps%pps_a)
! pft ecophysiological variables (only at the pft level for now)
call init_pft_epv_type(begp, endp, clm3%g%l%c%p%pepv)
#if (defined CNDV) || (defined CROP)
! pft DGVM state variables at pft level and averaged to column
call init_pft_pdgvstate_type(begp, endp, clm3%g%l%c%p%pdgvs)
#endif
#if (defined CNDV)
call init_pft_pdgvstate_type(begc, endc, clm3%g%l%c%cdgvs%pdgvs_a)
#endif
call init_pft_vstate_type(begp, endp, clm3%g%l%c%p%pvs)
! pft energy state variables at the pft level and averaged to the column
call init_pft_estate_type(begp, endp, clm3%g%l%c%p%pes)
call init_pft_estate_type(begc, endc, clm3%g%l%c%ces%pes_a)
! pft water state variables at the pft level and averaged to the column
call init_pft_wstate_type(begp, endp, clm3%g%l%c%p%pws)
call init_pft_wstate_type(begc, endc, clm3%g%l%c%cws%pws_a)
! pft carbon state variables at the pft level and averaged to the column
call init_pft_cstate_type(begp, endp, clm3%g%l%c%p%pcs)
call init_pft_cstate_type(begc, endc, clm3%g%l%c%ccs%pcs_a)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
call init_pft_cstate_type(begp, endp, clm3%g%l%c%p%pc13s)
call init_pft_cstate_type(begc, endc, clm3%g%l%c%cc13s%pcs_a)
#endif
! pft nitrogen state variables at the pft level and averaged to the column
call init_pft_nstate_type(begp, endp, clm3%g%l%c%p%pns)
call init_pft_nstate_type(begc, endc, clm3%g%l%c%cns%pns_a)
! pft energy flux variables at pft level and averaged to column
call init_pft_eflux_type(begp, endp, clm3%g%l%c%p%pef)
call init_pft_eflux_type(begc, endc, clm3%g%l%c%cef%pef_a)
! pft momentum flux variables at pft level and averaged to the column
call init_pft_mflux_type(begp, endp, clm3%g%l%c%p%pmf)
call init_pft_mflux_type(begc, endc, clm3%g%l%c%cmf%pmf_a)
! pft water flux variables
call init_pft_wflux_type(begp, endp, clm3%g%l%c%p%pwf)
call init_pft_wflux_type(begc, endc, clm3%g%l%c%cwf%pwf_a)
! pft carbon flux variables at pft level and averaged to column
call init_pft_cflux_type(begp, endp, clm3%g%l%c%p%pcf)
call init_pft_cflux_type(begc, endc, clm3%g%l%c%ccf%pcf_a)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
call init_pft_cflux_type(begp, endp, clm3%g%l%c%p%pc13f)
call init_pft_cflux_type(begc, endc, clm3%g%l%c%cc13f%pcf_a)
#endif
! pft nitrogen flux variables at pft level and averaged to column
call init_pft_nflux_type(begp, endp, clm3%g%l%c%p%pnf)
call init_pft_nflux_type(begc, endc, clm3%g%l%c%cnf%pnf_a)
! pft VOC flux variables at pft level and averaged to column
call init_pft_vflux_type(begp, endp, clm3%g%l%c%p%pvf)
call init_pft_vflux_type(begc, endc, clm3%g%l%c%cvf%pvf_a)
! gridcell VOC emission factors (heald, 05/06)
call init_gridcell_efstate_type(begg, endg, clm3%g%gve)
! pft dust flux variables at pft level and averaged to column
call init_pft_dflux_type(begp, endp, clm3%g%l%c%p%pdf)
call init_pft_dflux_type(begc, endc, clm3%g%l%c%cdf%pdf_a)
! pft dry dep velocity variables at pft level and averaged to column
call init_pft_depvd_type(begp, endp, clm3%g%l%c%p%pdd)
! column physical state variables at column level and averaged to
! the landunit and gridcell and model
call init_column_pstate_type(begc, endc, clm3%g%l%c%cps)
call init_column_pstate_type(begl, endl, clm3%g%l%lps%cps_a)
call init_column_pstate_type(begg, endg, clm3%g%gps%cps_a)
call init_column_pstate_type(1, 1, clm3%mps%cps_a)
! column energy state variables at column level and averaged to
! the landunit and gridcell and model
call init_column_estate_type(begc, endc, clm3%g%l%c%ces)
call init_column_estate_type(begl, endl, clm3%g%l%les%ces_a)
call init_column_estate_type(begg, endg, clm3%g%ges%ces_a)
call init_column_estate_type(1, 1, clm3%mes%ces_a)
! column water state variables at column level and averaged to
! the landunit and gridcell and model
call init_column_wstate_type(begc, endc, clm3%g%l%c%cws)
call init_column_wstate_type(begl, endl, clm3%g%l%lws%cws_a)
call init_column_wstate_type(begg, endg, clm3%g%gws%cws_a)
call init_column_wstate_type(1, 1, clm3%mws%cws_a)
! column carbon state variables at column level and averaged to
! the landunit and gridcell and model
call init_column_cstate_type(begc, endc, clm3%g%l%c%ccs)
call init_column_cstate_type(begl, endl, clm3%g%l%lcs%ccs_a)
call init_column_cstate_type(begg, endg, clm3%g%gcs%ccs_a)
call init_column_cstate_type(1, 1, clm3%mcs%ccs_a)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
call init_column_cstate_type(begc, endc, clm3%g%l%c%cc13s)
#endif
! column nitrogen state variables at column level and averaged to
! the landunit and gridcell and model
call init_column_nstate_type(begc, endc, clm3%g%l%c%cns)
call init_column_nstate_type(begl, endl, clm3%g%l%lns%cns_a)
call init_column_nstate_type(begg, endg, clm3%g%gns%cns_a)
call init_column_nstate_type(1, 1, clm3%mns%cns_a)
! column energy flux variables at column level and averaged to
! the landunit and gridcell and model
call init_column_eflux_type(begc, endc, clm3%g%l%c%cef)
call init_column_eflux_type(begl, endl, clm3%g%l%lef%cef_a)
call init_column_eflux_type(begg, endg, clm3%g%gef%cef_a)
call init_column_eflux_type(1, 1, clm3%mef%cef_a)
! column water flux variables at column level and averaged to
! landunit, gridcell and model level
call init_column_wflux_type(begc, endc, clm3%g%l%c%cwf)
call init_column_wflux_type(begl, endl, clm3%g%l%lwf%cwf_a)
call init_column_wflux_type(begg, endg, clm3%g%gwf%cwf_a)
call init_column_wflux_type(1, 1, clm3%mwf%cwf_a)
! column carbon flux variables at column level
call init_column_cflux_type(begc, endc, clm3%g%l%c%ccf)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
call init_column_cflux_type(begc, endc, clm3%g%l%c%cc13f)
#endif
! column nitrogen flux variables at column level
call init_column_nflux_type(begc, endc, clm3%g%l%c%cnf)
! land unit physical state variables
call init_landunit_pstate_type(begl, endl, clm3%g%l%lps)
! land unit energy flux variables
call init_landunit_eflux_type(begl, endl, clm3%g%l%lef)
#if (defined CNDV)
! gridcell DGVM variables
call init_gridcell_dgvstate_type(begg, endg, clm3%g%gdgvs)
#endif
! gridcell physical state variables
call init_gridcell_pstate_type(begg, endg, clm3%g%gps)
! gridcell: water flux variables
call init_gridcell_wflux_type(begg, endg, clm3%g%gwf)
! gridcell: energy flux variables
call init_gridcell_eflux_type(begg, endg, clm3%g%gef)
! gridcell: water state variables
call init_gridcell_wstate_type(begg, endg, clm3%g%gws)
! gridcell: energy state variables
call init_gridcell_estate_type(begg, endg, clm3%g%ges)
call init_atm2lnd_type (begg , endg , clm_a2l)
end subroutine initClmtype
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_type
!
! !INTERFACE:
subroutine init_pft_type (beg, end, p) 1
!
! !DESCRIPTION:
! Initialize components of pft_type structure
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type(pft_type), intent(inout):: p
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(p%gridcell(beg:end),p%wtgcell(beg:end))
allocate(p%landunit(beg:end),p%wtlunit(beg:end))
allocate(p%column (beg:end),p%wtcol (beg:end))
allocate(p%itype(beg:end))
allocate(p%mxy(beg:end))
allocate(p%area(beg:end))
end subroutine init_pft_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_type
!
! !INTERFACE:
subroutine init_column_type (beg, end, c) 1
!
! !DESCRIPTION:
! Initialize components of column_type structure
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type(column_type), intent(inout):: c
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(c%gridcell(beg:end),c%wtgcell(beg:end))
allocate(c%landunit(beg:end),c%wtlunit(beg:end))
allocate(c%pfti(beg:end),c%pftf(beg:end),c%npfts(beg:end))
allocate(c%itype(beg:end))
allocate(c%area(beg:end))
end subroutine init_column_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_landunit_type
!
! !INTERFACE:
subroutine init_landunit_type (beg, end,l) 1
!
! !DESCRIPTION:
! Initialize components of landunit_type structure
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type(landunit_type), intent(inout):: l
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(l%gridcell(beg:end),l%wtgcell(beg:end))
allocate(l%coli(beg:end),l%colf(beg:end),l%ncolumns(beg:end))
allocate(l%pfti(beg:end),l%pftf(beg:end),l%npfts (beg:end))
allocate(l%itype(beg:end))
allocate(l%ifspecial(beg:end))
allocate(l%lakpoi(beg:end))
allocate(l%urbpoi(beg:end))
! MV - these should be moved to landunit physical state -MV
allocate(l%canyon_hwr(beg:end))
allocate(l%wtroad_perv(beg:end))
allocate(l%ht_roof(beg:end))
allocate(l%wtlunit_roof(beg:end))
allocate(l%wind_hgt_canyon(beg:end))
allocate(l%z_0_town(beg:end))
allocate(l%z_d_town(beg:end))
allocate(l%area(beg:end))
l%canyon_hwr(beg:end) = nan
l%wtroad_perv(beg:end) = nan
l%ht_roof(beg:end) = nan
l%wtlunit_roof(beg:end) = nan
l%wind_hgt_canyon(beg:end) = nan
l%z_0_town(beg:end) = nan
l%z_d_town(beg:end) = nan
end subroutine init_landunit_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_gridcell_type
!
! !INTERFACE:
subroutine init_gridcell_type (beg, end,g) 1
!
! !DESCRIPTION:
! Initialize components of gridcell_type structure
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type(gridcell_type), intent(inout):: g
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(g%luni(beg:end),g%lunf(beg:end),g%nlandunits(beg:end))
allocate(g%coli(beg:end),g%colf(beg:end),g%ncolumns (beg:end))
allocate(g%pfti(beg:end),g%pftf(beg:end),g%npfts (beg:end))
allocate(g%gindex(beg:end))
allocate(g%area(beg:end))
allocate(g%lat(beg:end))
allocate(g%lon(beg:end))
allocate(g%latdeg(beg:end))
allocate(g%londeg(beg:end))
allocate(g%gindex_a(beg:end))
allocate(g%lat_a(beg:end))
allocate(g%lon_a(beg:end))
allocate(g%latdeg_a(beg:end))
allocate(g%londeg_a(beg:end))
end subroutine init_gridcell_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_energy_balance_type
!
! !INTERFACE:
subroutine init_energy_balance_type(beg, end, ebal) 5
!
! !DESCRIPTION:
! Initialize energy balance variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type(energy_balance_type), intent(inout):: ebal
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(ebal%errsoi(beg:end))
allocate(ebal%errseb(beg:end))
allocate(ebal%errsol(beg:end))
allocate(ebal%errlon(beg:end))
ebal%errsoi(beg:end) = nan
ebal%errseb(beg:end) = nan
ebal%errsol(beg:end) = nan
ebal%errlon(beg:end) = nan
end subroutine init_energy_balance_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_water_balance_type
!
! !INTERFACE:
subroutine init_water_balance_type(beg, end, wbal) 5
!
! !DESCRIPTION:
! Initialize water balance variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type(water_balance_type), intent(inout):: wbal
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(wbal%begwb(beg:end))
allocate(wbal%endwb(beg:end))
allocate(wbal%errh2o(beg:end))
wbal%begwb(beg:end) = nan
wbal%endwb(beg:end) = nan
wbal%errh2o(beg:end) = nan
end subroutine init_water_balance_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_carbon_balance_type
!
! !INTERFACE:
subroutine init_carbon_balance_type(beg, end, cbal) 2
!
! !DESCRIPTION:
! Initialize carbon balance variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type(carbon_balance_type), intent(inout):: cbal
!
! !REVISION HISTORY:
! Created by Peter Thornton, 12/11/2003
!
!EOP
!------------------------------------------------------------------------
allocate(cbal%begcb(beg:end))
allocate(cbal%endcb(beg:end))
allocate(cbal%errcb(beg:end))
cbal%begcb(beg:end) = nan
cbal%endcb(beg:end) = nan
cbal%errcb(beg:end) = nan
end subroutine init_carbon_balance_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_nitrogen_balance_type
!
! !INTERFACE:
subroutine init_nitrogen_balance_type(beg, end, nbal) 2
!
! !DESCRIPTION:
! Initialize nitrogen balance variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type(nitrogen_balance_type), intent(inout):: nbal
!
! !REVISION HISTORY:
! Created by Peter Thornton, 12/11/2003
!
!EOP
!------------------------------------------------------------------------
allocate(nbal%begnb(beg:end))
allocate(nbal%endnb(beg:end))
allocate(nbal%errnb(beg:end))
nbal%begnb(beg:end) = nan
nbal%endnb(beg:end) = nan
nbal%errnb(beg:end) = nan
end subroutine init_nitrogen_balance_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_ecophys_constants
!
! !INTERFACE:
subroutine init_pft_ecophys_constants() 1
!
! !DESCRIPTION:
! Initialize pft physical state
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pftcon%noveg(0:numpft))
allocate(pftcon%tree(0:numpft))
allocate(pftcon%smpso(0:numpft))
allocate(pftcon%smpsc(0:numpft))
allocate(pftcon%fnitr(0:numpft))
allocate(pftcon%foln(0:numpft))
allocate(pftcon%dleaf(0:numpft))
allocate(pftcon%c3psn(0:numpft))
allocate(pftcon%vcmx25(0:numpft))
allocate(pftcon%mp(0:numpft))
allocate(pftcon%qe25(0:numpft))
allocate(pftcon%xl(0:numpft))
allocate(pftcon%rhol(0:numpft,numrad))
allocate(pftcon%rhos(0:numpft,numrad))
allocate(pftcon%taul(0:numpft,numrad))
allocate(pftcon%taus(0:numpft,numrad))
allocate(pftcon%z0mr(0:numpft))
allocate(pftcon%displar(0:numpft))
allocate(pftcon%roota_par(0:numpft))
allocate(pftcon%rootb_par(0:numpft))
allocate(pftcon%sla(0:numpft))
allocate(pftcon%slatop(0:numpft))
allocate(pftcon%dsladlai(0:numpft))
allocate(pftcon%leafcn(0:numpft))
allocate(pftcon%flnr(0:numpft))
allocate(pftcon%woody(0:numpft))
allocate(pftcon%lflitcn(0:numpft))
allocate(pftcon%frootcn(0:numpft))
allocate(pftcon%livewdcn(0:numpft))
allocate(pftcon%deadwdcn(0:numpft))
#ifdef CROP
allocate(pftcon%graincn(0:numpft))
#endif
allocate(pftcon%froot_leaf(0:numpft))
allocate(pftcon%stem_leaf(0:numpft))
allocate(pftcon%croot_stem(0:numpft))
allocate(pftcon%flivewd(0:numpft))
allocate(pftcon%fcur(0:numpft))
allocate(pftcon%lf_flab(0:numpft))
allocate(pftcon%lf_fcel(0:numpft))
allocate(pftcon%lf_flig(0:numpft))
allocate(pftcon%fr_flab(0:numpft))
allocate(pftcon%fr_fcel(0:numpft))
allocate(pftcon%fr_flig(0:numpft))
allocate(pftcon%dw_fcel(0:numpft))
allocate(pftcon%dw_flig(0:numpft))
allocate(pftcon%leaf_long(0:numpft))
allocate(pftcon%evergreen(0:numpft))
allocate(pftcon%stress_decid(0:numpft))
allocate(pftcon%season_decid(0:numpft))
allocate(pftcon%resist(0:numpft))
allocate(pftcon%dwood(0:numpft))
pftcon%noveg(:) = bigint
pftcon%tree(:) = bigint
pftcon%smpso(:) = nan
pftcon%smpsc(:) = nan
pftcon%fnitr(:) = nan
pftcon%foln(:) = nan
pftcon%dleaf(:) = nan
pftcon%c3psn(:) = nan
pftcon%vcmx25(:) = nan
pftcon%mp(:) = nan
pftcon%qe25(:) = nan
pftcon%xl(:) = nan
pftcon%rhol(:,:numrad) = nan
pftcon%rhos(:,:numrad) = nan
pftcon%taul(:,:numrad) = nan
pftcon%taus(:,:numrad) = nan
pftcon%z0mr(:) = nan
pftcon%displar(:) = nan
pftcon%roota_par(:) = nan
pftcon%rootb_par(:) = nan
pftcon%sla(:) = nan
pftcon%slatop(:) = nan
pftcon%dsladlai(:) = nan
pftcon%leafcn(:) = nan
pftcon%flnr(:) = nan
pftcon%woody(:) = nan
pftcon%lflitcn(:) = nan
pftcon%frootcn(:) = nan
pftcon%livewdcn(:) = nan
pftcon%deadwdcn(:) = nan
#ifdef CROP
pftcon%graincn(:) = nan
#endif
pftcon%froot_leaf(:) = nan
pftcon%stem_leaf(:) = nan
pftcon%croot_stem(:) = nan
pftcon%flivewd(:) = nan
pftcon%fcur(:) = nan
pftcon%lf_flab(:) = nan
pftcon%lf_fcel(:) = nan
pftcon%lf_flig(:) = nan
pftcon%fr_flab(:) = nan
pftcon%fr_fcel(:) = nan
pftcon%fr_flig(:) = nan
pftcon%dw_fcel(:) = nan
pftcon%dw_flig(:) = nan
pftcon%leaf_long(:) = nan
pftcon%evergreen(:) = nan
pftcon%stress_decid(:) = nan
pftcon%season_decid(:) = nan
pftcon%resist(:) = nan
pftcon%dwood(:) = nan
end subroutine init_pft_ecophys_constants
#if (defined CNDV) || (defined CROP)
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_DGVMecophys_constants
!
! !INTERFACE:
subroutine init_pft_DGVMecophys_constants() 1
!
! !DESCRIPTION:
! Initialize pft physical state
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(dgv_pftcon%crownarea_max(0:numpft))
allocate(dgv_pftcon%tcmin(0:numpft))
allocate(dgv_pftcon%tcmax(0:numpft))
allocate(dgv_pftcon%gddmin(0:numpft))
allocate(dgv_pftcon%twmax(0:numpft))
allocate(dgv_pftcon%reinickerp(0:numpft))
allocate(dgv_pftcon%allom1(0:numpft))
allocate(dgv_pftcon%allom2(0:numpft))
allocate(dgv_pftcon%allom3(0:numpft))
dgv_pftcon%crownarea_max(:) = nan
dgv_pftcon%tcmin(:) = nan
dgv_pftcon%tcmax(:) = nan
dgv_pftcon%gddmin(:) = nan
dgv_pftcon%twmax(:) = nan
dgv_pftcon%reinickerp(:) = nan
dgv_pftcon%allom1(:) = nan
dgv_pftcon%allom2(:) = nan
dgv_pftcon%allom3(:) = nan
end subroutine init_pft_DGVMecophys_constants
#endif
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_pstate_type
!
! !INTERFACE:
subroutine init_pft_pstate_type(beg, end, pps) 2,1
!
! !DESCRIPTION:
! Initialize pft physical state
!
! !USES:
use clm_varcon, only : spval
#if (defined CASA)
use CASAMod , only : npools, nresp_pools, nlive, npool_types
#endif
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_pstate_type), intent(inout):: pps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pps%frac_veg_nosno(beg:end))
allocate(pps%frac_veg_nosno_alb(beg:end))
allocate(pps%emv(beg:end))
allocate(pps%z0mv(beg:end))
allocate(pps%z0hv(beg:end))
allocate(pps%z0qv(beg:end))
allocate(pps%rootfr(beg:end,1:nlevgrnd))
allocate(pps%rootr(beg:end,1:nlevgrnd))
allocate(pps%rresis(beg:end,1:nlevgrnd))
allocate(pps%dewmx(beg:end))
allocate(pps%rssun(beg:end))
allocate(pps%rssha(beg:end))
allocate(pps%laisun(beg:end))
allocate(pps%laisha(beg:end))
allocate(pps%btran(beg:end))
allocate(pps%fsun(beg:end))
allocate(pps%tlai(beg:end))
allocate(pps%tsai(beg:end))
allocate(pps%elai(beg:end))
allocate(pps%esai(beg:end))
allocate(pps%fwet(beg:end))
allocate(pps%fdry(beg:end))
allocate(pps%dt_veg(beg:end))
allocate(pps%htop(beg:end))
allocate(pps%hbot(beg:end))
allocate(pps%z0m(beg:end))
allocate(pps%displa(beg:end))
allocate(pps%albd(beg:end,1:numrad))
allocate(pps%albi(beg:end,1:numrad))
allocate(pps%fabd(beg:end,1:numrad))
allocate(pps%fabi(beg:end,1:numrad))
allocate(pps%ftdd(beg:end,1:numrad))
allocate(pps%ftid(beg:end,1:numrad))
allocate(pps%ftii(beg:end,1:numrad))
allocate(pps%u10(beg:end))
allocate(pps%fv(beg:end))
allocate(pps%ram1(beg:end))
#if (defined CROP)
allocate(pps%hdidx(beg:end))
allocate(pps%cumvd(beg:end))
allocate(pps%htmx(beg:end))
allocate(pps%vf(beg:end))
allocate(pps%gddmaturity(beg:end))
allocate(pps%gdd0(beg:end))
allocate(pps%gdd8(beg:end))
allocate(pps%gdd10(beg:end))
allocate(pps%gdd020(beg:end))
allocate(pps%gdd820(beg:end))
allocate(pps%gdd1020(beg:end))
allocate(pps%gddplant(beg:end))
allocate(pps%gddtsoi(beg:end))
allocate(pps%huileaf(beg:end))
allocate(pps%huigrain(beg:end))
allocate(pps%a10tmin(beg:end))
allocate(pps%a5tmin(beg:end))
allocate(pps%aleafi(beg:end))
allocate(pps%astemi(beg:end))
allocate(pps%aleaf(beg:end))
allocate(pps%astem(beg:end))
allocate(pps%croplive(beg:end))
allocate(pps%cropplant(beg:end)) !,numpft)) ! make 2-D if using
allocate(pps%harvdate(beg:end)) !,numpft)) ! crop rotation
allocate(pps%idop(beg:end))
allocate(pps%peaklai(beg:end))
#endif
allocate(pps%vds(beg:end))
allocate(pps%slasun(beg:end))
allocate(pps%slasha(beg:end))
allocate(pps%lncsun(beg:end))
allocate(pps%lncsha(beg:end))
allocate(pps%vcmxsun(beg:end))
allocate(pps%vcmxsha(beg:end))
allocate(pps%gdir(beg:end))
allocate(pps%omega(beg:end,1:numrad))
allocate(pps%eff_kid(beg:end,1:numrad))
allocate(pps%eff_kii(beg:end,1:numrad))
allocate(pps%sun_faid(beg:end,1:numrad))
allocate(pps%sun_faii(beg:end,1:numrad))
allocate(pps%sha_faid(beg:end,1:numrad))
allocate(pps%sha_faii(beg:end,1:numrad))
allocate(pps%forc_hgt_u_pft(beg:end))
allocate(pps%forc_hgt_t_pft(beg:end))
allocate(pps%forc_hgt_q_pft(beg:end))
! 4/14/05: PET
! Adding isotope code
allocate(pps%cisun(beg:end))
allocate(pps%cisha(beg:end))
#if (defined C13)
allocate(pps%alphapsnsun(beg:end))
allocate(pps%alphapsnsha(beg:end))
#endif
! heald: added from CASA definition
allocate(pps%sandfrac(beg:end))
allocate(pps%clayfrac(beg:end))
pps%sandfrac(beg:end) = nan
pps%clayfrac(beg:end) = nan
allocate(pps%mlaidiff(beg:end))
allocate(pps%rb1(beg:end))
allocate(pps%annlai(12,beg:end))
pps%mlaidiff(beg:end) = nan
pps%rb1(beg:end) = nan
pps%annlai(:,:) = nan
#if (defined CASA)
allocate(pps%Closs(beg:end,npools)) ! C lost to atm
allocate(pps%Ctrans(beg:end,npool_types)) ! C transfers out of pool types
allocate(pps%Resp_C(beg:end,npools))
allocate(pps%Tpool_C(beg:end,npools))! Total C pool size
allocate(pps%eff(beg:end,nresp_pools))
allocate(pps%frac_donor(beg:end,nresp_pools))
allocate(pps%livefr(beg:end,nlive)) !live fraction
allocate(pps%pet(beg:end)) !potential evaporation (mm h2o/s)
allocate(pps%co2flux(beg:end)) ! net CO2 flux (g C/m2/sec) [+= atm]
allocate(pps%fnpp(beg:end)) ! NPP (g C/m2/sec)
allocate(pps%soilt(beg:end)) !soil temp for top 30cm
allocate(pps%smoist(beg:end)) !soil moisture for top 30cm
allocate(pps%sz(beg:end))
allocate(pps%watopt(beg:end))
allocate(pps%watdry(beg:end))
allocate(pps%soiltc(beg:end)) !soil temp for entire column
allocate(pps%smoistc(beg:end)) !soil moisture for entire column
allocate(pps%szc(beg:end))
allocate(pps%watoptc(beg:end))
allocate(pps%watdryc(beg:end))
allocate(pps%Wlim(beg:end))
allocate(pps%litterscalar(beg:end))
allocate(pps%rootlitscalar(beg:end))
allocate(pps%stressCD(beg:end))
allocate(pps%excessC(beg:end)) ! excess Carbon (gC/m2/timestep)
allocate(pps%bgtemp(beg:end))
allocate(pps%bgmoist(beg:end))
allocate(pps%plai(beg:end)) ! prognostic LAI (m2 leaf/m2 ground)
allocate(pps%Cflux(beg:end))
allocate(pps%XSCpool(beg:end))
allocate(pps%tday(beg:end)) ! daily accumulated temperature (deg C)
allocate(pps%tdayavg(beg:end)) ! daily averaged temperature (deg C)
allocate(pps%tcount(beg:end)) ! counter for daily avg temp
allocate(pps%degday(beg:end)) ! accumulated degree days (deg C)
allocate(pps%ndegday(beg:end)) ! counter for number of degree days
allocate(pps%stressT(beg:end))
allocate(pps%stressW(beg:end)) ! water stress function for leaf loss
allocate(pps%iseabeg(beg:end)) ! index for start of growing season
allocate(pps%nstepbeg(beg:end)) ! nstep at start of growing season
allocate(pps%lgrow(beg:end)) ! growing season index (0 or 1) to be
! passed daily to CASA to get NPP
#if (defined CLAMP)
! Summary variables added for the C-LAMP Experiments
allocate(pps%casa_agnpp(beg:end))
allocate(pps%casa_ar(beg:end))
allocate(pps%casa_bgnpp(beg:end))
allocate(pps%casa_cwdc(beg:end))
allocate(pps%casa_cwdc_hr(beg:end))
allocate(pps%casa_cwdc_loss(beg:end))
allocate(pps%casa_frootc(beg:end))
allocate(pps%casa_frootc_alloc(beg:end))
allocate(pps%casa_frootc_loss(beg:end))
allocate(pps%casa_gpp(beg:end))
allocate(pps%casa_hr(beg:end))
allocate(pps%casa_leafc(beg:end))
allocate(pps%casa_leafc_alloc(beg:end))
allocate(pps%casa_leafc_loss(beg:end))
allocate(pps%casa_litterc(beg:end))
allocate(pps%casa_litterc_hr(beg:end))
allocate(pps%casa_litterc_loss(beg:end))
allocate(pps%casa_nee(beg:end))
allocate(pps%casa_nep(beg:end))
allocate(pps%casa_npp(beg:end))
allocate(pps%casa_soilc(beg:end))
allocate(pps%casa_soilc_hr(beg:end))
allocate(pps%casa_soilc_loss(beg:end))
allocate(pps%casa_woodc(beg:end))
allocate(pps%casa_woodc_alloc(beg:end))
allocate(pps%casa_woodc_loss(beg:end))
#endif
#endif
pps%frac_veg_nosno(beg:end) = bigint
pps%frac_veg_nosno_alb(beg:end) = 0
pps%emv(beg:end) = nan
pps%z0mv(beg:end) = nan
pps%z0hv(beg:end) = nan
pps%z0qv(beg:end) = nan
pps%rootfr(beg:end,:nlevgrnd) = spval
pps%rootr (beg:end,:nlevgrnd) = spval
pps%rresis(beg:end,:nlevgrnd) = spval
pps%dewmx(beg:end) = nan
pps%rssun(beg:end) = nan
pps%rssha(beg:end) = nan
pps%laisun(beg:end) = nan
pps%laisha(beg:end) = nan
pps%btran(beg:end) = nan
pps%fsun(beg:end) = spval
pps%tlai(beg:end) = 0._r8
pps%tsai(beg:end) = 0._r8
pps%elai(beg:end) = 0._r8
pps%esai(beg:end) = 0._r8
pps%fwet(beg:end) = nan
pps%fdry(beg:end) = nan
pps%dt_veg(beg:end) = nan
pps%htop(beg:end) = 0._r8
pps%hbot(beg:end) = 0._r8
pps%z0m(beg:end) = nan
pps%displa(beg:end) = nan
pps%albd(beg:end,:numrad) = nan
pps%albi(beg:end,:numrad) = nan
pps%fabd(beg:end,:numrad) = nan
pps%fabi(beg:end,:numrad) = nan
pps%ftdd(beg:end,:numrad) = nan
pps%ftid(beg:end,:numrad) = nan
pps%ftii(beg:end,:numrad) = nan
pps%u10(beg:end) = nan
pps%fv(beg:end) = nan
pps%ram1(beg:end) = nan
#if (defined CROP)
pps%hdidx(beg:end) = nan
pps%cumvd(beg:end) = nan
pps%htmx(beg:end) = nan
pps%vf(beg:end) = nan
pps%gddmaturity(beg:end) = nan
pps%gdd0(beg:end) = nan
pps%gdd8(beg:end) = nan
pps%gdd10(beg:end) = nan
pps%gdd020(beg:end) = nan
pps%gdd820(beg:end) = nan
pps%gdd1020(beg:end) = nan
pps%gddplant(beg:end) = nan
pps%gddtsoi(beg:end) = nan
pps%huileaf(beg:end) = nan
pps%huigrain(beg:end) = nan
pps%a10tmin(beg:end) = nan
pps%a5tmin(beg:end) = nan
pps%aleafi(beg:end) = nan
pps%astemi(beg:end) = nan
pps%aleaf(beg:end) = nan
pps%astem(beg:end) = nan
pps%croplive(beg:end) = bigint
pps%cropplant(beg:end) = bigint
pps%harvdate(beg:end) = bigint
pps%idop(beg:end) = bigint
pps%peaklai(beg:end) = bigint
#endif
pps%vds(beg:end) = nan
pps%slasun(beg:end) = nan
pps%slasha(beg:end) = nan
pps%lncsun(beg:end) = nan
pps%lncsha(beg:end) = nan
pps%vcmxsun(beg:end) = nan
pps%vcmxsha(beg:end) = nan
pps%gdir(beg:end) = nan
pps%omega(beg:end,1:numrad) = nan
pps%eff_kid(beg:end,1:numrad) = nan
pps%eff_kii(beg:end,1:numrad) = nan
pps%sun_faid(beg:end,1:numrad) = nan
pps%sun_faii(beg:end,1:numrad) = nan
pps%sha_faid(beg:end,1:numrad) = nan
pps%sha_faii(beg:end,1:numrad) = nan
pps%forc_hgt_u_pft(beg:end) = nan
pps%forc_hgt_t_pft(beg:end) = nan
pps%forc_hgt_q_pft(beg:end) = nan
! 4/14/05: PET
! Adding isotope code
pps%cisun(beg:end) = nan
pps%cisha(beg:end) = nan
#if (defined C13)
pps%alphapsnsun(beg:end) = nan
pps%alphapsnsha(beg:end) = nan
#endif
#if (defined CASA)
pps%Closs(beg:end,:npools) = spval !init w/ spval the variables that
pps%Ctrans(beg:end,:npool_types) = spval !init w/ spval the variables that
pps%Resp_C(beg:end,:npools) = nan !go to history, because CASA
pps%Tpool_C(beg:end,:npools) = spval !routines do not get called on
pps%livefr(beg:end,:nlive) = spval !first timestep of nsrest=0 and
pps%pet(beg:end) = spval !history would get nans
pps%co2flux(beg:end) = nan !in the first timestep
pps%fnpp(beg:end) = nan
pps%excessC(beg:end) = spval
pps%bgtemp(beg:end) = spval
pps%bgmoist(beg:end) = spval
pps%plai(beg:end) = spval
pps%Cflux(beg:end) = nan
pps%XSCpool(beg:end) = spval
pps%tdayavg(beg:end) = spval
pps%degday(beg:end) = spval
pps%stressT(beg:end) = spval
pps%stressW(beg:end) = spval
pps%stressCD(beg:end) = spval
pps%iseabeg(beg:end) = spval
pps%nstepbeg(beg:end) = spval
pps%lgrow(beg:end) = spval
pps%eff(beg:end,:nresp_pools) = nan
pps%frac_donor(beg:end,:nresp_pools) = nan
pps%soilt(beg:end) = spval ! on history file
pps%smoist(beg:end) = spval ! on history file
pps%sz(beg:end) = nan
pps%watopt(beg:end) = nan
pps%watdry(beg:end) = nan
pps%soiltc(beg:end) = nan
pps%smoistc(beg:end) = nan
pps%szc(beg:end) = nan
pps%watoptc(beg:end) = spval ! on history file
pps%watdryc(beg:end) = spval ! on history file
pps%Wlim(beg:end) = spval ! on history file
pps%litterscalar(beg:end) = nan
pps%rootlitscalar(beg:end) = nan
pps%tday(beg:end) = nan
pps%tcount(beg:end) = nan
pps%ndegday(beg:end) = nan
#if (defined CLAMP)
! Summary variables added for the C-LAMP Experiments
pps%casa_agnpp(beg:end) = nan
pps%casa_ar(beg:end) = nan
pps%casa_bgnpp(beg:end) = nan
pps%casa_cwdc(beg:end) = nan
pps%casa_cwdc_hr(beg:end) = nan
pps%casa_cwdc_loss(beg:end) = nan
pps%casa_frootc(beg:end) = nan
pps%casa_frootc_alloc(beg:end) = nan
pps%casa_frootc_loss(beg:end) = nan
pps%casa_gpp(beg:end) = nan
pps%casa_hr(beg:end) = nan
pps%casa_leafc(beg:end) = nan
pps%casa_leafc_alloc(beg:end) = nan
pps%casa_leafc_loss(beg:end) = nan
pps%casa_litterc(beg:end) = nan
pps%casa_litterc_loss(beg:end) = nan
pps%casa_nee(beg:end) = nan
pps%casa_nep(beg:end) = nan
pps%casa_npp(beg:end) = nan
pps%casa_soilc(beg:end) = nan
pps%casa_soilc_hr(beg:end) = nan
pps%casa_soilc_loss(beg:end) = nan
pps%casa_woodc(beg:end) = nan
pps%casa_woodc_alloc(beg:end) = nan
pps%casa_woodc_loss(beg:end) = nan
#endif
#endif
end subroutine init_pft_pstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_epv_type
!
! !INTERFACE:
subroutine init_pft_epv_type(beg, end, pepv) 1
!
! !DESCRIPTION:
! Initialize pft ecophysiological variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_epv_type), intent(inout):: pepv
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
allocate(pepv%dormant_flag(beg:end))
allocate(pepv%days_active(beg:end))
allocate(pepv%onset_flag(beg:end))
allocate(pepv%onset_counter(beg:end))
allocate(pepv%onset_gddflag(beg:end))
allocate(pepv%onset_fdd(beg:end))
allocate(pepv%onset_gdd(beg:end))
allocate(pepv%onset_swi(beg:end))
allocate(pepv%offset_flag(beg:end))
allocate(pepv%offset_counter(beg:end))
allocate(pepv%offset_fdd(beg:end))
allocate(pepv%offset_swi(beg:end))
allocate(pepv%lgsf(beg:end))
allocate(pepv%bglfr(beg:end))
allocate(pepv%bgtr(beg:end))
allocate(pepv%dayl(beg:end))
allocate(pepv%prev_dayl(beg:end))
allocate(pepv%annavg_t2m(beg:end))
allocate(pepv%tempavg_t2m(beg:end))
allocate(pepv%gpp(beg:end))
allocate(pepv%availc(beg:end))
allocate(pepv%xsmrpool_recover(beg:end))
#if (defined C13)
allocate(pepv%xsmrpool_c13ratio(beg:end))
#endif
allocate(pepv%alloc_pnow(beg:end))
allocate(pepv%c_allometry(beg:end))
allocate(pepv%n_allometry(beg:end))
allocate(pepv%plant_ndemand(beg:end))
allocate(pepv%tempsum_potential_gpp(beg:end))
allocate(pepv%annsum_potential_gpp(beg:end))
allocate(pepv%tempmax_retransn(beg:end))
allocate(pepv%annmax_retransn(beg:end))
allocate(pepv%avail_retransn(beg:end))
allocate(pepv%plant_nalloc(beg:end))
allocate(pepv%plant_calloc(beg:end))
allocate(pepv%excess_cflux(beg:end))
allocate(pepv%downreg(beg:end))
allocate(pepv%prev_leafc_to_litter(beg:end))
allocate(pepv%prev_frootc_to_litter(beg:end))
allocate(pepv%tempsum_npp(beg:end))
allocate(pepv%annsum_npp(beg:end))
#if (defined CNDV)
allocate(pepv%tempsum_litfall(beg:end))
allocate(pepv%annsum_litfall(beg:end))
#endif
#if (defined C13)
! 4/21/05, PET
! Adding isotope code
allocate(pepv%rc13_canair(beg:end))
allocate(pepv%rc13_psnsun(beg:end))
allocate(pepv%rc13_psnsha(beg:end))
#endif
pepv%dormant_flag(beg:end) = nan
pepv%days_active(beg:end) = nan
pepv%onset_flag(beg:end) = nan
pepv%onset_counter(beg:end) = nan
pepv%onset_gddflag(beg:end) = nan
pepv%onset_fdd(beg:end) = nan
pepv%onset_gdd(beg:end) = nan
pepv%onset_swi(beg:end) = nan
pepv%offset_flag(beg:end) = nan
pepv%offset_counter(beg:end) = nan
pepv%offset_fdd(beg:end) = nan
pepv%offset_swi(beg:end) = nan
pepv%lgsf(beg:end) = nan
pepv%bglfr(beg:end) = nan
pepv%bgtr(beg:end) = nan
pepv%dayl(beg:end) = nan
pepv%prev_dayl(beg:end) = nan
pepv%annavg_t2m(beg:end) = nan
pepv%tempavg_t2m(beg:end) = nan
pepv%gpp(beg:end) = nan
pepv%availc(beg:end) = nan
pepv%xsmrpool_recover(beg:end) = nan
#if (defined C13)
pepv%xsmrpool_c13ratio(beg:end) = nan
#endif
pepv%alloc_pnow(beg:end) = nan
pepv%c_allometry(beg:end) = nan
pepv%n_allometry(beg:end) = nan
pepv%plant_ndemand(beg:end) = nan
pepv%tempsum_potential_gpp(beg:end) = nan
pepv%annsum_potential_gpp(beg:end) = nan
pepv%tempmax_retransn(beg:end) = nan
pepv%annmax_retransn(beg:end) = nan
pepv%avail_retransn(beg:end) = nan
pepv%plant_nalloc(beg:end) = nan
pepv%plant_calloc(beg:end) = nan
pepv%excess_cflux(beg:end) = nan
pepv%downreg(beg:end) = nan
pepv%prev_leafc_to_litter(beg:end) = nan
pepv%prev_frootc_to_litter(beg:end) = nan
pepv%tempsum_npp(beg:end) = nan
pepv%annsum_npp(beg:end) = nan
#if (defined CNDV)
pepv%tempsum_litfall(beg:end) = nan
pepv%annsum_litfall(beg:end) = nan
#endif
#if (defined C13)
! 4/21/05, PET
! Adding isotope code
pepv%rc13_canair(beg:end) = nan
pepv%rc13_psnsun(beg:end) = nan
pepv%rc13_psnsha(beg:end) = nan
#endif
end subroutine init_pft_epv_type
#if (defined CNDV) || (defined CROP)
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_pdgvstate_type
!
! !INTERFACE:
subroutine init_pft_pdgvstate_type(beg, end, pdgvs) 2
!
! !DESCRIPTION:
! Initialize pft DGVM state variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_dgvstate_type), intent(inout):: pdgvs
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pdgvs%agddtw(beg:end))
allocate(pdgvs%agdd(beg:end))
allocate(pdgvs%t10(beg:end))
allocate(pdgvs%t_mo(beg:end))
allocate(pdgvs%t_mo_min(beg:end))
allocate(pdgvs%prec365(beg:end))
allocate(pdgvs%present(beg:end))
allocate(pdgvs%pftmayexist(beg:end))
allocate(pdgvs%nind(beg:end))
allocate(pdgvs%lm_ind(beg:end))
allocate(pdgvs%lai_ind(beg:end))
allocate(pdgvs%fpcinc(beg:end))
allocate(pdgvs%fpcgrid(beg:end))
allocate(pdgvs%fpcgridold(beg:end))
allocate(pdgvs%crownarea(beg:end))
allocate(pdgvs%greffic(beg:end))
allocate(pdgvs%heatstress(beg:end))
pdgvs%agddtw(beg:end) = nan
pdgvs%agdd(beg:end) = nan
pdgvs%t10(beg:end) = nan
pdgvs%t_mo(beg:end) = nan
pdgvs%t_mo_min(beg:end) = nan
pdgvs%prec365(beg:end) = nan
pdgvs%present(beg:end) = .false.
pdgvs%pftmayexist(beg:end) = .true.
pdgvs%nind(beg:end) = nan
pdgvs%lm_ind(beg:end) = nan
pdgvs%lai_ind(beg:end) = nan
pdgvs%fpcinc(beg:end) = nan
pdgvs%fpcgrid(beg:end) = nan
pdgvs%fpcgridold(beg:end) = nan
pdgvs%crownarea(beg:end) = nan
pdgvs%greffic(beg:end) = nan
pdgvs%heatstress(beg:end) = nan
end subroutine init_pft_pdgvstate_type
#endif
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_vstate_type
!
! !INTERFACE:
subroutine init_pft_vstate_type(beg, end, pvs) 1,1
!
! !DESCRIPTION:
! Initialize pft VOC variables
!
! !USES:
use clm_varcon, only : spval
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_vstate_type), intent(inout):: pvs
!
! !REVISION HISTORY:
! Created by Erik Kluzek
!
!EOP
!------------------------------------------------------------------------
allocate(pvs%t_veg24 (beg:end))
allocate(pvs%t_veg240(beg:end))
allocate(pvs%fsd24 (beg:end))
allocate(pvs%fsd240 (beg:end))
allocate(pvs%fsi24 (beg:end))
allocate(pvs%fsi240 (beg:end))
allocate(pvs%fsun24 (beg:end))
allocate(pvs%fsun240 (beg:end))
allocate(pvs%elai_p (beg:end))
pvs%t_veg24 (beg:end) = spval
pvs%t_veg240(beg:end) = spval
pvs%fsd24 (beg:end) = spval
pvs%fsd240 (beg:end) = spval
pvs%fsi24 (beg:end) = spval
pvs%fsi240 (beg:end) = spval
pvs%fsun24 (beg:end) = spval
pvs%fsun240 (beg:end) = spval
pvs%elai_p (beg:end) = spval
end subroutine init_pft_vstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_estate_type
!
! !INTERFACE:
subroutine init_pft_estate_type(beg, end, pes) 2
!
! !DESCRIPTION:
! Initialize pft energy state
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_estate_type), intent(inout):: pes
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pes%t_ref2m(beg:end))
allocate(pes%t_ref2m_min(beg:end))
allocate(pes%t_ref2m_max(beg:end))
allocate(pes%t_ref2m_min_inst(beg:end))
allocate(pes%t_ref2m_max_inst(beg:end))
allocate(pes%q_ref2m(beg:end))
allocate(pes%t_ref2m_u(beg:end))
allocate(pes%t_ref2m_r(beg:end))
allocate(pes%t_ref2m_min_u(beg:end))
allocate(pes%t_ref2m_min_r(beg:end))
allocate(pes%t_ref2m_max_u(beg:end))
allocate(pes%t_ref2m_max_r(beg:end))
allocate(pes%t_ref2m_min_inst_u(beg:end))
allocate(pes%t_ref2m_min_inst_r(beg:end))
allocate(pes%t_ref2m_max_inst_u(beg:end))
allocate(pes%t_ref2m_max_inst_r(beg:end))
allocate(pes%rh_ref2m(beg:end))
allocate(pes%rh_ref2m_u(beg:end))
allocate(pes%rh_ref2m_r(beg:end))
allocate(pes%t_veg(beg:end))
allocate(pes%thm(beg:end))
pes%t_ref2m(beg:end) = nan
pes%t_ref2m_min(beg:end) = nan
pes%t_ref2m_max(beg:end) = nan
pes%t_ref2m_min_inst(beg:end) = nan
pes%t_ref2m_max_inst(beg:end) = nan
pes%q_ref2m(beg:end) = nan
pes%t_ref2m_u(beg:end) = nan
pes%t_ref2m_r(beg:end) = nan
pes%t_ref2m_min_u(beg:end) = nan
pes%t_ref2m_min_r(beg:end) = nan
pes%t_ref2m_max_u(beg:end) = nan
pes%t_ref2m_max_r(beg:end) = nan
pes%t_ref2m_min_inst_u(beg:end) = nan
pes%t_ref2m_min_inst_r(beg:end) = nan
pes%t_ref2m_max_inst_u(beg:end) = nan
pes%t_ref2m_max_inst_r(beg:end) = nan
pes%rh_ref2m(beg:end) = nan
pes%rh_ref2m_u(beg:end) = nan
pes%rh_ref2m_r(beg:end) = nan
pes%t_veg(beg:end) = nan
pes%thm(beg:end) = nan
end subroutine init_pft_estate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_wstate_type
!
! !INTERFACE:
subroutine init_pft_wstate_type(beg, end, pws) 2
!
! !DESCRIPTION:
! Initialize pft water state
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_wstate_type), intent(inout):: pws !pft water state
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pws%h2ocan(beg:end))
pws%h2ocan(beg:end) = nan
end subroutine init_pft_wstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_cstate_type
!
! !INTERFACE:
subroutine init_pft_cstate_type(beg, end, pcs) 4
!
! !DESCRIPTION:
! Initialize pft carbon state
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_cstate_type), intent(inout):: pcs !pft carbon state
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
allocate(pcs%leafc(beg:end))
allocate(pcs%leafc_storage(beg:end))
allocate(pcs%leafc_xfer(beg:end))
allocate(pcs%frootc(beg:end))
allocate(pcs%frootc_storage(beg:end))
allocate(pcs%frootc_xfer(beg:end))
allocate(pcs%livestemc(beg:end))
allocate(pcs%livestemc_storage(beg:end))
allocate(pcs%livestemc_xfer(beg:end))
allocate(pcs%deadstemc(beg:end))
allocate(pcs%deadstemc_storage(beg:end))
allocate(pcs%deadstemc_xfer(beg:end))
allocate(pcs%livecrootc(beg:end))
allocate(pcs%livecrootc_storage(beg:end))
allocate(pcs%livecrootc_xfer(beg:end))
allocate(pcs%deadcrootc(beg:end))
allocate(pcs%deadcrootc_storage(beg:end))
allocate(pcs%deadcrootc_xfer(beg:end))
allocate(pcs%gresp_storage(beg:end))
allocate(pcs%gresp_xfer(beg:end))
allocate(pcs%cpool(beg:end))
allocate(pcs%xsmrpool(beg:end))
allocate(pcs%pft_ctrunc(beg:end))
allocate(pcs%dispvegc(beg:end))
allocate(pcs%storvegc(beg:end))
allocate(pcs%totvegc(beg:end))
allocate(pcs%totpftc(beg:end))
allocate(pcs%leafcmax(beg:end))
#if (defined CROP)
allocate(pcs%grainc(beg:end))
allocate(pcs%grainc_storage(beg:end))
allocate(pcs%grainc_xfer(beg:end))
#endif
#if (defined CLAMP) && (defined CN)
!CLAMP
allocate(pcs%woodc(beg:end))
#endif
pcs%leafc(beg:end) = nan
pcs%leafc_storage(beg:end) = nan
pcs%leafc_xfer(beg:end) = nan
pcs%frootc(beg:end) = nan
pcs%frootc_storage(beg:end) = nan
pcs%frootc_xfer(beg:end) = nan
pcs%livestemc(beg:end) = nan
pcs%livestemc_storage(beg:end) = nan
pcs%livestemc_xfer(beg:end) = nan
pcs%deadstemc(beg:end) = nan
pcs%deadstemc_storage(beg:end) = nan
pcs%deadstemc_xfer(beg:end) = nan
pcs%livecrootc(beg:end) = nan
pcs%livecrootc_storage(beg:end) = nan
pcs%livecrootc_xfer(beg:end) = nan
pcs%deadcrootc(beg:end) = nan
pcs%deadcrootc_storage(beg:end) = nan
pcs%deadcrootc_xfer(beg:end) = nan
pcs%gresp_storage(beg:end) = nan
pcs%gresp_xfer(beg:end) = nan
pcs%cpool(beg:end) = nan
pcs%xsmrpool(beg:end) = nan
pcs%pft_ctrunc(beg:end) = nan
pcs%dispvegc(beg:end) = nan
pcs%storvegc(beg:end) = nan
pcs%totvegc(beg:end) = nan
pcs%totpftc(beg:end) = nan
pcs%leafcmax(beg:end) = nan
#if (defined CROP)
pcs%grainc(beg:end) = nan
pcs%grainc_storage(beg:end) = nan
pcs%grainc_xfer(beg:end) = nan
#endif
#if (defined CLAMP) && (defined CN)
!CLAMP
pcs%woodc(beg:end) = nan
#endif
end subroutine init_pft_cstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_nstate_type
!
! !INTERFACE:
subroutine init_pft_nstate_type(beg, end, pns) 2
!
! !DESCRIPTION:
! Initialize pft nitrogen state
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_nstate_type), intent(inout):: pns !pft nitrogen state
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
#if (defined CROP)
allocate(pns%grainn(beg:end))
allocate(pns%grainn_storage(beg:end))
allocate(pns%grainn_xfer(beg:end))
#endif
allocate(pns%leafn(beg:end))
allocate(pns%leafn_storage(beg:end))
allocate(pns%leafn_xfer(beg:end))
allocate(pns%frootn(beg:end))
allocate(pns%frootn_storage(beg:end))
allocate(pns%frootn_xfer(beg:end))
allocate(pns%livestemn(beg:end))
allocate(pns%livestemn_storage(beg:end))
allocate(pns%livestemn_xfer(beg:end))
allocate(pns%deadstemn(beg:end))
allocate(pns%deadstemn_storage(beg:end))
allocate(pns%deadstemn_xfer(beg:end))
allocate(pns%livecrootn(beg:end))
allocate(pns%livecrootn_storage(beg:end))
allocate(pns%livecrootn_xfer(beg:end))
allocate(pns%deadcrootn(beg:end))
allocate(pns%deadcrootn_storage(beg:end))
allocate(pns%deadcrootn_xfer(beg:end))
allocate(pns%retransn(beg:end))
allocate(pns%npool(beg:end))
allocate(pns%pft_ntrunc(beg:end))
allocate(pns%dispvegn(beg:end))
allocate(pns%storvegn(beg:end))
allocate(pns%totvegn(beg:end))
allocate(pns%totpftn(beg:end))
#if (defined CROP)
pns%grainn(beg:end) = nan
pns%grainn_storage(beg:end) = nan
pns%grainn_xfer(beg:end) = nan
#endif
pns%leafn(beg:end) = nan
pns%leafn_storage(beg:end) = nan
pns%leafn_xfer(beg:end) = nan
pns%frootn(beg:end) = nan
pns%frootn_storage(beg:end) = nan
pns%frootn_xfer(beg:end) = nan
pns%livestemn(beg:end) = nan
pns%livestemn_storage(beg:end) = nan
pns%livestemn_xfer(beg:end) = nan
pns%deadstemn(beg:end) = nan
pns%deadstemn_storage(beg:end) = nan
pns%deadstemn_xfer(beg:end) = nan
pns%livecrootn(beg:end) = nan
pns%livecrootn_storage(beg:end) = nan
pns%livecrootn_xfer(beg:end) = nan
pns%deadcrootn(beg:end) = nan
pns%deadcrootn_storage(beg:end) = nan
pns%deadcrootn_xfer(beg:end) = nan
pns%retransn(beg:end) = nan
pns%npool(beg:end) = nan
pns%pft_ntrunc(beg:end) = nan
pns%dispvegn(beg:end) = nan
pns%storvegn(beg:end) = nan
pns%totvegn(beg:end) = nan
pns%totpftn(beg:end) = nan
end subroutine init_pft_nstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_eflux_type
!
! !INTERFACE:
subroutine init_pft_eflux_type(beg, end, pef) 2
!
! !DESCRIPTION:
! Initialize pft energy flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_eflux_type), intent(inout):: pef
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pef%sabg(beg:end))
allocate(pef%sabv(beg:end))
allocate(pef%fsa(beg:end))
allocate(pef%fsa_u(beg:end))
allocate(pef%fsa_r(beg:end))
allocate(pef%fsr(beg:end))
allocate(pef%parsun(beg:end))
allocate(pef%parsha(beg:end))
allocate(pef%dlrad(beg:end))
allocate(pef%ulrad(beg:end))
allocate(pef%eflx_lh_tot(beg:end))
allocate(pef%eflx_lh_tot_u(beg:end))
allocate(pef%eflx_lh_tot_r(beg:end))
allocate(pef%eflx_lh_grnd(beg:end))
allocate(pef%eflx_soil_grnd(beg:end))
allocate(pef%eflx_soil_grnd_u(beg:end))
allocate(pef%eflx_soil_grnd_r(beg:end))
allocate(pef%eflx_sh_tot(beg:end))
allocate(pef%eflx_sh_tot_u(beg:end))
allocate(pef%eflx_sh_tot_r(beg:end))
allocate(pef%eflx_sh_grnd(beg:end))
allocate(pef%eflx_sh_veg(beg:end))
allocate(pef%eflx_lh_vege(beg:end))
allocate(pef%eflx_lh_vegt(beg:end))
allocate(pef%eflx_wasteheat_pft(beg:end))
allocate(pef%eflx_heat_from_ac_pft(beg:end))
allocate(pef%eflx_traffic_pft(beg:end))
allocate(pef%eflx_anthro(beg:end))
allocate(pef%cgrnd(beg:end))
allocate(pef%cgrndl(beg:end))
allocate(pef%cgrnds(beg:end))
allocate(pef%eflx_gnet(beg:end))
allocate(pef%dgnetdT(beg:end))
allocate(pef%eflx_lwrad_out(beg:end))
allocate(pef%eflx_lwrad_net(beg:end))
allocate(pef%eflx_lwrad_net_u(beg:end))
allocate(pef%eflx_lwrad_net_r(beg:end))
allocate(pef%netrad(beg:end))
allocate(pef%fsds_vis_d(beg:end))
allocate(pef%fsds_nir_d(beg:end))
allocate(pef%fsds_vis_i(beg:end))
allocate(pef%fsds_nir_i(beg:end))
allocate(pef%fsr_vis_d(beg:end))
allocate(pef%fsr_nir_d(beg:end))
allocate(pef%fsr_vis_i(beg:end))
allocate(pef%fsr_nir_i(beg:end))
allocate(pef%fsds_vis_d_ln(beg:end))
allocate(pef%fsds_nir_d_ln(beg:end))
allocate(pef%fsr_vis_d_ln(beg:end))
allocate(pef%fsr_nir_d_ln(beg:end))
allocate(pef%sun_add(beg:end,1:numrad))
allocate(pef%tot_aid(beg:end,1:numrad))
allocate(pef%sun_aid(beg:end,1:numrad))
allocate(pef%sun_aii(beg:end,1:numrad))
allocate(pef%sha_aid(beg:end,1:numrad))
allocate(pef%sha_aii(beg:end,1:numrad))
allocate(pef%sun_atot(beg:end,1:numrad))
allocate(pef%sha_atot(beg:end,1:numrad))
allocate(pef%sun_alf(beg:end,1:numrad))
allocate(pef%sha_alf(beg:end,1:numrad))
allocate(pef%sun_aperlai(beg:end,1:numrad))
allocate(pef%sha_aperlai(beg:end,1:numrad))
allocate(pef%sabg_lyr(beg:end,-nlevsno+1:1))
allocate(pef%sfc_frc_aer(beg:end))
allocate(pef%sfc_frc_bc(beg:end))
allocate(pef%sfc_frc_oc(beg:end))
allocate(pef%sfc_frc_dst(beg:end))
allocate(pef%sfc_frc_aer_sno(beg:end))
allocate(pef%sfc_frc_bc_sno(beg:end))
allocate(pef%sfc_frc_oc_sno(beg:end))
allocate(pef%sfc_frc_dst_sno(beg:end))
allocate(pef%fsr_sno_vd(beg:end))
allocate(pef%fsr_sno_nd(beg:end))
allocate(pef%fsr_sno_vi(beg:end))
allocate(pef%fsr_sno_ni(beg:end))
allocate(pef%fsds_sno_vd(beg:end))
allocate(pef%fsds_sno_nd(beg:end))
allocate(pef%fsds_sno_vi(beg:end))
allocate(pef%fsds_sno_ni(beg:end))
pef%sabg(beg:end) = nan
pef%sabv(beg:end) = nan
pef%fsa(beg:end) = nan
pef%fsa_u(beg:end) = nan
pef%fsa_r(beg:end) = nan
pef%fsr(beg:end) = nan
pef%parsun(beg:end) = nan
pef%parsha(beg:end) = nan
pef%dlrad(beg:end) = nan
pef%ulrad(beg:end) = nan
pef%eflx_lh_tot(beg:end) = nan
pef%eflx_lh_tot_u(beg:end) = nan
pef%eflx_lh_tot_r(beg:end) = nan
pef%eflx_lh_grnd(beg:end) = nan
pef%eflx_soil_grnd(beg:end) = nan
pef%eflx_soil_grnd_u(beg:end) = nan
pef%eflx_soil_grnd_r(beg:end) = nan
pef%eflx_sh_tot(beg:end) = nan
pef%eflx_sh_tot_u(beg:end) = nan
pef%eflx_sh_tot_r(beg:end) = nan
pef%eflx_sh_grnd(beg:end) = nan
pef%eflx_sh_veg(beg:end) = nan
pef%eflx_lh_vege(beg:end) = nan
pef%eflx_lh_vegt(beg:end) = nan
pef%eflx_wasteheat_pft(beg:end) = nan
pef%eflx_heat_from_ac_pft(beg:end) = nan
pef%eflx_traffic_pft(beg:end) = nan
pef%eflx_anthro(beg:end) = nan
pef%cgrnd(beg:end) = nan
pef%cgrndl(beg:end) = nan
pef%cgrnds(beg:end) = nan
pef%eflx_gnet(beg:end) = nan
pef%dgnetdT(beg:end) = nan
pef%eflx_lwrad_out(beg:end) = nan
pef%eflx_lwrad_net(beg:end) = nan
pef%eflx_lwrad_net_u(beg:end) = nan
pef%eflx_lwrad_net_r(beg:end) = nan
pef%netrad(beg:end) = nan
pef%fsds_vis_d(beg:end) = nan
pef%fsds_nir_d(beg:end) = nan
pef%fsds_vis_i(beg:end) = nan
pef%fsds_nir_i(beg:end) = nan
pef%fsr_vis_d(beg:end) = nan
pef%fsr_nir_d(beg:end) = nan
pef%fsr_vis_i(beg:end) = nan
pef%fsr_nir_i(beg:end) = nan
pef%fsds_vis_d_ln(beg:end) = nan
pef%fsds_nir_d_ln(beg:end) = nan
pef%fsr_vis_d_ln(beg:end) = nan
pef%fsr_nir_d_ln(beg:end) = nan
pef%sun_add(beg:end,1:numrad) = nan
pef%tot_aid(beg:end,1:numrad) = nan
pef%sun_aid(beg:end,1:numrad) = nan
pef%sun_aii(beg:end,1:numrad) = nan
pef%sha_aid(beg:end,1:numrad) = nan
pef%sha_aii(beg:end,1:numrad) = nan
pef%sun_atot(beg:end,1:numrad) = nan
pef%sha_atot(beg:end,1:numrad) = nan
pef%sun_alf(beg:end,1:numrad) = nan
pef%sha_alf(beg:end,1:numrad) = nan
pef%sun_aperlai(beg:end,1:numrad) = nan
pef%sha_aperlai(beg:end,1:numrad) = nan
pef%sabg_lyr(beg:end,-nlevsno+1:1) = nan
pef%sfc_frc_aer(beg:end) = nan
pef%sfc_frc_bc(beg:end) = nan
pef%sfc_frc_oc(beg:end) = nan
pef%sfc_frc_dst(beg:end) = nan
pef%sfc_frc_aer_sno(beg:end) = nan
pef%sfc_frc_bc_sno(beg:end) = nan
pef%sfc_frc_oc_sno(beg:end) = nan
pef%sfc_frc_dst_sno(beg:end) = nan
pef%fsr_sno_vd(beg:end) = nan
pef%fsr_sno_nd(beg:end) = nan
pef%fsr_sno_vi(beg:end) = nan
pef%fsr_sno_ni(beg:end) = nan
pef%fsds_sno_vd(beg:end) = nan
pef%fsds_sno_nd(beg:end) = nan
pef%fsds_sno_vi(beg:end) = nan
pef%fsds_sno_ni(beg:end) = nan
end subroutine init_pft_eflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_mflux_type
!
! !INTERFACE:
subroutine init_pft_mflux_type(beg, end, pmf) 2
!
! !DESCRIPTION:
! Initialize pft momentum flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_mflux_type), intent(inout) :: pmf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pmf%taux(beg:end))
allocate(pmf%tauy(beg:end))
pmf%taux(beg:end) = nan
pmf%tauy(beg:end) = nan
end subroutine init_pft_mflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_wflux_type
!
! !INTERFACE:
subroutine init_pft_wflux_type(beg, end, pwf) 2
!
! !DESCRIPTION:
! Initialize pft water flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_wflux_type), intent(inout) :: pwf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pwf%qflx_prec_intr(beg:end))
allocate(pwf%qflx_prec_grnd(beg:end))
allocate(pwf%qflx_rain_grnd(beg:end))
allocate(pwf%qflx_snow_grnd(beg:end))
allocate(pwf%qflx_snwcp_liq(beg:end))
allocate(pwf%qflx_snwcp_ice(beg:end))
allocate(pwf%qflx_evap_veg(beg:end))
allocate(pwf%qflx_tran_veg(beg:end))
allocate(pwf%qflx_evap_can(beg:end))
allocate(pwf%qflx_evap_soi(beg:end))
allocate(pwf%qflx_evap_tot(beg:end))
allocate(pwf%qflx_evap_grnd(beg:end))
allocate(pwf%qflx_dew_grnd(beg:end))
allocate(pwf%qflx_sub_snow(beg:end))
allocate(pwf%qflx_dew_snow(beg:end))
pwf%qflx_prec_intr(beg:end) = nan
pwf%qflx_prec_grnd(beg:end) = nan
pwf%qflx_rain_grnd(beg:end) = nan
pwf%qflx_snow_grnd(beg:end) = nan
pwf%qflx_snwcp_liq(beg:end) = nan
pwf%qflx_snwcp_ice(beg:end) = nan
pwf%qflx_evap_veg(beg:end) = nan
pwf%qflx_tran_veg(beg:end) = nan
pwf%qflx_evap_can(beg:end) = nan
pwf%qflx_evap_soi(beg:end) = nan
pwf%qflx_evap_tot(beg:end) = nan
pwf%qflx_evap_grnd(beg:end) = nan
pwf%qflx_dew_grnd(beg:end) = nan
pwf%qflx_sub_snow(beg:end) = nan
pwf%qflx_dew_snow(beg:end) = nan
end subroutine init_pft_wflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_cflux_type
!
! !INTERFACE:
subroutine init_pft_cflux_type(beg, end, pcf) 4
!
! !DESCRIPTION:
! Initialize pft carbon flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_cflux_type), intent(inout) :: pcf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pcf%psnsun(beg:end))
allocate(pcf%psnsha(beg:end))
allocate(pcf%fpsn(beg:end))
allocate(pcf%fco2(beg:end))
allocate(pcf%m_leafc_to_litter(beg:end))
allocate(pcf%m_frootc_to_litter(beg:end))
allocate(pcf%m_leafc_storage_to_litter(beg:end))
allocate(pcf%m_frootc_storage_to_litter(beg:end))
allocate(pcf%m_livestemc_storage_to_litter(beg:end))
allocate(pcf%m_deadstemc_storage_to_litter(beg:end))
allocate(pcf%m_livecrootc_storage_to_litter(beg:end))
allocate(pcf%m_deadcrootc_storage_to_litter(beg:end))
allocate(pcf%m_leafc_xfer_to_litter(beg:end))
allocate(pcf%m_frootc_xfer_to_litter(beg:end))
allocate(pcf%m_livestemc_xfer_to_litter(beg:end))
allocate(pcf%m_deadstemc_xfer_to_litter(beg:end))
allocate(pcf%m_livecrootc_xfer_to_litter(beg:end))
allocate(pcf%m_deadcrootc_xfer_to_litter(beg:end))
allocate(pcf%m_livestemc_to_litter(beg:end))
allocate(pcf%m_deadstemc_to_litter(beg:end))
allocate(pcf%m_livecrootc_to_litter(beg:end))
allocate(pcf%m_deadcrootc_to_litter(beg:end))
allocate(pcf%m_gresp_storage_to_litter(beg:end))
allocate(pcf%m_gresp_xfer_to_litter(beg:end))
allocate(pcf%hrv_leafc_to_litter(beg:end))
allocate(pcf%hrv_leafc_storage_to_litter(beg:end))
allocate(pcf%hrv_leafc_xfer_to_litter(beg:end))
allocate(pcf%hrv_frootc_to_litter(beg:end))
allocate(pcf%hrv_frootc_storage_to_litter(beg:end))
allocate(pcf%hrv_frootc_xfer_to_litter(beg:end))
allocate(pcf%hrv_livestemc_to_litter(beg:end))
allocate(pcf%hrv_livestemc_storage_to_litter(beg:end))
allocate(pcf%hrv_livestemc_xfer_to_litter(beg:end))
allocate(pcf%hrv_deadstemc_to_prod10c(beg:end))
allocate(pcf%hrv_deadstemc_to_prod100c(beg:end))
allocate(pcf%hrv_deadstemc_storage_to_litter(beg:end))
allocate(pcf%hrv_deadstemc_xfer_to_litter(beg:end))
allocate(pcf%hrv_livecrootc_to_litter(beg:end))
allocate(pcf%hrv_livecrootc_storage_to_litter(beg:end))
allocate(pcf%hrv_livecrootc_xfer_to_litter(beg:end))
allocate(pcf%hrv_deadcrootc_to_litter(beg:end))
allocate(pcf%hrv_deadcrootc_storage_to_litter(beg:end))
allocate(pcf%hrv_deadcrootc_xfer_to_litter(beg:end))
allocate(pcf%hrv_gresp_storage_to_litter(beg:end))
allocate(pcf%hrv_gresp_xfer_to_litter(beg:end))
allocate(pcf%hrv_xsmrpool_to_atm(beg:end))
allocate(pcf%m_leafc_to_fire(beg:end))
allocate(pcf%m_frootc_to_fire(beg:end))
allocate(pcf%m_leafc_storage_to_fire(beg:end))
allocate(pcf%m_frootc_storage_to_fire(beg:end))
allocate(pcf%m_livestemc_storage_to_fire(beg:end))
allocate(pcf%m_deadstemc_storage_to_fire(beg:end))
allocate(pcf%m_livecrootc_storage_to_fire(beg:end))
allocate(pcf%m_deadcrootc_storage_to_fire(beg:end))
allocate(pcf%m_leafc_xfer_to_fire(beg:end))
allocate(pcf%m_frootc_xfer_to_fire(beg:end))
allocate(pcf%m_livestemc_xfer_to_fire(beg:end))
allocate(pcf%m_deadstemc_xfer_to_fire(beg:end))
allocate(pcf%m_livecrootc_xfer_to_fire(beg:end))
allocate(pcf%m_deadcrootc_xfer_to_fire(beg:end))
allocate(pcf%m_livestemc_to_fire(beg:end))
allocate(pcf%m_deadstemc_to_fire(beg:end))
allocate(pcf%m_deadstemc_to_litter_fire(beg:end))
allocate(pcf%m_livecrootc_to_fire(beg:end))
allocate(pcf%m_deadcrootc_to_fire(beg:end))
allocate(pcf%m_deadcrootc_to_litter_fire(beg:end))
allocate(pcf%m_gresp_storage_to_fire(beg:end))
allocate(pcf%m_gresp_xfer_to_fire(beg:end))
allocate(pcf%leafc_xfer_to_leafc(beg:end))
allocate(pcf%frootc_xfer_to_frootc(beg:end))
allocate(pcf%livestemc_xfer_to_livestemc(beg:end))
allocate(pcf%deadstemc_xfer_to_deadstemc(beg:end))
allocate(pcf%livecrootc_xfer_to_livecrootc(beg:end))
allocate(pcf%deadcrootc_xfer_to_deadcrootc(beg:end))
allocate(pcf%leafc_to_litter(beg:end))
allocate(pcf%frootc_to_litter(beg:end))
allocate(pcf%leaf_mr(beg:end))
allocate(pcf%froot_mr(beg:end))
allocate(pcf%livestem_mr(beg:end))
allocate(pcf%livecroot_mr(beg:end))
allocate(pcf%leaf_curmr(beg:end))
allocate(pcf%froot_curmr(beg:end))
allocate(pcf%livestem_curmr(beg:end))
allocate(pcf%livecroot_curmr(beg:end))
allocate(pcf%leaf_xsmr(beg:end))
allocate(pcf%froot_xsmr(beg:end))
allocate(pcf%livestem_xsmr(beg:end))
allocate(pcf%livecroot_xsmr(beg:end))
allocate(pcf%psnsun_to_cpool(beg:end))
allocate(pcf%psnshade_to_cpool(beg:end))
allocate(pcf%cpool_to_xsmrpool(beg:end))
allocate(pcf%cpool_to_leafc(beg:end))
allocate(pcf%cpool_to_leafc_storage(beg:end))
allocate(pcf%cpool_to_frootc(beg:end))
allocate(pcf%cpool_to_frootc_storage(beg:end))
allocate(pcf%cpool_to_livestemc(beg:end))
allocate(pcf%cpool_to_livestemc_storage(beg:end))
allocate(pcf%cpool_to_deadstemc(beg:end))
allocate(pcf%cpool_to_deadstemc_storage(beg:end))
allocate(pcf%cpool_to_livecrootc(beg:end))
allocate(pcf%cpool_to_livecrootc_storage(beg:end))
allocate(pcf%cpool_to_deadcrootc(beg:end))
allocate(pcf%cpool_to_deadcrootc_storage(beg:end))
allocate(pcf%cpool_to_gresp_storage(beg:end))
allocate(pcf%cpool_leaf_gr(beg:end))
allocate(pcf%cpool_leaf_storage_gr(beg:end))
allocate(pcf%transfer_leaf_gr(beg:end))
allocate(pcf%cpool_froot_gr(beg:end))
allocate(pcf%cpool_froot_storage_gr(beg:end))
allocate(pcf%transfer_froot_gr(beg:end))
allocate(pcf%cpool_livestem_gr(beg:end))
allocate(pcf%cpool_livestem_storage_gr(beg:end))
allocate(pcf%transfer_livestem_gr(beg:end))
allocate(pcf%cpool_deadstem_gr(beg:end))
allocate(pcf%cpool_deadstem_storage_gr(beg:end))
allocate(pcf%transfer_deadstem_gr(beg:end))
allocate(pcf%cpool_livecroot_gr(beg:end))
allocate(pcf%cpool_livecroot_storage_gr(beg:end))
allocate(pcf%transfer_livecroot_gr(beg:end))
allocate(pcf%cpool_deadcroot_gr(beg:end))
allocate(pcf%cpool_deadcroot_storage_gr(beg:end))
allocate(pcf%transfer_deadcroot_gr(beg:end))
allocate(pcf%leafc_storage_to_xfer(beg:end))
allocate(pcf%frootc_storage_to_xfer(beg:end))
allocate(pcf%livestemc_storage_to_xfer(beg:end))
allocate(pcf%deadstemc_storage_to_xfer(beg:end))
allocate(pcf%livecrootc_storage_to_xfer(beg:end))
allocate(pcf%deadcrootc_storage_to_xfer(beg:end))
allocate(pcf%gresp_storage_to_xfer(beg:end))
allocate(pcf%livestemc_to_deadstemc(beg:end))
allocate(pcf%livecrootc_to_deadcrootc(beg:end))
allocate(pcf%gpp(beg:end))
allocate(pcf%mr(beg:end))
allocate(pcf%current_gr(beg:end))
allocate(pcf%transfer_gr(beg:end))
allocate(pcf%storage_gr(beg:end))
allocate(pcf%gr(beg:end))
allocate(pcf%ar(beg:end))
allocate(pcf%rr(beg:end))
allocate(pcf%npp(beg:end))
allocate(pcf%agnpp(beg:end))
allocate(pcf%bgnpp(beg:end))
allocate(pcf%litfall(beg:end))
allocate(pcf%vegfire(beg:end))
allocate(pcf%wood_harvestc(beg:end))
allocate(pcf%pft_cinputs(beg:end))
allocate(pcf%pft_coutputs(beg:end))
allocate(pcf%pft_fire_closs(beg:end))
#if (defined CROP)
allocate(pcf%xsmrpool_to_atm(beg:end))
allocate(pcf%grainc_xfer_to_grainc(beg:end))
allocate(pcf%livestemc_to_litter(beg:end))
allocate(pcf%grainc_to_food(beg:end))
allocate(pcf%cpool_to_grainc(beg:end))
allocate(pcf%cpool_to_grainc_storage(beg:end))
allocate(pcf%cpool_grain_gr(beg:end))
allocate(pcf%cpool_grain_storage_gr(beg:end))
allocate(pcf%transfer_grain_gr(beg:end))
allocate(pcf%grainc_storage_to_xfer(beg:end))
#endif
#if (defined CLAMP) && (defined CN)
!CLAMP
allocate(pcf%frootc_alloc(beg:end))
allocate(pcf%frootc_loss(beg:end))
allocate(pcf%leafc_alloc(beg:end))
allocate(pcf%leafc_loss(beg:end))
allocate(pcf%woodc_alloc(beg:end))
allocate(pcf%woodc_loss(beg:end))
#endif
pcf%psnsun(beg:end) = nan
pcf%psnsha(beg:end) = nan
pcf%fpsn(beg:end) = nan
pcf%fco2(beg:end) = 0._r8
pcf%m_leafc_to_litter(beg:end) = nan
pcf%m_frootc_to_litter(beg:end) = nan
pcf%m_leafc_storage_to_litter(beg:end) = nan
pcf%m_frootc_storage_to_litter(beg:end) = nan
pcf%m_livestemc_storage_to_litter(beg:end) = nan
pcf%m_deadstemc_storage_to_litter(beg:end) = nan
pcf%m_livecrootc_storage_to_litter(beg:end) = nan
pcf%m_deadcrootc_storage_to_litter(beg:end) = nan
pcf%m_leafc_xfer_to_litter(beg:end) = nan
pcf%m_frootc_xfer_to_litter(beg:end) = nan
pcf%m_livestemc_xfer_to_litter(beg:end) = nan
pcf%m_deadstemc_xfer_to_litter(beg:end) = nan
pcf%m_livecrootc_xfer_to_litter(beg:end) = nan
pcf%m_deadcrootc_xfer_to_litter(beg:end) = nan
pcf%m_livestemc_to_litter(beg:end) = nan
pcf%m_deadstemc_to_litter(beg:end) = nan
pcf%m_livecrootc_to_litter(beg:end) = nan
pcf%m_deadcrootc_to_litter(beg:end) = nan
pcf%m_gresp_storage_to_litter(beg:end) = nan
pcf%m_gresp_xfer_to_litter(beg:end) = nan
pcf%hrv_leafc_to_litter(beg:end) = nan
pcf%hrv_leafc_storage_to_litter(beg:end) = nan
pcf%hrv_leafc_xfer_to_litter(beg:end) = nan
pcf%hrv_frootc_to_litter(beg:end) = nan
pcf%hrv_frootc_storage_to_litter(beg:end) = nan
pcf%hrv_frootc_xfer_to_litter(beg:end) = nan
pcf%hrv_livestemc_to_litter(beg:end) = nan
pcf%hrv_livestemc_storage_to_litter(beg:end) = nan
pcf%hrv_livestemc_xfer_to_litter(beg:end) = nan
pcf%hrv_deadstemc_to_prod10c(beg:end) = nan
pcf%hrv_deadstemc_to_prod100c(beg:end) = nan
pcf%hrv_deadstemc_storage_to_litter(beg:end) = nan
pcf%hrv_deadstemc_xfer_to_litter(beg:end) = nan
pcf%hrv_livecrootc_to_litter(beg:end) = nan
pcf%hrv_livecrootc_storage_to_litter(beg:end) = nan
pcf%hrv_livecrootc_xfer_to_litter(beg:end) = nan
pcf%hrv_deadcrootc_to_litter(beg:end) = nan
pcf%hrv_deadcrootc_storage_to_litter(beg:end) = nan
pcf%hrv_deadcrootc_xfer_to_litter(beg:end) = nan
pcf%hrv_gresp_storage_to_litter(beg:end) = nan
pcf%hrv_gresp_xfer_to_litter(beg:end) = nan
pcf%hrv_xsmrpool_to_atm(beg:end) = nan
pcf%m_leafc_to_fire(beg:end) = nan
pcf%m_frootc_to_fire(beg:end) = nan
pcf%m_leafc_storage_to_fire(beg:end) = nan
pcf%m_frootc_storage_to_fire(beg:end) = nan
pcf%m_livestemc_storage_to_fire(beg:end) = nan
pcf%m_deadstemc_storage_to_fire(beg:end) = nan
pcf%m_livecrootc_storage_to_fire(beg:end) = nan
pcf%m_deadcrootc_storage_to_fire(beg:end) = nan
pcf%m_leafc_xfer_to_fire(beg:end) = nan
pcf%m_frootc_xfer_to_fire(beg:end) = nan
pcf%m_livestemc_xfer_to_fire(beg:end) = nan
pcf%m_deadstemc_xfer_to_fire(beg:end) = nan
pcf%m_livecrootc_xfer_to_fire(beg:end) = nan
pcf%m_deadcrootc_xfer_to_fire(beg:end) = nan
pcf%m_livestemc_to_fire(beg:end) = nan
pcf%m_deadstemc_to_fire(beg:end) = nan
pcf%m_deadstemc_to_litter_fire(beg:end) = nan
pcf%m_livecrootc_to_fire(beg:end) = nan
pcf%m_deadcrootc_to_fire(beg:end) = nan
pcf%m_deadcrootc_to_litter_fire(beg:end) = nan
pcf%m_gresp_storage_to_fire(beg:end) = nan
pcf%m_gresp_xfer_to_fire(beg:end) = nan
pcf%leafc_xfer_to_leafc(beg:end) = nan
pcf%frootc_xfer_to_frootc(beg:end) = nan
pcf%livestemc_xfer_to_livestemc(beg:end) = nan
pcf%deadstemc_xfer_to_deadstemc(beg:end) = nan
pcf%livecrootc_xfer_to_livecrootc(beg:end) = nan
pcf%deadcrootc_xfer_to_deadcrootc(beg:end) = nan
pcf%leafc_to_litter(beg:end) = nan
pcf%frootc_to_litter(beg:end) = nan
pcf%leaf_mr(beg:end) = nan
pcf%froot_mr(beg:end) = nan
pcf%livestem_mr(beg:end) = nan
pcf%livecroot_mr(beg:end) = nan
pcf%leaf_curmr(beg:end) = nan
pcf%froot_curmr(beg:end) = nan
pcf%livestem_curmr(beg:end) = nan
pcf%livecroot_curmr(beg:end) = nan
pcf%leaf_xsmr(beg:end) = nan
pcf%froot_xsmr(beg:end) = nan
pcf%livestem_xsmr(beg:end) = nan
pcf%livecroot_xsmr(beg:end) = nan
pcf%psnsun_to_cpool(beg:end) = nan
pcf%psnshade_to_cpool(beg:end) = nan
pcf%cpool_to_xsmrpool(beg:end) = nan
pcf%cpool_to_leafc(beg:end) = nan
pcf%cpool_to_leafc_storage(beg:end) = nan
pcf%cpool_to_frootc(beg:end) = nan
pcf%cpool_to_frootc_storage(beg:end) = nan
pcf%cpool_to_livestemc(beg:end) = nan
pcf%cpool_to_livestemc_storage(beg:end) = nan
pcf%cpool_to_deadstemc(beg:end) = nan
pcf%cpool_to_deadstemc_storage(beg:end) = nan
pcf%cpool_to_livecrootc(beg:end) = nan
pcf%cpool_to_livecrootc_storage(beg:end) = nan
pcf%cpool_to_deadcrootc(beg:end) = nan
pcf%cpool_to_deadcrootc_storage(beg:end) = nan
pcf%cpool_to_gresp_storage(beg:end) = nan
pcf%cpool_leaf_gr(beg:end) = nan
pcf%cpool_leaf_storage_gr(beg:end) = nan
pcf%transfer_leaf_gr(beg:end) = nan
pcf%cpool_froot_gr(beg:end) = nan
pcf%cpool_froot_storage_gr(beg:end) = nan
pcf%transfer_froot_gr(beg:end) = nan
pcf%cpool_livestem_gr(beg:end) = nan
pcf%cpool_livestem_storage_gr(beg:end) = nan
pcf%transfer_livestem_gr(beg:end) = nan
pcf%cpool_deadstem_gr(beg:end) = nan
pcf%cpool_deadstem_storage_gr(beg:end) = nan
pcf%transfer_deadstem_gr(beg:end) = nan
pcf%cpool_livecroot_gr(beg:end) = nan
pcf%cpool_livecroot_storage_gr(beg:end) = nan
pcf%transfer_livecroot_gr(beg:end) = nan
pcf%cpool_deadcroot_gr(beg:end) = nan
pcf%cpool_deadcroot_storage_gr(beg:end) = nan
pcf%transfer_deadcroot_gr(beg:end) = nan
pcf%leafc_storage_to_xfer(beg:end) = nan
pcf%frootc_storage_to_xfer(beg:end) = nan
pcf%livestemc_storage_to_xfer(beg:end) = nan
pcf%deadstemc_storage_to_xfer(beg:end) = nan
pcf%livecrootc_storage_to_xfer(beg:end) = nan
pcf%deadcrootc_storage_to_xfer(beg:end) = nan
pcf%gresp_storage_to_xfer(beg:end) = nan
pcf%livestemc_to_deadstemc(beg:end) = nan
pcf%livecrootc_to_deadcrootc(beg:end) = nan
pcf%gpp(beg:end) = nan
pcf%mr(beg:end) = nan
pcf%current_gr(beg:end) = nan
pcf%transfer_gr(beg:end) = nan
pcf%storage_gr(beg:end) = nan
pcf%gr(beg:end) = nan
pcf%ar(beg:end) = nan
pcf%rr(beg:end) = nan
pcf%npp(beg:end) = nan
pcf%agnpp(beg:end) = nan
pcf%bgnpp(beg:end) = nan
pcf%litfall(beg:end) = nan
pcf%vegfire(beg:end) = nan
pcf%wood_harvestc(beg:end) = nan
pcf%pft_cinputs(beg:end) = nan
pcf%pft_coutputs(beg:end) = nan
pcf%pft_fire_closs(beg:end) = nan
#if (defined CROP)
pcf%xsmrpool_to_atm(beg:end) = nan
pcf%grainc_xfer_to_grainc(beg:end) = nan
pcf%livestemc_to_litter(beg:end) = nan
pcf%grainc_to_food(beg:end) = nan
pcf%cpool_to_grainc(beg:end) = nan
pcf%cpool_to_grainc_storage(beg:end) = nan
pcf%cpool_grain_gr(beg:end) = nan
pcf%cpool_grain_storage_gr(beg:end) = nan
pcf%transfer_grain_gr(beg:end) = nan
pcf%grainc_storage_to_xfer(beg:end) = nan
#endif
#if (defined CLAMP) && (defined CN)
!CLAMP
pcf%frootc_alloc(beg:end) = nan
pcf%frootc_loss(beg:end) = nan
pcf%leafc_alloc(beg:end) = nan
pcf%leafc_loss(beg:end) = nan
pcf%woodc_alloc(beg:end) = nan
pcf%woodc_loss(beg:end) = nan
#endif
end subroutine init_pft_cflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_nflux_type
!
! !INTERFACE:
subroutine init_pft_nflux_type(beg, end, pnf) 2
!
! !DESCRIPTION:
! Initialize pft nitrogen flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_nflux_type), intent(inout) :: pnf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pnf%m_leafn_to_litter(beg:end))
allocate(pnf%m_frootn_to_litter(beg:end))
allocate(pnf%m_leafn_storage_to_litter(beg:end))
allocate(pnf%m_frootn_storage_to_litter(beg:end))
allocate(pnf%m_livestemn_storage_to_litter(beg:end))
allocate(pnf%m_deadstemn_storage_to_litter(beg:end))
allocate(pnf%m_livecrootn_storage_to_litter(beg:end))
allocate(pnf%m_deadcrootn_storage_to_litter(beg:end))
allocate(pnf%m_leafn_xfer_to_litter(beg:end))
allocate(pnf%m_frootn_xfer_to_litter(beg:end))
allocate(pnf%m_livestemn_xfer_to_litter(beg:end))
allocate(pnf%m_deadstemn_xfer_to_litter(beg:end))
allocate(pnf%m_livecrootn_xfer_to_litter(beg:end))
allocate(pnf%m_deadcrootn_xfer_to_litter(beg:end))
allocate(pnf%m_livestemn_to_litter(beg:end))
allocate(pnf%m_deadstemn_to_litter(beg:end))
allocate(pnf%m_livecrootn_to_litter(beg:end))
allocate(pnf%m_deadcrootn_to_litter(beg:end))
allocate(pnf%m_retransn_to_litter(beg:end))
allocate(pnf%hrv_leafn_to_litter(beg:end))
allocate(pnf%hrv_frootn_to_litter(beg:end))
allocate(pnf%hrv_leafn_storage_to_litter(beg:end))
allocate(pnf%hrv_frootn_storage_to_litter(beg:end))
allocate(pnf%hrv_livestemn_storage_to_litter(beg:end))
allocate(pnf%hrv_deadstemn_storage_to_litter(beg:end))
allocate(pnf%hrv_livecrootn_storage_to_litter(beg:end))
allocate(pnf%hrv_deadcrootn_storage_to_litter(beg:end))
allocate(pnf%hrv_leafn_xfer_to_litter(beg:end))
allocate(pnf%hrv_frootn_xfer_to_litter(beg:end))
allocate(pnf%hrv_livestemn_xfer_to_litter(beg:end))
allocate(pnf%hrv_deadstemn_xfer_to_litter(beg:end))
allocate(pnf%hrv_livecrootn_xfer_to_litter(beg:end))
allocate(pnf%hrv_deadcrootn_xfer_to_litter(beg:end))
allocate(pnf%hrv_livestemn_to_litter(beg:end))
allocate(pnf%hrv_deadstemn_to_prod10n(beg:end))
allocate(pnf%hrv_deadstemn_to_prod100n(beg:end))
allocate(pnf%hrv_livecrootn_to_litter(beg:end))
allocate(pnf%hrv_deadcrootn_to_litter(beg:end))
allocate(pnf%hrv_retransn_to_litter(beg:end))
allocate(pnf%m_leafn_to_fire(beg:end))
allocate(pnf%m_frootn_to_fire(beg:end))
allocate(pnf%m_leafn_storage_to_fire(beg:end))
allocate(pnf%m_frootn_storage_to_fire(beg:end))
allocate(pnf%m_livestemn_storage_to_fire(beg:end))
allocate(pnf%m_deadstemn_storage_to_fire(beg:end))
allocate(pnf%m_livecrootn_storage_to_fire(beg:end))
allocate(pnf%m_deadcrootn_storage_to_fire(beg:end))
allocate(pnf%m_leafn_xfer_to_fire(beg:end))
allocate(pnf%m_frootn_xfer_to_fire(beg:end))
allocate(pnf%m_livestemn_xfer_to_fire(beg:end))
allocate(pnf%m_deadstemn_xfer_to_fire(beg:end))
allocate(pnf%m_livecrootn_xfer_to_fire(beg:end))
allocate(pnf%m_deadcrootn_xfer_to_fire(beg:end))
allocate(pnf%m_livestemn_to_fire(beg:end))
allocate(pnf%m_deadstemn_to_fire(beg:end))
allocate(pnf%m_deadstemn_to_litter_fire(beg:end))
allocate(pnf%m_livecrootn_to_fire(beg:end))
allocate(pnf%m_deadcrootn_to_fire(beg:end))
allocate(pnf%m_deadcrootn_to_litter_fire(beg:end))
allocate(pnf%m_retransn_to_fire(beg:end))
allocate(pnf%leafn_xfer_to_leafn(beg:end))
allocate(pnf%frootn_xfer_to_frootn(beg:end))
allocate(pnf%livestemn_xfer_to_livestemn(beg:end))
allocate(pnf%deadstemn_xfer_to_deadstemn(beg:end))
allocate(pnf%livecrootn_xfer_to_livecrootn(beg:end))
allocate(pnf%deadcrootn_xfer_to_deadcrootn(beg:end))
allocate(pnf%leafn_to_litter(beg:end))
allocate(pnf%leafn_to_retransn(beg:end))
allocate(pnf%frootn_to_litter(beg:end))
allocate(pnf%retransn_to_npool(beg:end))
allocate(pnf%sminn_to_npool(beg:end))
allocate(pnf%npool_to_leafn(beg:end))
allocate(pnf%npool_to_leafn_storage(beg:end))
allocate(pnf%npool_to_frootn(beg:end))
allocate(pnf%npool_to_frootn_storage(beg:end))
allocate(pnf%npool_to_livestemn(beg:end))
allocate(pnf%npool_to_livestemn_storage(beg:end))
allocate(pnf%npool_to_deadstemn(beg:end))
allocate(pnf%npool_to_deadstemn_storage(beg:end))
allocate(pnf%npool_to_livecrootn(beg:end))
allocate(pnf%npool_to_livecrootn_storage(beg:end))
allocate(pnf%npool_to_deadcrootn(beg:end))
allocate(pnf%npool_to_deadcrootn_storage(beg:end))
allocate(pnf%leafn_storage_to_xfer(beg:end))
allocate(pnf%frootn_storage_to_xfer(beg:end))
allocate(pnf%livestemn_storage_to_xfer(beg:end))
allocate(pnf%deadstemn_storage_to_xfer(beg:end))
allocate(pnf%livecrootn_storage_to_xfer(beg:end))
allocate(pnf%deadcrootn_storage_to_xfer(beg:end))
allocate(pnf%livestemn_to_deadstemn(beg:end))
allocate(pnf%livestemn_to_retransn(beg:end))
allocate(pnf%livecrootn_to_deadcrootn(beg:end))
allocate(pnf%livecrootn_to_retransn(beg:end))
allocate(pnf%ndeploy(beg:end))
allocate(pnf%pft_ninputs(beg:end))
allocate(pnf%pft_noutputs(beg:end))
allocate(pnf%wood_harvestn(beg:end))
allocate(pnf%pft_fire_nloss(beg:end))
#if (defined CROP)
allocate(pnf%grainn_xfer_to_grainn(beg:end))
allocate(pnf%livestemn_to_litter(beg:end))
allocate(pnf%grainn_to_food(beg:end))
allocate(pnf%npool_to_grainn(beg:end))
allocate(pnf%npool_to_grainn_storage(beg:end))
allocate(pnf%grainn_storage_to_xfer(beg:end))
#endif
pnf%m_leafn_to_litter(beg:end) = nan
pnf%m_frootn_to_litter(beg:end) = nan
pnf%m_leafn_storage_to_litter(beg:end) = nan
pnf%m_frootn_storage_to_litter(beg:end) = nan
pnf%m_livestemn_storage_to_litter(beg:end) = nan
pnf%m_deadstemn_storage_to_litter(beg:end) = nan
pnf%m_livecrootn_storage_to_litter(beg:end) = nan
pnf%m_deadcrootn_storage_to_litter(beg:end) = nan
pnf%m_leafn_xfer_to_litter(beg:end) = nan
pnf%m_frootn_xfer_to_litter(beg:end) = nan
pnf%m_livestemn_xfer_to_litter(beg:end) = nan
pnf%m_deadstemn_xfer_to_litter(beg:end) = nan
pnf%m_livecrootn_xfer_to_litter(beg:end) = nan
pnf%m_deadcrootn_xfer_to_litter(beg:end) = nan
pnf%m_livestemn_to_litter(beg:end) = nan
pnf%m_deadstemn_to_litter(beg:end) = nan
pnf%m_livecrootn_to_litter(beg:end) = nan
pnf%m_deadcrootn_to_litter(beg:end) = nan
pnf%m_retransn_to_litter(beg:end) = nan
pnf%hrv_leafn_to_litter(beg:end) = nan
pnf%hrv_frootn_to_litter(beg:end) = nan
pnf%hrv_leafn_storage_to_litter(beg:end) = nan
pnf%hrv_frootn_storage_to_litter(beg:end) = nan
pnf%hrv_livestemn_storage_to_litter(beg:end) = nan
pnf%hrv_deadstemn_storage_to_litter(beg:end) = nan
pnf%hrv_livecrootn_storage_to_litter(beg:end) = nan
pnf%hrv_deadcrootn_storage_to_litter(beg:end) = nan
pnf%hrv_leafn_xfer_to_litter(beg:end) = nan
pnf%hrv_frootn_xfer_to_litter(beg:end) = nan
pnf%hrv_livestemn_xfer_to_litter(beg:end) = nan
pnf%hrv_deadstemn_xfer_to_litter(beg:end) = nan
pnf%hrv_livecrootn_xfer_to_litter(beg:end) = nan
pnf%hrv_deadcrootn_xfer_to_litter(beg:end) = nan
pnf%hrv_livestemn_to_litter(beg:end) = nan
pnf%hrv_deadstemn_to_prod10n(beg:end) = nan
pnf%hrv_deadstemn_to_prod100n(beg:end) = nan
pnf%hrv_livecrootn_to_litter(beg:end) = nan
pnf%hrv_deadcrootn_to_litter(beg:end) = nan
pnf%hrv_retransn_to_litter(beg:end) = nan
pnf%m_leafn_to_fire(beg:end) = nan
pnf%m_frootn_to_fire(beg:end) = nan
pnf%m_leafn_storage_to_fire(beg:end) = nan
pnf%m_frootn_storage_to_fire(beg:end) = nan
pnf%m_livestemn_storage_to_fire(beg:end) = nan
pnf%m_deadstemn_storage_to_fire(beg:end) = nan
pnf%m_livecrootn_storage_to_fire(beg:end) = nan
pnf%m_deadcrootn_storage_to_fire(beg:end) = nan
pnf%m_leafn_xfer_to_fire(beg:end) = nan
pnf%m_frootn_xfer_to_fire(beg:end) = nan
pnf%m_livestemn_xfer_to_fire(beg:end) = nan
pnf%m_deadstemn_xfer_to_fire(beg:end) = nan
pnf%m_livecrootn_xfer_to_fire(beg:end) = nan
pnf%m_deadcrootn_xfer_to_fire(beg:end) = nan
pnf%m_livestemn_to_fire(beg:end) = nan
pnf%m_deadstemn_to_fire(beg:end) = nan
pnf%m_deadstemn_to_litter_fire(beg:end) = nan
pnf%m_livecrootn_to_fire(beg:end) = nan
pnf%m_deadcrootn_to_fire(beg:end) = nan
pnf%m_deadcrootn_to_litter_fire(beg:end) = nan
pnf%m_retransn_to_fire(beg:end) = nan
pnf%leafn_xfer_to_leafn(beg:end) = nan
pnf%frootn_xfer_to_frootn(beg:end) = nan
pnf%livestemn_xfer_to_livestemn(beg:end) = nan
pnf%deadstemn_xfer_to_deadstemn(beg:end) = nan
pnf%livecrootn_xfer_to_livecrootn(beg:end) = nan
pnf%deadcrootn_xfer_to_deadcrootn(beg:end) = nan
pnf%leafn_to_litter(beg:end) = nan
pnf%leafn_to_retransn(beg:end) = nan
pnf%frootn_to_litter(beg:end) = nan
pnf%retransn_to_npool(beg:end) = nan
pnf%sminn_to_npool(beg:end) = nan
pnf%npool_to_leafn(beg:end) = nan
pnf%npool_to_leafn_storage(beg:end) = nan
pnf%npool_to_frootn(beg:end) = nan
pnf%npool_to_frootn_storage(beg:end) = nan
pnf%npool_to_livestemn(beg:end) = nan
pnf%npool_to_livestemn_storage(beg:end) = nan
pnf%npool_to_deadstemn(beg:end) = nan
pnf%npool_to_deadstemn_storage(beg:end) = nan
pnf%npool_to_livecrootn(beg:end) = nan
pnf%npool_to_livecrootn_storage(beg:end) = nan
pnf%npool_to_deadcrootn(beg:end) = nan
pnf%npool_to_deadcrootn_storage(beg:end) = nan
pnf%leafn_storage_to_xfer(beg:end) = nan
pnf%frootn_storage_to_xfer(beg:end) = nan
pnf%livestemn_storage_to_xfer(beg:end) = nan
pnf%deadstemn_storage_to_xfer(beg:end) = nan
pnf%livecrootn_storage_to_xfer(beg:end) = nan
pnf%deadcrootn_storage_to_xfer(beg:end) = nan
pnf%livestemn_to_deadstemn(beg:end) = nan
pnf%livestemn_to_retransn(beg:end) = nan
pnf%livecrootn_to_deadcrootn(beg:end) = nan
pnf%livecrootn_to_retransn(beg:end) = nan
pnf%ndeploy(beg:end) = nan
pnf%pft_ninputs(beg:end) = nan
pnf%pft_noutputs(beg:end) = nan
pnf%wood_harvestn(beg:end) = nan
pnf%pft_fire_nloss(beg:end) = nan
#if (defined CROP)
pnf%grainn_xfer_to_grainn(beg:end) = nan
pnf%livestemn_to_litter(beg:end) = nan
pnf%grainn_to_food(beg:end) = nan
pnf%npool_to_grainn(beg:end) = nan
pnf%npool_to_grainn_storage(beg:end) = nan
pnf%grainn_storage_to_xfer(beg:end) = nan
#endif
end subroutine init_pft_nflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_vflux_type
!
! !INTERFACE:
subroutine init_pft_vflux_type(beg, end, pvf) 2,1
!
! !DESCRIPTION:
! Initialize pft VOC flux variables
!
use clm_varcon, only : spval
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_vflux_type), intent(inout) :: pvf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! (heald, 08/06)
!
!EOP
!------------------------------------------------------------------------
allocate(pvf%vocflx_tot(beg:end))
allocate(pvf%vocflx(beg:end,1:nvoc))
allocate(pvf%vocflx_1(beg:end))
allocate(pvf%vocflx_2(beg:end))
allocate(pvf%vocflx_3(beg:end))
allocate(pvf%vocflx_4(beg:end))
allocate(pvf%vocflx_5(beg:end))
allocate(pvf%Eopt_out(beg:end))
allocate(pvf%topt_out(beg:end))
allocate(pvf%alpha_out(beg:end))
allocate(pvf%cp_out(beg:end))
allocate(pvf%para_out(beg:end))
allocate(pvf%par24a_out(beg:end))
allocate(pvf%par240a_out(beg:end))
allocate(pvf%paru_out(beg:end))
allocate(pvf%par24u_out(beg:end))
allocate(pvf%par240u_out(beg:end))
allocate(pvf%gamma_out(beg:end))
allocate(pvf%gammaL_out(beg:end))
allocate(pvf%gammaT_out(beg:end))
allocate(pvf%gammaP_out(beg:end))
allocate(pvf%gammaA_out(beg:end))
allocate(pvf%gammaS_out(beg:end))
pvf%vocflx_tot(beg:end) = spval
pvf%vocflx(beg:end,1:nvoc) = spval
pvf%vocflx_1(beg:end) = spval
pvf%vocflx_2(beg:end) = spval
pvf%vocflx_3(beg:end) = spval
pvf%vocflx_4(beg:end) = spval
pvf%vocflx_5(beg:end) = spval
pvf%Eopt_out(beg:end) = nan
pvf%topt_out(beg:end) = nan
pvf%alpha_out(beg:end) = nan
pvf%cp_out(beg:end) = nan
pvf%para_out(beg:end) = nan
pvf%par24a_out(beg:end) = nan
pvf%par240a_out(beg:end) = nan
pvf%paru_out(beg:end) = nan
pvf%par24u_out(beg:end) = nan
pvf%par240u_out(beg:end) = nan
pvf%gamma_out(beg:end) = nan
pvf%gammaL_out(beg:end) = nan
pvf%gammaT_out(beg:end) = nan
pvf%gammaP_out(beg:end) = nan
pvf%gammaA_out(beg:end) = nan
pvf%gammaS_out(beg:end) = nan
end subroutine init_pft_vflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_dflux_type
!
! !INTERFACE:
subroutine init_pft_dflux_type(beg, end, pdf) 2
!
! !DESCRIPTION:
! Initialize pft dust flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_dflux_type), intent(inout):: pdf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(pdf%flx_mss_vrt_dst(beg:end,1:ndst))
allocate(pdf%flx_mss_vrt_dst_tot(beg:end))
allocate(pdf%vlc_trb(beg:end,1:ndst))
allocate(pdf%vlc_trb_1(beg:end))
allocate(pdf%vlc_trb_2(beg:end))
allocate(pdf%vlc_trb_3(beg:end))
allocate(pdf%vlc_trb_4(beg:end))
pdf%flx_mss_vrt_dst(beg:end,1:ndst) = nan
pdf%flx_mss_vrt_dst_tot(beg:end) = nan
pdf%vlc_trb(beg:end,1:ndst) = nan
pdf%vlc_trb_1(beg:end) = nan
pdf%vlc_trb_2(beg:end) = nan
pdf%vlc_trb_3(beg:end) = nan
pdf%vlc_trb_4(beg:end) = nan
end subroutine init_pft_dflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_pft_depvd_type
!
! !INTERFACE:
subroutine init_pft_depvd_type(beg, end, pdd) 1
! use seq_drydep_mod, only: n_drydep
!
! !DESCRIPTION:
! Initialize pft dep velocity variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (pft_depvd_type), intent(inout):: pdd
integer :: i
!
! !REVISION HISTORY:
! Created by James Sulzman 541-929-6183
!
!EOP
!------------------------------------------------------------------------
! if ( n_drydep > 0 )then
! allocate(pdd%drydepvel(beg:end,n_drydep))
! pdd%drydepvel = nan
! end if
end subroutine init_pft_depvd_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_pstate_type
!
! !INTERFACE:
subroutine init_column_pstate_type(beg, end, cps) 4,1
!
! !DESCRIPTION:
! Initialize column physical state variables
!
! !USES:
use clm_varcon, only : spval
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (column_pstate_type), intent(inout):: cps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(cps%snl(beg:end)) !* cannot be averaged up
allocate(cps%isoicol(beg:end)) !* cannot be averaged up
allocate(cps%bsw(beg:end,nlevgrnd))
allocate(cps%watsat(beg:end,nlevgrnd))
allocate(cps%watfc(beg:end,nlevgrnd))
allocate(cps%watdry(beg:end,nlevgrnd))
allocate(cps%watopt(beg:end,nlevgrnd))
allocate(cps%hksat(beg:end,nlevgrnd))
allocate(cps%sucsat(beg:end,nlevgrnd))
allocate(cps%csol(beg:end,nlevgrnd))
allocate(cps%tkmg(beg:end,nlevgrnd))
allocate(cps%tkdry(beg:end,nlevgrnd))
allocate(cps%tksatu(beg:end,nlevgrnd))
allocate(cps%smpmin(beg:end))
allocate(cps%hkdepth(beg:end))
allocate(cps%wtfact(beg:end))
allocate(cps%fracice(beg:end,nlevgrnd))
allocate(cps%gwc_thr(beg:end))
allocate(cps%mss_frc_cly_vld(beg:end))
allocate(cps%mbl_bsn_fct(beg:end))
allocate(cps%do_capsnow(beg:end))
allocate(cps%snowdp(beg:end))
allocate(cps%frac_sno (beg:end))
allocate(cps%zi(beg:end,-nlevsno+0:nlevgrnd))
allocate(cps%dz(beg:end,-nlevsno+1:nlevgrnd))
allocate(cps%z (beg:end,-nlevsno+1:nlevgrnd))
allocate(cps%frac_iceold(beg:end,-nlevsno+1:nlevgrnd))
allocate(cps%imelt(beg:end,-nlevsno+1:nlevgrnd))
allocate(cps%eff_porosity(beg:end,nlevgrnd))
allocate(cps%emg(beg:end))
allocate(cps%z0mg(beg:end))
allocate(cps%z0hg(beg:end))
allocate(cps%z0qg(beg:end))
allocate(cps%htvp(beg:end))
allocate(cps%beta(beg:end))
allocate(cps%zii(beg:end))
allocate(cps%albgrd(beg:end,numrad))
allocate(cps%albgri(beg:end,numrad))
allocate(cps%rootr_column(beg:end,nlevgrnd))
allocate(cps%rootfr_road_perv(beg:end,nlevgrnd))
allocate(cps%rootr_road_perv(beg:end,nlevgrnd))
allocate(cps%wf(beg:end))
! allocate(cps%xirrig(beg:end))
allocate(cps%max_dayl(beg:end))
allocate(cps%bsw2(beg:end,nlevgrnd))
allocate(cps%psisat(beg:end,nlevgrnd))
allocate(cps%vwcsat(beg:end,nlevgrnd))
allocate(cps%soilpsi(beg:end,nlevgrnd))
allocate(cps%decl(beg:end))
allocate(cps%coszen(beg:end))
allocate(cps%fpi(beg:end))
allocate(cps%fpg(beg:end))
allocate(cps%annsum_counter(beg:end))
allocate(cps%cannsum_npp(beg:end))
allocate(cps%cannavg_t2m(beg:end))
allocate(cps%me(beg:end))
allocate(cps%fire_prob(beg:end))
allocate(cps%mean_fire_prob(beg:end))
allocate(cps%fireseasonl(beg:end))
allocate(cps%farea_burned(beg:end))
allocate(cps%ann_farea_burned(beg:end))
allocate(cps%albsnd_hst(beg:end,numrad))
allocate(cps%albsni_hst(beg:end,numrad))
allocate(cps%albsod(beg:end,numrad))
allocate(cps%albsoi(beg:end,numrad))
allocate(cps%flx_absdv(beg:end,-nlevsno+1:1))
allocate(cps%flx_absdn(beg:end,-nlevsno+1:1))
allocate(cps%flx_absiv(beg:end,-nlevsno+1:1))
allocate(cps%flx_absin(beg:end,-nlevsno+1:1))
allocate(cps%snw_rds(beg:end,-nlevsno+1:0))
allocate(cps%snw_rds_top(beg:end))
allocate(cps%sno_liq_top(beg:end))
allocate(cps%mss_bcpho(beg:end,-nlevsno+1:0))
allocate(cps%mss_bcphi(beg:end,-nlevsno+1:0))
allocate(cps%mss_bctot(beg:end,-nlevsno+1:0))
allocate(cps%mss_bc_col(beg:end))
allocate(cps%mss_bc_top(beg:end))
allocate(cps%mss_ocpho(beg:end,-nlevsno+1:0))
allocate(cps%mss_ocphi(beg:end,-nlevsno+1:0))
allocate(cps%mss_octot(beg:end,-nlevsno+1:0))
allocate(cps%mss_oc_col(beg:end))
allocate(cps%mss_oc_top(beg:end))
allocate(cps%mss_dst1(beg:end,-nlevsno+1:0))
allocate(cps%mss_dst2(beg:end,-nlevsno+1:0))
allocate(cps%mss_dst3(beg:end,-nlevsno+1:0))
allocate(cps%mss_dst4(beg:end,-nlevsno+1:0))
allocate(cps%mss_dsttot(beg:end,-nlevsno+1:0))
allocate(cps%mss_dst_col(beg:end))
allocate(cps%mss_dst_top(beg:end))
allocate(cps%h2osno_top(beg:end))
allocate(cps%mss_cnc_bcphi(beg:end,-nlevsno+1:0))
allocate(cps%mss_cnc_bcpho(beg:end,-nlevsno+1:0))
allocate(cps%mss_cnc_ocphi(beg:end,-nlevsno+1:0))
allocate(cps%mss_cnc_ocpho(beg:end,-nlevsno+1:0))
allocate(cps%mss_cnc_dst1(beg:end,-nlevsno+1:0))
allocate(cps%mss_cnc_dst2(beg:end,-nlevsno+1:0))
allocate(cps%mss_cnc_dst3(beg:end,-nlevsno+1:0))
allocate(cps%mss_cnc_dst4(beg:end,-nlevsno+1:0))
allocate(cps%albgrd_pur(beg:end,numrad))
allocate(cps%albgri_pur(beg:end,numrad))
allocate(cps%albgrd_bc(beg:end,numrad))
allocate(cps%albgri_bc(beg:end,numrad))
allocate(cps%albgrd_oc(beg:end,numrad))
allocate(cps%albgri_oc(beg:end,numrad))
allocate(cps%albgrd_dst(beg:end,numrad))
allocate(cps%albgri_dst(beg:end,numrad))
allocate(cps%dTdz_top(beg:end))
allocate(cps%snot_top(beg:end))
cps%isoicol(beg:end) = bigint
cps%bsw(beg:end,1:nlevgrnd) = nan
cps%watsat(beg:end,1:nlevgrnd) = nan
cps%watfc(beg:end,1:nlevgrnd) = nan
cps%watdry(beg:end,1:nlevgrnd) = nan
cps%watopt(beg:end,1:nlevgrnd) = nan
cps%hksat(beg:end,1:nlevgrnd) = nan
cps%sucsat(beg:end,1:nlevgrnd) = nan
cps%csol(beg:end,1:nlevgrnd) = nan
cps%tkmg(beg:end,1:nlevgrnd) = nan
cps%tkdry(beg:end,1:nlevgrnd) = nan
cps%tksatu(beg:end,1:nlevgrnd) = nan
cps%smpmin(beg:end) = nan
cps%hkdepth(beg:end) = nan
cps%wtfact(beg:end) = nan
cps%fracice(beg:end,1:nlevgrnd) = nan
cps%gwc_thr(beg:end) = nan
cps%mss_frc_cly_vld(beg:end) = nan
cps%mbl_bsn_fct(beg:end) = nan
cps%do_capsnow (beg:end)= .false.
cps%snowdp(beg:end) = nan
cps%frac_sno(beg:end) = nan
cps%zi(beg:end,-nlevsno+0:nlevgrnd) = nan
cps%dz(beg:end,-nlevsno+1:nlevgrnd) = nan
cps%z (beg:end,-nlevsno+1:nlevgrnd) = nan
cps%frac_iceold(beg:end,-nlevsno+1:nlevgrnd) = spval
cps%imelt(beg:end,-nlevsno+1:nlevgrnd) = bigint
cps%eff_porosity(beg:end,1:nlevgrnd) = spval
cps%emg(beg:end) = nan
cps%z0mg(beg:end) = nan
cps%z0hg(beg:end) = nan
cps%z0qg(beg:end) = nan
cps%htvp(beg:end) = nan
cps%beta(beg:end) = nan
cps%zii(beg:end) = nan
cps%albgrd(beg:end,:numrad) = nan
cps%albgri(beg:end,:numrad) = nan
cps%rootr_column(beg:end,1:nlevgrnd) = spval
cps%rootfr_road_perv(beg:end,1:nlevurb) = nan
cps%rootr_road_perv(beg:end,1:nlevurb) = nan
cps%wf(beg:end) = nan
! cps%xirrig(beg:end) = 0._r8
cps%bsw2(beg:end,1:nlevgrnd) = nan
cps%psisat(beg:end,1:nlevgrnd) = nan
cps%vwcsat(beg:end,1:nlevgrnd) = nan
cps%soilpsi(beg:end,1:nlevgrnd) = spval
cps%decl(beg:end) = nan
cps%coszen(beg:end) = nan
cps%fpi(beg:end) = nan
cps%fpg(beg:end) = nan
cps%annsum_counter(beg:end) = nan
cps%cannsum_npp(beg:end) = nan
cps%cannavg_t2m(beg:end) = nan
cps%me(beg:end) = nan
cps%fire_prob(beg:end) = nan
cps%mean_fire_prob(beg:end) = nan
cps%fireseasonl(beg:end) = nan
cps%farea_burned(beg:end) = nan
cps%ann_farea_burned(beg:end) = nan
cps%albsnd_hst(beg:end,:numrad) = spval
cps%albsni_hst(beg:end,:numrad) = spval
cps%albsod(beg:end,:numrad) = nan
cps%albsoi(beg:end,:numrad) = nan
cps%flx_absdv(beg:end,-nlevsno+1:1) = spval
cps%flx_absdn(beg:end,-nlevsno+1:1) = spval
cps%flx_absiv(beg:end,-nlevsno+1:1) = spval
cps%flx_absin(beg:end,-nlevsno+1:1) = spval
cps%snw_rds(beg:end,-nlevsno+1:0) = nan
cps%snw_rds_top(beg:end) = nan
cps%sno_liq_top(beg:end) = nan
cps%mss_bcpho(beg:end,-nlevsno+1:0) = nan
cps%mss_bcphi(beg:end,-nlevsno+1:0) = nan
cps%mss_bctot(beg:end,-nlevsno+1:0) = nan
cps%mss_bc_col(beg:end) = nan
cps%mss_bc_top(beg:end) = nan
cps%mss_ocpho(beg:end,-nlevsno+1:0) = nan
cps%mss_ocphi(beg:end,-nlevsno+1:0) = nan
cps%mss_octot(beg:end,-nlevsno+1:0) = nan
cps%mss_oc_col(beg:end) = nan
cps%mss_oc_top(beg:end) = nan
cps%mss_dst1(beg:end,-nlevsno+1:0) = nan
cps%mss_dst2(beg:end,-nlevsno+1:0) = nan
cps%mss_dst3(beg:end,-nlevsno+1:0) = nan
cps%mss_dst4(beg:end,-nlevsno+1:0) = nan
cps%mss_dsttot(beg:end,-nlevsno+1:0) = nan
cps%mss_dst_col(beg:end) = nan
cps%mss_dst_top(beg:end) = nan
cps%h2osno_top(beg:end) = nan
cps%mss_cnc_bcphi(beg:end,-nlevsno+1:0) = nan
cps%mss_cnc_bcpho(beg:end,-nlevsno+1:0) = nan
cps%mss_cnc_ocphi(beg:end,-nlevsno+1:0) = nan
cps%mss_cnc_ocpho(beg:end,-nlevsno+1:0) = nan
cps%mss_cnc_dst1(beg:end,-nlevsno+1:0) = nan
cps%mss_cnc_dst2(beg:end,-nlevsno+1:0) = nan
cps%mss_cnc_dst3(beg:end,-nlevsno+1:0) = nan
cps%mss_cnc_dst4(beg:end,-nlevsno+1:0) = nan
cps%albgrd_pur(beg:end,:numrad) = nan
cps%albgri_pur(beg:end,:numrad) = nan
cps%albgrd_bc(beg:end,:numrad) = nan
cps%albgri_bc(beg:end,:numrad) = nan
cps%albgrd_oc(beg:end,:numrad) = nan
cps%albgri_oc(beg:end,:numrad) = nan
cps%albgrd_dst(beg:end,:numrad) = nan
cps%albgri_dst(beg:end,:numrad) = nan
cps%dTdz_top(beg:end) = nan
cps%snot_top(beg:end) = nan
end subroutine init_column_pstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_estate_type
!
! !INTERFACE:
subroutine init_column_estate_type(beg, end, ces) 4,1
!
! !DESCRIPTION:
! Initialize column energy state variables
!
! !USES:
use clm_varcon, only : spval
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (column_estate_type), intent(inout):: ces
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(ces%t_grnd(beg:end))
allocate(ces%t_grnd_u(beg:end))
allocate(ces%t_grnd_r(beg:end))
allocate(ces%dt_grnd(beg:end))
allocate(ces%t_soisno(beg:end,-nlevsno+1:nlevgrnd))
allocate(ces%t_soi_10cm(beg:end))
allocate(ces%t_lake(beg:end,1:nlevlak))
allocate(ces%tssbef(beg:end,-nlevsno+1:nlevgrnd))
allocate(ces%thv(beg:end))
allocate(ces%hc_soi(beg:end))
allocate(ces%hc_soisno(beg:end))
ces%t_grnd(beg:end) = nan
ces%t_grnd_u(beg:end) = nan
ces%t_grnd_r(beg:end) = nan
ces%dt_grnd(beg:end) = nan
ces%t_soisno(beg:end,-nlevsno+1:nlevgrnd) = spval
ces%t_soi_10cm(beg:end) = spval
ces%t_lake(beg:end,1:nlevlak) = nan
ces%tssbef(beg:end,-nlevsno+1:nlevgrnd) = nan
ces%thv(beg:end) = nan
ces%hc_soi(beg:end) = nan
ces%hc_soisno(beg:end) = nan
end subroutine init_column_estate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_wstate_type
!
! !INTERFACE:
subroutine init_column_wstate_type(beg, end, cws) 4,1
!
! !DESCRIPTION:
! Initialize column water state variables
!
! !USES:
use clm_varcon, only : spval
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (column_wstate_type), intent(inout):: cws !column water state
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(cws%h2osno(beg:end))
allocate(cws%h2osoi_liq(beg:end,-nlevsno+1:nlevgrnd))
allocate(cws%h2osoi_ice(beg:end,-nlevsno+1:nlevgrnd))
allocate(cws%h2osoi_liqice_10cm(beg:end))
allocate(cws%h2osoi_vol(beg:end,1:nlevgrnd))
allocate(cws%h2osno_old(beg:end))
allocate(cws%qg(beg:end))
allocate(cws%dqgdT(beg:end))
allocate(cws%snowice(beg:end))
allocate(cws%snowliq(beg:end))
allocate(cws%soilalpha(beg:end))
allocate(cws%soilbeta(beg:end))
allocate(cws%soilalpha_u(beg:end))
allocate(cws%zwt(beg:end))
allocate(cws%fcov(beg:end))
allocate(cws%fsat(beg:end))
allocate(cws%wa(beg:end))
allocate(cws%wt(beg:end))
allocate(cws%qcharge(beg:end))
allocate(cws%smp_l(beg:end,1:nlevgrnd))
allocate(cws%hk_l(beg:end,1:nlevgrnd))
cws%h2osno(beg:end) = nan
cws%h2osoi_liq(beg:end,-nlevsno+1:nlevgrnd)= spval
cws%h2osoi_ice(beg:end,-nlevsno+1:nlevgrnd) = spval
cws%h2osoi_liqice_10cm(beg:end) = spval
cws%h2osoi_vol(beg:end,1:nlevgrnd) = spval
cws%h2osno_old(beg:end) = nan
cws%qg(beg:end) = nan
cws%dqgdT(beg:end) = nan
cws%snowice(beg:end) = nan
cws%snowliq(beg:end) = nan
cws%soilalpha(beg:end) = nan
cws%soilbeta(beg:end) = nan
cws%soilalpha_u(beg:end) = nan
cws%zwt(beg:end) = nan
cws%fcov(beg:end) = nan
cws%fsat(beg:end) = nan
cws%wa(beg:end) = nan
cws%wt(beg:end) = nan
cws%qcharge(beg:end) = nan
cws%smp_l(beg:end,1:nlevgrnd) = spval
cws%hk_l(beg:end,1:nlevgrnd) = spval
end subroutine init_column_wstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_cstate_type
!
! !INTERFACE:
subroutine init_column_cstate_type(beg, end, ccs) 5
!
! !DESCRIPTION:
! Initialize column carbon state variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (column_cstate_type), intent(inout):: ccs
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(ccs%soilc(beg:end))
allocate(ccs%cwdc(beg:end))
allocate(ccs%litr1c(beg:end))
allocate(ccs%litr2c(beg:end))
allocate(ccs%litr3c(beg:end))
allocate(ccs%soil1c(beg:end))
allocate(ccs%soil2c(beg:end))
allocate(ccs%soil3c(beg:end))
allocate(ccs%soil4c(beg:end))
allocate(ccs%seedc(beg:end))
allocate(ccs%col_ctrunc(beg:end))
allocate(ccs%prod10c(beg:end))
allocate(ccs%prod100c(beg:end))
allocate(ccs%totprodc(beg:end))
allocate(ccs%totlitc(beg:end))
allocate(ccs%totsomc(beg:end))
allocate(ccs%totecosysc(beg:end))
allocate(ccs%totcolc(beg:end))
ccs%soilc(beg:end) = nan
ccs%cwdc(beg:end) = nan
ccs%litr1c(beg:end) = nan
ccs%litr2c(beg:end) = nan
ccs%litr3c(beg:end) = nan
ccs%soil1c(beg:end) = nan
ccs%soil2c(beg:end) = nan
ccs%soil3c(beg:end) = nan
ccs%soil4c(beg:end) = nan
ccs%seedc(beg:end) = nan
ccs%col_ctrunc(beg:end) = nan
ccs%prod10c(beg:end) = nan
ccs%prod100c(beg:end) = nan
ccs%totprodc(beg:end) = nan
ccs%totlitc(beg:end) = nan
ccs%totsomc(beg:end) = nan
ccs%totecosysc(beg:end) = nan
ccs%totcolc(beg:end) = nan
end subroutine init_column_cstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_nstate_type
!
! !INTERFACE:
subroutine init_column_nstate_type(beg, end, cns) 4
!
! !DESCRIPTION:
! Initialize column nitrogen state variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (column_nstate_type), intent(inout):: cns
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
allocate(cns%cwdn(beg:end))
allocate(cns%litr1n(beg:end))
allocate(cns%litr2n(beg:end))
allocate(cns%litr3n(beg:end))
allocate(cns%soil1n(beg:end))
allocate(cns%soil2n(beg:end))
allocate(cns%soil3n(beg:end))
allocate(cns%soil4n(beg:end))
allocate(cns%sminn(beg:end))
allocate(cns%col_ntrunc(beg:end))
allocate(cns%seedn(beg:end))
allocate(cns%prod10n(beg:end))
allocate(cns%prod100n(beg:end))
allocate(cns%totprodn(beg:end))
allocate(cns%totlitn(beg:end))
allocate(cns%totsomn(beg:end))
allocate(cns%totecosysn(beg:end))
allocate(cns%totcoln(beg:end))
cns%cwdn(beg:end) = nan
cns%litr1n(beg:end) = nan
cns%litr2n(beg:end) = nan
cns%litr3n(beg:end) = nan
cns%soil1n(beg:end) = nan
cns%soil2n(beg:end) = nan
cns%soil3n(beg:end) = nan
cns%soil4n(beg:end) = nan
cns%sminn(beg:end) = nan
cns%col_ntrunc(beg:end) = nan
cns%seedn(beg:end) = nan
cns%prod10n(beg:end) = nan
cns%prod100n(beg:end) = nan
cns%totprodn(beg:end) = nan
cns%totlitn(beg:end) = nan
cns%totsomn(beg:end) = nan
cns%totecosysn(beg:end) = nan
cns%totcoln(beg:end) = nan
end subroutine init_column_nstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_eflux_type
!
! !INTERFACE:
subroutine init_column_eflux_type(beg, end, cef) 4
!
! !DESCRIPTION:
! Initialize column energy flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (column_eflux_type), intent(inout):: cef
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(cef%eflx_snomelt(beg:end))
allocate(cef%eflx_snomelt_u(beg:end))
allocate(cef%eflx_snomelt_r(beg:end))
allocate(cef%eflx_impsoil(beg:end))
allocate(cef%eflx_fgr12(beg:end))
allocate(cef%eflx_building_heat(beg:end))
allocate(cef%eflx_urban_ac(beg:end))
allocate(cef%eflx_urban_heat(beg:end))
cef%eflx_snomelt(beg:end) = nan
cef%eflx_snomelt_u(beg:end) = nan
cef%eflx_snomelt_r(beg:end) = nan
cef%eflx_impsoil(beg:end) = nan
cef%eflx_fgr12(beg:end) = nan
cef%eflx_building_heat(beg:end) = nan
cef%eflx_urban_ac(beg:end) = nan
cef%eflx_urban_heat(beg:end) = nan
end subroutine init_column_eflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_wflux_type
!
! !INTERFACE:
subroutine init_column_wflux_type(beg, end, cwf) 4,1
!
! !DESCRIPTION:
! Initialize column water flux variables
!
! !USES:
use clm_varcon, only : spval
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (column_wflux_type), intent(inout):: cwf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(cwf%qflx_infl(beg:end))
allocate(cwf%qflx_surf(beg:end))
allocate(cwf%qflx_drain(beg:end))
allocate(cwf%qflx_top_soil(beg:end))
allocate(cwf%qflx_snomelt(beg:end))
allocate(cwf%qflx_qrgwl(beg:end))
allocate(cwf%qflx_runoff(beg:end))
allocate(cwf%qflx_runoff_u(beg:end))
allocate(cwf%qflx_runoff_r(beg:end))
allocate(cwf%qmelt(beg:end))
allocate(cwf%h2ocan_loss(beg:end))
allocate(cwf%qflx_rsub_sat(beg:end))
allocate(cwf%flx_bc_dep_dry(beg:end))
allocate(cwf%flx_bc_dep_wet(beg:end))
allocate(cwf%flx_bc_dep_pho(beg:end))
allocate(cwf%flx_bc_dep_phi(beg:end))
allocate(cwf%flx_bc_dep(beg:end))
allocate(cwf%flx_oc_dep_dry(beg:end))
allocate(cwf%flx_oc_dep_wet(beg:end))
allocate(cwf%flx_oc_dep_pho(beg:end))
allocate(cwf%flx_oc_dep_phi(beg:end))
allocate(cwf%flx_oc_dep(beg:end))
allocate(cwf%flx_dst_dep_dry1(beg:end))
allocate(cwf%flx_dst_dep_wet1(beg:end))
allocate(cwf%flx_dst_dep_dry2(beg:end))
allocate(cwf%flx_dst_dep_wet2(beg:end))
allocate(cwf%flx_dst_dep_dry3(beg:end))
allocate(cwf%flx_dst_dep_wet3(beg:end))
allocate(cwf%flx_dst_dep_dry4(beg:end))
allocate(cwf%flx_dst_dep_wet4(beg:end))
allocate(cwf%flx_dst_dep(beg:end))
allocate(cwf%qflx_snofrz_lyr(beg:end,-nlevsno+1:0))
cwf%qflx_infl(beg:end) = nan
cwf%qflx_surf(beg:end) = nan
cwf%qflx_drain(beg:end) = nan
cwf%qflx_top_soil(beg:end) = nan
cwf%qflx_snomelt(beg:end) = nan
cwf%qflx_qrgwl(beg:end) = nan
cwf%qflx_runoff(beg:end) = nan
cwf%qflx_runoff_u(beg:end) = nan
cwf%qflx_runoff_r(beg:end) = nan
cwf%qmelt(beg:end) = nan
cwf%h2ocan_loss(beg:end) = nan
cwf%qflx_rsub_sat(beg:end) = nan
cwf%flx_bc_dep_dry(beg:end) = nan
cwf%flx_bc_dep_wet(beg:end) = nan
cwf%flx_bc_dep_pho(beg:end) = nan
cwf%flx_bc_dep_phi(beg:end) = nan
cwf%flx_bc_dep(beg:end) = nan
cwf%flx_oc_dep_dry(beg:end) = nan
cwf%flx_oc_dep_wet(beg:end) = nan
cwf%flx_oc_dep_pho(beg:end) = nan
cwf%flx_oc_dep_phi(beg:end) = nan
cwf%flx_oc_dep(beg:end) = nan
cwf%flx_dst_dep_dry1(beg:end) = nan
cwf%flx_dst_dep_wet1(beg:end) = nan
cwf%flx_dst_dep_dry2(beg:end) = nan
cwf%flx_dst_dep_wet2(beg:end) = nan
cwf%flx_dst_dep_dry3(beg:end) = nan
cwf%flx_dst_dep_wet3(beg:end) = nan
cwf%flx_dst_dep_dry4(beg:end) = nan
cwf%flx_dst_dep_wet4(beg:end) = nan
cwf%flx_dst_dep(beg:end) = nan
cwf%qflx_snofrz_lyr(beg:end,-nlevsno+1:0) = spval
end subroutine init_column_wflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_cflux_type
!
! !INTERFACE:
subroutine init_column_cflux_type(beg, end, ccf) 2
!
! !DESCRIPTION:
! Initialize column carbon flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (column_cflux_type), intent(inout):: ccf
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
allocate(ccf%m_leafc_to_litr1c(beg:end))
allocate(ccf%m_leafc_to_litr2c(beg:end))
allocate(ccf%m_leafc_to_litr3c(beg:end))
allocate(ccf%m_frootc_to_litr1c(beg:end))
allocate(ccf%m_frootc_to_litr2c(beg:end))
allocate(ccf%m_frootc_to_litr3c(beg:end))
allocate(ccf%m_leafc_storage_to_litr1c(beg:end))
allocate(ccf%m_frootc_storage_to_litr1c(beg:end))
allocate(ccf%m_livestemc_storage_to_litr1c(beg:end))
allocate(ccf%m_deadstemc_storage_to_litr1c(beg:end))
allocate(ccf%m_livecrootc_storage_to_litr1c(beg:end))
allocate(ccf%m_deadcrootc_storage_to_litr1c(beg:end))
allocate(ccf%m_leafc_xfer_to_litr1c(beg:end))
allocate(ccf%m_frootc_xfer_to_litr1c(beg:end))
allocate(ccf%m_livestemc_xfer_to_litr1c(beg:end))
allocate(ccf%m_deadstemc_xfer_to_litr1c(beg:end))
allocate(ccf%m_livecrootc_xfer_to_litr1c(beg:end))
allocate(ccf%m_deadcrootc_xfer_to_litr1c(beg:end))
allocate(ccf%m_livestemc_to_cwdc(beg:end))
allocate(ccf%m_deadstemc_to_cwdc(beg:end))
allocate(ccf%m_livecrootc_to_cwdc(beg:end))
allocate(ccf%m_deadcrootc_to_cwdc(beg:end))
allocate(ccf%m_gresp_storage_to_litr1c(beg:end))
allocate(ccf%m_gresp_xfer_to_litr1c(beg:end))
allocate(ccf%m_deadstemc_to_cwdc_fire(beg:end))
allocate(ccf%m_deadcrootc_to_cwdc_fire(beg:end))
allocate(ccf%hrv_leafc_to_litr1c(beg:end))
allocate(ccf%hrv_leafc_to_litr2c(beg:end))
allocate(ccf%hrv_leafc_to_litr3c(beg:end))
allocate(ccf%hrv_frootc_to_litr1c(beg:end))
allocate(ccf%hrv_frootc_to_litr2c(beg:end))
allocate(ccf%hrv_frootc_to_litr3c(beg:end))
allocate(ccf%hrv_livestemc_to_cwdc(beg:end))
allocate(ccf%hrv_deadstemc_to_prod10c(beg:end))
allocate(ccf%hrv_deadstemc_to_prod100c(beg:end))
allocate(ccf%hrv_livecrootc_to_cwdc(beg:end))
allocate(ccf%hrv_deadcrootc_to_cwdc(beg:end))
allocate(ccf%hrv_leafc_storage_to_litr1c(beg:end))
allocate(ccf%hrv_frootc_storage_to_litr1c(beg:end))
allocate(ccf%hrv_livestemc_storage_to_litr1c(beg:end))
allocate(ccf%hrv_deadstemc_storage_to_litr1c(beg:end))
allocate(ccf%hrv_livecrootc_storage_to_litr1c(beg:end))
allocate(ccf%hrv_deadcrootc_storage_to_litr1c(beg:end))
allocate(ccf%hrv_gresp_storage_to_litr1c(beg:end))
allocate(ccf%hrv_leafc_xfer_to_litr1c(beg:end))
allocate(ccf%hrv_frootc_xfer_to_litr1c(beg:end))
allocate(ccf%hrv_livestemc_xfer_to_litr1c(beg:end))
allocate(ccf%hrv_deadstemc_xfer_to_litr1c(beg:end))
allocate(ccf%hrv_livecrootc_xfer_to_litr1c(beg:end))
allocate(ccf%hrv_deadcrootc_xfer_to_litr1c(beg:end))
allocate(ccf%hrv_gresp_xfer_to_litr1c(beg:end))
allocate(ccf%m_litr1c_to_fire(beg:end))
allocate(ccf%m_litr2c_to_fire(beg:end))
allocate(ccf%m_litr3c_to_fire(beg:end))
allocate(ccf%m_cwdc_to_fire(beg:end))
#if (defined CROP)
allocate(ccf%grainc_to_litr1c(beg:end))
allocate(ccf%grainc_to_litr2c(beg:end))
allocate(ccf%grainc_to_litr3c(beg:end))
allocate(ccf%livestemc_to_litr1c(beg:end))
allocate(ccf%livestemc_to_litr2c(beg:end))
allocate(ccf%livestemc_to_litr3c(beg:end))
#endif
allocate(ccf%leafc_to_litr1c(beg:end))
allocate(ccf%leafc_to_litr2c(beg:end))
allocate(ccf%leafc_to_litr3c(beg:end))
allocate(ccf%frootc_to_litr1c(beg:end))
allocate(ccf%frootc_to_litr2c(beg:end))
allocate(ccf%frootc_to_litr3c(beg:end))
allocate(ccf%cwdc_to_litr2c(beg:end))
allocate(ccf%cwdc_to_litr3c(beg:end))
allocate(ccf%litr1_hr(beg:end))
allocate(ccf%litr1c_to_soil1c(beg:end))
allocate(ccf%litr2_hr(beg:end))
allocate(ccf%litr2c_to_soil2c(beg:end))
allocate(ccf%litr3_hr(beg:end))
allocate(ccf%litr3c_to_soil3c(beg:end))
allocate(ccf%soil1_hr(beg:end))
allocate(ccf%soil1c_to_soil2c(beg:end))
allocate(ccf%soil2_hr(beg:end))
allocate(ccf%soil2c_to_soil3c(beg:end))
allocate(ccf%soil3_hr(beg:end))
allocate(ccf%soil3c_to_soil4c(beg:end))
allocate(ccf%soil4_hr(beg:end))
#ifdef CN
allocate(ccf%dwt_seedc_to_leaf(beg:end))
allocate(ccf%dwt_seedc_to_deadstem(beg:end))
allocate(ccf%dwt_conv_cflux(beg:end))
allocate(ccf%dwt_prod10c_gain(beg:end))
allocate(ccf%dwt_prod100c_gain(beg:end))
allocate(ccf%dwt_frootc_to_litr1c(beg:end))
allocate(ccf%dwt_frootc_to_litr2c(beg:end))
allocate(ccf%dwt_frootc_to_litr3c(beg:end))
allocate(ccf%dwt_livecrootc_to_cwdc(beg:end))
allocate(ccf%dwt_deadcrootc_to_cwdc(beg:end))
allocate(ccf%dwt_closs(beg:end))
allocate(ccf%landuseflux(beg:end))
allocate(ccf%landuptake(beg:end))
allocate(ccf%prod10c_loss(beg:end))
allocate(ccf%prod100c_loss(beg:end))
allocate(ccf%product_closs(beg:end))
#endif
allocate(ccf%lithr(beg:end))
allocate(ccf%somhr(beg:end))
allocate(ccf%hr(beg:end))
allocate(ccf%sr(beg:end))
allocate(ccf%er(beg:end))
allocate(ccf%litfire(beg:end))
allocate(ccf%somfire(beg:end))
allocate(ccf%totfire(beg:end))
allocate(ccf%nep(beg:end))
allocate(ccf%nbp(beg:end))
allocate(ccf%nee(beg:end))
allocate(ccf%col_cinputs(beg:end))
allocate(ccf%col_coutputs(beg:end))
allocate(ccf%col_fire_closs(beg:end))
#if (defined CLAMP) && (defined CN)
!CLAMP
allocate(ccf%cwdc_hr(beg:end))
allocate(ccf%cwdc_loss(beg:end))
allocate(ccf%litterc_loss(beg:end))
#endif
ccf%m_leafc_to_litr1c(beg:end) = nan
ccf%m_leafc_to_litr2c(beg:end) = nan
ccf%m_leafc_to_litr3c(beg:end) = nan
ccf%m_frootc_to_litr1c(beg:end) = nan
ccf%m_frootc_to_litr2c(beg:end) = nan
ccf%m_frootc_to_litr3c(beg:end) = nan
ccf%m_leafc_storage_to_litr1c(beg:end) = nan
ccf%m_frootc_storage_to_litr1c(beg:end) = nan
ccf%m_livestemc_storage_to_litr1c(beg:end) = nan
ccf%m_deadstemc_storage_to_litr1c(beg:end) = nan
ccf%m_livecrootc_storage_to_litr1c(beg:end) = nan
ccf%m_deadcrootc_storage_to_litr1c(beg:end) = nan
ccf%m_leafc_xfer_to_litr1c(beg:end) = nan
ccf%m_frootc_xfer_to_litr1c(beg:end) = nan
ccf%m_livestemc_xfer_to_litr1c(beg:end) = nan
ccf%m_deadstemc_xfer_to_litr1c(beg:end) = nan
ccf%m_livecrootc_xfer_to_litr1c(beg:end) = nan
ccf%m_deadcrootc_xfer_to_litr1c(beg:end) = nan
ccf%m_livestemc_to_cwdc(beg:end) = nan
ccf%m_deadstemc_to_cwdc(beg:end) = nan
ccf%m_livecrootc_to_cwdc(beg:end) = nan
ccf%m_deadcrootc_to_cwdc(beg:end) = nan
ccf%m_gresp_storage_to_litr1c(beg:end) = nan
ccf%m_gresp_xfer_to_litr1c(beg:end) = nan
ccf%m_deadstemc_to_cwdc_fire(beg:end) = nan
ccf%m_deadcrootc_to_cwdc_fire(beg:end) = nan
ccf%hrv_leafc_to_litr1c(beg:end) = nan
ccf%hrv_leafc_to_litr2c(beg:end) = nan
ccf%hrv_leafc_to_litr3c(beg:end) = nan
ccf%hrv_frootc_to_litr1c(beg:end) = nan
ccf%hrv_frootc_to_litr2c(beg:end) = nan
ccf%hrv_frootc_to_litr3c(beg:end) = nan
ccf%hrv_livestemc_to_cwdc(beg:end) = nan
ccf%hrv_deadstemc_to_prod10c(beg:end) = nan
ccf%hrv_deadstemc_to_prod100c(beg:end) = nan
ccf%hrv_livecrootc_to_cwdc(beg:end) = nan
ccf%hrv_deadcrootc_to_cwdc(beg:end) = nan
ccf%hrv_leafc_storage_to_litr1c(beg:end) = nan
ccf%hrv_frootc_storage_to_litr1c(beg:end) = nan
ccf%hrv_livestemc_storage_to_litr1c(beg:end) = nan
ccf%hrv_deadstemc_storage_to_litr1c(beg:end) = nan
ccf%hrv_livecrootc_storage_to_litr1c(beg:end) = nan
ccf%hrv_deadcrootc_storage_to_litr1c(beg:end) = nan
#if (defined CROP)
ccf%grainc_to_litr1c(beg:end) = nan
ccf%grainc_to_litr2c(beg:end) = nan
ccf%grainc_to_litr3c(beg:end) = nan
ccf%livestemc_to_litr1c(beg:end) = nan
ccf%livestemc_to_litr2c(beg:end) = nan
ccf%livestemc_to_litr3c(beg:end) = nan
#endif
ccf%hrv_gresp_storage_to_litr1c(beg:end) = nan
ccf%hrv_leafc_xfer_to_litr1c(beg:end) = nan
ccf%hrv_frootc_xfer_to_litr1c(beg:end) = nan
ccf%hrv_livestemc_xfer_to_litr1c(beg:end) = nan
ccf%hrv_deadstemc_xfer_to_litr1c(beg:end) = nan
ccf%hrv_livecrootc_xfer_to_litr1c(beg:end) = nan
ccf%hrv_deadcrootc_xfer_to_litr1c(beg:end) = nan
ccf%hrv_gresp_xfer_to_litr1c(beg:end) = nan
ccf%m_litr1c_to_fire(beg:end) = nan
ccf%m_litr2c_to_fire(beg:end) = nan
ccf%m_litr3c_to_fire(beg:end) = nan
ccf%m_cwdc_to_fire(beg:end) = nan
ccf%leafc_to_litr1c(beg:end) = nan
ccf%leafc_to_litr2c(beg:end) = nan
ccf%leafc_to_litr3c(beg:end) = nan
ccf%frootc_to_litr1c(beg:end) = nan
ccf%frootc_to_litr2c(beg:end) = nan
ccf%frootc_to_litr3c(beg:end) = nan
ccf%cwdc_to_litr2c(beg:end) = nan
ccf%cwdc_to_litr3c(beg:end) = nan
ccf%litr1_hr(beg:end) = nan
ccf%litr1c_to_soil1c(beg:end) = nan
ccf%litr2_hr(beg:end) = nan
ccf%litr2c_to_soil2c(beg:end) = nan
ccf%litr3_hr(beg:end) = nan
ccf%litr3c_to_soil3c(beg:end) = nan
ccf%soil1_hr(beg:end) = nan
ccf%soil1c_to_soil2c(beg:end) = nan
ccf%soil2_hr(beg:end) = nan
ccf%soil2c_to_soil3c(beg:end) = nan
ccf%soil3_hr(beg:end) = nan
ccf%soil3c_to_soil4c(beg:end) = nan
ccf%soil4_hr(beg:end) = nan
#if (defined CN)
ccf%dwt_seedc_to_leaf(beg:end) = nan
ccf%dwt_seedc_to_deadstem(beg:end) = nan
ccf%dwt_conv_cflux(beg:end) = nan
ccf%dwt_prod10c_gain(beg:end) = nan
ccf%dwt_prod100c_gain(beg:end) = nan
ccf%dwt_frootc_to_litr1c(beg:end) = nan
ccf%dwt_frootc_to_litr2c(beg:end) = nan
ccf%dwt_frootc_to_litr3c(beg:end) = nan
ccf%dwt_livecrootc_to_cwdc(beg:end) = nan
ccf%dwt_deadcrootc_to_cwdc(beg:end) = nan
ccf%dwt_closs(beg:end) = nan
ccf%landuseflux(beg:end) = nan
ccf%landuptake(beg:end) = nan
ccf%prod10c_loss(beg:end) = nan
ccf%prod100c_loss(beg:end) = nan
ccf%product_closs(beg:end) = nan
#endif
ccf%lithr(beg:end) = nan
ccf%somhr(beg:end) = nan
ccf%hr(beg:end) = nan
ccf%sr(beg:end) = nan
ccf%er(beg:end) = nan
ccf%litfire(beg:end) = nan
ccf%somfire(beg:end) = nan
ccf%totfire(beg:end) = nan
ccf%nep(beg:end) = nan
ccf%nbp(beg:end) = nan
ccf%nee(beg:end) = nan
ccf%col_cinputs(beg:end) = nan
ccf%col_coutputs(beg:end) = nan
ccf%col_fire_closs(beg:end) = nan
#if (defined CLAMP) && (defined CN)
!CLAMP
ccf%cwdc_hr(beg:end) = nan
ccf%cwdc_loss(beg:end) = nan
ccf%litterc_loss(beg:end) = nan
#endif
end subroutine init_column_cflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_column_nflux_type
!
! !INTERFACE:
subroutine init_column_nflux_type(beg, end, cnf) 1
!
! !DESCRIPTION:
! Initialize column nitrogen flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (column_nflux_type), intent(inout):: cnf
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
allocate(cnf%ndep_to_sminn(beg:end))
allocate(cnf%nfix_to_sminn(beg:end))
allocate(cnf%m_leafn_to_litr1n(beg:end))
allocate(cnf%m_leafn_to_litr2n(beg:end))
allocate(cnf%m_leafn_to_litr3n(beg:end))
allocate(cnf%m_frootn_to_litr1n(beg:end))
allocate(cnf%m_frootn_to_litr2n(beg:end))
allocate(cnf%m_frootn_to_litr3n(beg:end))
allocate(cnf%m_leafn_storage_to_litr1n(beg:end))
allocate(cnf%m_frootn_storage_to_litr1n(beg:end))
allocate(cnf%m_livestemn_storage_to_litr1n(beg:end))
allocate(cnf%m_deadstemn_storage_to_litr1n(beg:end))
allocate(cnf%m_livecrootn_storage_to_litr1n(beg:end))
allocate(cnf%m_deadcrootn_storage_to_litr1n(beg:end))
allocate(cnf%m_leafn_xfer_to_litr1n(beg:end))
allocate(cnf%m_frootn_xfer_to_litr1n(beg:end))
allocate(cnf%m_livestemn_xfer_to_litr1n(beg:end))
allocate(cnf%m_deadstemn_xfer_to_litr1n(beg:end))
allocate(cnf%m_livecrootn_xfer_to_litr1n(beg:end))
allocate(cnf%m_deadcrootn_xfer_to_litr1n(beg:end))
allocate(cnf%m_livestemn_to_cwdn(beg:end))
allocate(cnf%m_deadstemn_to_cwdn(beg:end))
allocate(cnf%m_livecrootn_to_cwdn(beg:end))
allocate(cnf%m_deadcrootn_to_cwdn(beg:end))
allocate(cnf%m_retransn_to_litr1n(beg:end))
allocate(cnf%hrv_leafn_to_litr1n(beg:end))
allocate(cnf%hrv_leafn_to_litr2n(beg:end))
allocate(cnf%hrv_leafn_to_litr3n(beg:end))
allocate(cnf%hrv_frootn_to_litr1n(beg:end))
allocate(cnf%hrv_frootn_to_litr2n(beg:end))
allocate(cnf%hrv_frootn_to_litr3n(beg:end))
allocate(cnf%hrv_livestemn_to_cwdn(beg:end))
allocate(cnf%hrv_deadstemn_to_prod10n(beg:end))
allocate(cnf%hrv_deadstemn_to_prod100n(beg:end))
allocate(cnf%hrv_livecrootn_to_cwdn(beg:end))
allocate(cnf%hrv_deadcrootn_to_cwdn(beg:end))
allocate(cnf%hrv_retransn_to_litr1n(beg:end))
allocate(cnf%hrv_leafn_storage_to_litr1n(beg:end))
allocate(cnf%hrv_frootn_storage_to_litr1n(beg:end))
allocate(cnf%hrv_livestemn_storage_to_litr1n(beg:end))
allocate(cnf%hrv_deadstemn_storage_to_litr1n(beg:end))
allocate(cnf%hrv_livecrootn_storage_to_litr1n(beg:end))
allocate(cnf%hrv_deadcrootn_storage_to_litr1n(beg:end))
allocate(cnf%hrv_leafn_xfer_to_litr1n(beg:end))
allocate(cnf%hrv_frootn_xfer_to_litr1n(beg:end))
allocate(cnf%hrv_livestemn_xfer_to_litr1n(beg:end))
allocate(cnf%hrv_deadstemn_xfer_to_litr1n(beg:end))
allocate(cnf%hrv_livecrootn_xfer_to_litr1n(beg:end))
allocate(cnf%hrv_deadcrootn_xfer_to_litr1n(beg:end))
allocate(cnf%m_deadstemn_to_cwdn_fire(beg:end))
allocate(cnf%m_deadcrootn_to_cwdn_fire(beg:end))
allocate(cnf%m_litr1n_to_fire(beg:end))
allocate(cnf%m_litr2n_to_fire(beg:end))
allocate(cnf%m_litr3n_to_fire(beg:end))
allocate(cnf%m_cwdn_to_fire(beg:end))
#if (defined CROP)
allocate(cnf%grainn_to_litr1n(beg:end))
allocate(cnf%grainn_to_litr2n(beg:end))
allocate(cnf%grainn_to_litr3n(beg:end))
allocate(cnf%livestemn_to_litr1n(beg:end))
allocate(cnf%livestemn_to_litr2n(beg:end))
allocate(cnf%livestemn_to_litr3n(beg:end))
#endif
allocate(cnf%leafn_to_litr1n(beg:end))
allocate(cnf%leafn_to_litr2n(beg:end))
allocate(cnf%leafn_to_litr3n(beg:end))
allocate(cnf%frootn_to_litr1n(beg:end))
allocate(cnf%frootn_to_litr2n(beg:end))
allocate(cnf%frootn_to_litr3n(beg:end))
allocate(cnf%cwdn_to_litr2n(beg:end))
allocate(cnf%cwdn_to_litr3n(beg:end))
allocate(cnf%litr1n_to_soil1n(beg:end))
allocate(cnf%sminn_to_soil1n_l1(beg:end))
allocate(cnf%litr2n_to_soil2n(beg:end))
allocate(cnf%sminn_to_soil2n_l2(beg:end))
allocate(cnf%litr3n_to_soil3n(beg:end))
allocate(cnf%sminn_to_soil3n_l3(beg:end))
allocate(cnf%soil1n_to_soil2n(beg:end))
allocate(cnf%sminn_to_soil2n_s1(beg:end))
allocate(cnf%soil2n_to_soil3n(beg:end))
allocate(cnf%sminn_to_soil3n_s2(beg:end))
allocate(cnf%soil3n_to_soil4n(beg:end))
allocate(cnf%sminn_to_soil4n_s3(beg:end))
allocate(cnf%soil4n_to_sminn(beg:end))
allocate(cnf%sminn_to_denit_l1s1(beg:end))
allocate(cnf%sminn_to_denit_l2s2(beg:end))
allocate(cnf%sminn_to_denit_l3s3(beg:end))
allocate(cnf%sminn_to_denit_s1s2(beg:end))
allocate(cnf%sminn_to_denit_s2s3(beg:end))
allocate(cnf%sminn_to_denit_s3s4(beg:end))
allocate(cnf%sminn_to_denit_s4(beg:end))
allocate(cnf%sminn_to_denit_excess(beg:end))
allocate(cnf%sminn_leached(beg:end))
allocate(cnf%dwt_seedn_to_leaf(beg:end))
allocate(cnf%dwt_seedn_to_deadstem(beg:end))
allocate(cnf%dwt_conv_nflux(beg:end))
allocate(cnf%dwt_prod10n_gain(beg:end))
allocate(cnf%dwt_prod100n_gain(beg:end))
allocate(cnf%dwt_frootn_to_litr1n(beg:end))
allocate(cnf%dwt_frootn_to_litr2n(beg:end))
allocate(cnf%dwt_frootn_to_litr3n(beg:end))
allocate(cnf%dwt_livecrootn_to_cwdn(beg:end))
allocate(cnf%dwt_deadcrootn_to_cwdn(beg:end))
allocate(cnf%dwt_nloss(beg:end))
allocate(cnf%prod10n_loss(beg:end))
allocate(cnf%prod100n_loss(beg:end))
allocate(cnf%product_nloss(beg:end))
allocate(cnf%potential_immob(beg:end))
allocate(cnf%actual_immob(beg:end))
allocate(cnf%sminn_to_plant(beg:end))
allocate(cnf%supplement_to_sminn(beg:end))
allocate(cnf%gross_nmin(beg:end))
allocate(cnf%net_nmin(beg:end))
allocate(cnf%denit(beg:end))
allocate(cnf%col_ninputs(beg:end))
allocate(cnf%col_noutputs(beg:end))
allocate(cnf%col_fire_nloss(beg:end))
cnf%ndep_to_sminn(beg:end) = nan
cnf%nfix_to_sminn(beg:end) = nan
cnf%m_leafn_to_litr1n(beg:end) = nan
cnf%m_leafn_to_litr2n(beg:end) = nan
cnf%m_leafn_to_litr3n(beg:end) = nan
cnf%m_frootn_to_litr1n(beg:end) = nan
cnf%m_frootn_to_litr2n(beg:end) = nan
cnf%m_frootn_to_litr3n(beg:end) = nan
cnf%m_leafn_storage_to_litr1n(beg:end) = nan
cnf%m_frootn_storage_to_litr1n(beg:end) = nan
cnf%m_livestemn_storage_to_litr1n(beg:end) = nan
cnf%m_deadstemn_storage_to_litr1n(beg:end) = nan
cnf%m_livecrootn_storage_to_litr1n(beg:end) = nan
cnf%m_deadcrootn_storage_to_litr1n(beg:end) = nan
cnf%m_leafn_xfer_to_litr1n(beg:end) = nan
cnf%m_frootn_xfer_to_litr1n(beg:end) = nan
cnf%m_livestemn_xfer_to_litr1n(beg:end) = nan
cnf%m_deadstemn_xfer_to_litr1n(beg:end) = nan
cnf%m_livecrootn_xfer_to_litr1n(beg:end) = nan
cnf%m_deadcrootn_xfer_to_litr1n(beg:end) = nan
cnf%m_livestemn_to_cwdn(beg:end) = nan
cnf%m_deadstemn_to_cwdn(beg:end) = nan
cnf%m_livecrootn_to_cwdn(beg:end) = nan
cnf%m_deadcrootn_to_cwdn(beg:end) = nan
cnf%m_retransn_to_litr1n(beg:end) = nan
cnf%hrv_leafn_to_litr1n(beg:end) = nan
cnf%hrv_leafn_to_litr2n(beg:end) = nan
cnf%hrv_leafn_to_litr3n(beg:end) = nan
cnf%hrv_frootn_to_litr1n(beg:end) = nan
cnf%hrv_frootn_to_litr2n(beg:end) = nan
cnf%hrv_frootn_to_litr3n(beg:end) = nan
cnf%hrv_livestemn_to_cwdn(beg:end) = nan
cnf%hrv_deadstemn_to_prod10n(beg:end) = nan
cnf%hrv_deadstemn_to_prod100n(beg:end) = nan
cnf%hrv_livecrootn_to_cwdn(beg:end) = nan
cnf%hrv_deadcrootn_to_cwdn(beg:end) = nan
cnf%hrv_retransn_to_litr1n(beg:end) = nan
cnf%hrv_leafn_storage_to_litr1n(beg:end) = nan
cnf%hrv_frootn_storage_to_litr1n(beg:end) = nan
cnf%hrv_livestemn_storage_to_litr1n(beg:end) = nan
cnf%hrv_deadstemn_storage_to_litr1n(beg:end) = nan
cnf%hrv_livecrootn_storage_to_litr1n(beg:end) = nan
cnf%hrv_deadcrootn_storage_to_litr1n(beg:end) = nan
cnf%hrv_leafn_xfer_to_litr1n(beg:end) = nan
cnf%hrv_frootn_xfer_to_litr1n(beg:end) = nan
cnf%hrv_livestemn_xfer_to_litr1n(beg:end) = nan
cnf%hrv_deadstemn_xfer_to_litr1n(beg:end) = nan
cnf%hrv_livecrootn_xfer_to_litr1n(beg:end) = nan
cnf%hrv_deadcrootn_xfer_to_litr1n(beg:end) = nan
cnf%m_deadstemn_to_cwdn_fire(beg:end) = nan
cnf%m_deadcrootn_to_cwdn_fire(beg:end) = nan
cnf%m_litr1n_to_fire(beg:end) = nan
cnf%m_litr2n_to_fire(beg:end) = nan
cnf%m_litr3n_to_fire(beg:end) = nan
cnf%m_cwdn_to_fire(beg:end) = nan
#if (defined CROP)
cnf%grainn_to_litr1n(beg:end) = nan
cnf%grainn_to_litr2n(beg:end) = nan
cnf%grainn_to_litr3n(beg:end) = nan
cnf%livestemn_to_litr1n(beg:end) = nan
cnf%livestemn_to_litr2n(beg:end) = nan
cnf%livestemn_to_litr3n(beg:end) = nan
#endif
cnf%leafn_to_litr1n(beg:end) = nan
cnf%leafn_to_litr2n(beg:end) = nan
cnf%leafn_to_litr3n(beg:end) = nan
cnf%frootn_to_litr1n(beg:end) = nan
cnf%frootn_to_litr2n(beg:end) = nan
cnf%frootn_to_litr3n(beg:end) = nan
cnf%cwdn_to_litr2n(beg:end) = nan
cnf%cwdn_to_litr3n(beg:end) = nan
cnf%litr1n_to_soil1n(beg:end) = nan
cnf%sminn_to_soil1n_l1(beg:end) = nan
cnf%litr2n_to_soil2n(beg:end) = nan
cnf%sminn_to_soil2n_l2(beg:end) = nan
cnf%litr3n_to_soil3n(beg:end) = nan
cnf%sminn_to_soil3n_l3(beg:end) = nan
cnf%soil1n_to_soil2n(beg:end) = nan
cnf%sminn_to_soil2n_s1(beg:end) = nan
cnf%soil2n_to_soil3n(beg:end) = nan
cnf%sminn_to_soil3n_s2(beg:end) = nan
cnf%soil3n_to_soil4n(beg:end) = nan
cnf%sminn_to_soil4n_s3(beg:end) = nan
cnf%soil4n_to_sminn(beg:end) = nan
cnf%sminn_to_denit_l1s1(beg:end) = nan
cnf%sminn_to_denit_l2s2(beg:end) = nan
cnf%sminn_to_denit_l3s3(beg:end) = nan
cnf%sminn_to_denit_s1s2(beg:end) = nan
cnf%sminn_to_denit_s2s3(beg:end) = nan
cnf%sminn_to_denit_s3s4(beg:end) = nan
cnf%sminn_to_denit_s4(beg:end) = nan
cnf%sminn_to_denit_excess(beg:end) = nan
cnf%sminn_leached(beg:end) = nan
cnf%dwt_seedn_to_leaf(beg:end) = nan
cnf%dwt_seedn_to_deadstem(beg:end) = nan
cnf%dwt_conv_nflux(beg:end) = nan
cnf%dwt_prod10n_gain(beg:end) = nan
cnf%dwt_prod100n_gain(beg:end) = nan
cnf%dwt_frootn_to_litr1n(beg:end) = nan
cnf%dwt_frootn_to_litr2n(beg:end) = nan
cnf%dwt_frootn_to_litr3n(beg:end) = nan
cnf%dwt_livecrootn_to_cwdn(beg:end) = nan
cnf%dwt_deadcrootn_to_cwdn(beg:end) = nan
cnf%dwt_nloss(beg:end) = nan
cnf%prod10n_loss(beg:end) = nan
cnf%prod100n_loss(beg:end) = nan
cnf%product_nloss(beg:end) = nan
cnf%potential_immob(beg:end) = nan
cnf%actual_immob(beg:end) = nan
cnf%sminn_to_plant(beg:end) = nan
cnf%supplement_to_sminn(beg:end) = nan
cnf%gross_nmin(beg:end) = nan
cnf%net_nmin(beg:end) = nan
cnf%denit(beg:end) = nan
cnf%col_ninputs(beg:end) = nan
cnf%col_noutputs(beg:end) = nan
cnf%col_fire_nloss(beg:end) = nan
end subroutine init_column_nflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_landunit_pstate_type
!
! !INTERFACE:
subroutine init_landunit_pstate_type(beg, end, lps) 1
!
! !DESCRIPTION:
! Initialize landunit physical state variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (landunit_pstate_type), intent(inout):: lps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(lps%t_building(beg:end))
allocate(lps%t_building_max(beg:end))
allocate(lps%t_building_min(beg:end))
allocate(lps%tk_wall(beg:end,nlevurb))
allocate(lps%tk_roof(beg:end,nlevurb))
allocate(lps%tk_improad(beg:end,nlevgrnd))
allocate(lps%cv_wall(beg:end,nlevurb))
allocate(lps%cv_roof(beg:end,nlevurb))
allocate(lps%cv_improad(beg:end,nlevgrnd))
allocate(lps%thick_wall(beg:end))
allocate(lps%thick_roof(beg:end))
allocate(lps%nlev_improad(beg:end))
allocate(lps%vf_sr(beg:end))
allocate(lps%vf_wr(beg:end))
allocate(lps%vf_sw(beg:end))
allocate(lps%vf_rw(beg:end))
allocate(lps%vf_ww(beg:end))
allocate(lps%taf(beg:end))
allocate(lps%qaf(beg:end))
allocate(lps%sabs_roof_dir(beg:end,1:numrad))
allocate(lps%sabs_roof_dif(beg:end,1:numrad))
allocate(lps%sabs_sunwall_dir(beg:end,1:numrad))
allocate(lps%sabs_sunwall_dif(beg:end,1:numrad))
allocate(lps%sabs_shadewall_dir(beg:end,1:numrad))
allocate(lps%sabs_shadewall_dif(beg:end,1:numrad))
allocate(lps%sabs_improad_dir(beg:end,1:numrad))
allocate(lps%sabs_improad_dif(beg:end,1:numrad))
allocate(lps%sabs_perroad_dir(beg:end,1:numrad))
allocate(lps%sabs_perroad_dif(beg:end,1:numrad))
lps%t_building(beg:end) = nan
lps%t_building_max(beg:end) = nan
lps%t_building_min(beg:end) = nan
lps%tk_wall(beg:end,1:nlevurb) = nan
lps%tk_roof(beg:end,1:nlevurb) = nan
lps%tk_improad(beg:end,1:nlevgrnd) = nan
lps%cv_wall(beg:end,1:nlevurb) = nan
lps%cv_roof(beg:end,1:nlevurb) = nan
lps%cv_improad(beg:end,1:nlevgrnd) = nan
lps%cv_improad(beg:end,1:5) = nan
lps%thick_wall(beg:end) = nan
lps%thick_roof(beg:end) = nan
lps%nlev_improad(beg:end) = bigint
lps%vf_sr(beg:end) = nan
lps%vf_wr(beg:end) = nan
lps%vf_sw(beg:end) = nan
lps%vf_rw(beg:end) = nan
lps%vf_ww(beg:end) = nan
lps%taf(beg:end) = nan
lps%qaf(beg:end) = nan
lps%sabs_roof_dir(beg:end,1:numrad) = nan
lps%sabs_roof_dif(beg:end,1:numrad) = nan
lps%sabs_sunwall_dir(beg:end,1:numrad) = nan
lps%sabs_sunwall_dif(beg:end,1:numrad) = nan
lps%sabs_shadewall_dir(beg:end,1:numrad) = nan
lps%sabs_shadewall_dif(beg:end,1:numrad) = nan
lps%sabs_improad_dir(beg:end,1:numrad) = nan
lps%sabs_improad_dif(beg:end,1:numrad) = nan
lps%sabs_perroad_dir(beg:end,1:numrad) = nan
lps%sabs_perroad_dif(beg:end,1:numrad) = nan
end subroutine init_landunit_pstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_landunit_eflux_type
!
! !INTERFACE:
subroutine init_landunit_eflux_type(beg, end, lef) 1
!
! !DESCRIPTION:
! Initialize landunit energy flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (landunit_eflux_type), intent(inout):: lef
!
! !REVISION HISTORY:
! Created by Keith Oleson
!
!EOP
!------------------------------------------------------------------------
allocate(lef%eflx_traffic(beg:end))
allocate(lef%eflx_traffic_factor(beg:end))
allocate(lef%eflx_wasteheat(beg:end))
allocate(lef%eflx_heat_from_ac(beg:end))
lef%eflx_traffic(beg:end) = nan
lef%eflx_traffic_factor(beg:end) = nan
lef%eflx_wasteheat(beg:end) = nan
lef%eflx_heat_from_ac(beg:end) = nan
end subroutine init_landunit_eflux_type
#if (defined CNDV)
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_gridcell_dgvstate_type
!
! !INTERFACE:
subroutine init_gridcell_dgvstate_type(beg, end, gps) 1
!
! !DESCRIPTION:
! Initialize gridcell DGVM variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (gridcell_dgvstate_type), intent(inout):: gps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(gps%agdd20(beg:end))
allocate(gps%tmomin20(beg:end))
allocate(gps%t10min(beg:end))
gps%agdd20(beg:end) = nan
gps%tmomin20(beg:end) = nan
gps%t10min(beg:end) = nan
end subroutine init_gridcell_dgvstate_type
#endif
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_gridcell_pstate_type
!
! !INTERFACE:
subroutine init_gridcell_pstate_type(beg, end, gps) 1
!
! !DESCRIPTION:
! Initialize gridcell physical state variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (gridcell_pstate_type), intent(inout):: gps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
!allocate(gps%bcphiwet2t(beg:end,1:2))
!allocate(gps%bcphidry2t(beg:end,1:2))
!allocate(gps%bcphodry2t(beg:end,1:2))
!allocate(gps%ocphiwet2t(beg:end,1:2))
!allocate(gps%ocphidry2t(beg:end,1:2))
!allocate(gps%ocphodry2t(beg:end,1:2))
!allocate(gps%dstx01wd2t(beg:end,1:2))
!allocate(gps%dstx01dd2t(beg:end,1:2))
!allocate(gps%dstx02wd2t(beg:end,1:2))
!allocate(gps%dstx02dd2t(beg:end,1:2))
!allocate(gps%dstx03wd2t(beg:end,1:2))
!allocate(gps%dstx03dd2t(beg:end,1:2))
!allocate(gps%dstx04wd2t(beg:end,1:2))
!allocate(gps%dstx04dd2t(beg:end,1:2))
!gps%bcphiwet2t(beg:end,1:2) = nan
!gps%bcphidry2t(beg:end,1:2) = nan
!gps%bcphodry2t(beg:end,1:2) = nan
!gps%ocphiwet2t(beg:end,1:2) = nan
!gps%ocphidry2t(beg:end,1:2) = nan
!gps%ocphodry2t(beg:end,1:2) = nan
!gps%dstx01wd2t(beg:end,1:2) = nan
!gps%dstx01dd2t(beg:end,1:2) = nan
!gps%dstx02wd2t(beg:end,1:2) = nan
!gps%dstx02dd2t(beg:end,1:2) = nan
!gps%dstx03wd2t(beg:end,1:2) = nan
!gps%dstx03dd2t(beg:end,1:2) = nan
!gps%dstx04wd2t(beg:end,1:2) = nan
!gps%dstx04dd2t(beg:end,1:2) = nan
end subroutine init_gridcell_pstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_gridcell_efstate_type
!
! !INTERFACE:
subroutine init_gridcell_efstate_type(beg, end, gve) 1
!
! !DESCRIPTION:
! Initialize gridcell isoprene emission factor variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (gridcell_efstate_type), intent(inout) :: gve
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein (heald)
!
!EOP
!------------------------------------------------------------------------
allocate(gve%efisop(6,beg:end))
gve%efisop(:,beg:end) = nan
end subroutine init_gridcell_efstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_gridcell_wflux_type
!
! !INTERFACE:
subroutine init_gridcell_wflux_type(beg, end, gwf) 1
!
! !DESCRIPTION:
! Initialize gridcell water flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (gridcell_wflux_type), intent(inout):: gwf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
allocate(gwf%qflx_runoffg(beg:end))
allocate(gwf%qflx_snwcp_iceg(beg:end))
allocate(gwf%qflx_liq_dynbal(beg:end))
allocate(gwf%qflx_ice_dynbal(beg:end))
gwf%qflx_runoffg(beg:end) = nan
gwf%qflx_snwcp_iceg(beg:end) = nan
gwf%qflx_liq_dynbal(beg:end) = nan
gwf%qflx_ice_dynbal(beg:end) = nan
end subroutine init_gridcell_wflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_gridcell_eflux_type
!
! !INTERFACE:
subroutine init_gridcell_eflux_type(beg, end, gef) 1
!
! !DESCRIPTION:
! Initialize gridcell energy flux variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (gridcell_eflux_type), intent(inout):: gef
!
! !REVISION HISTORY:
! Created by David Lawrence
!
!EOP
!------------------------------------------------------------------------
allocate(gef%eflx_sh_totg(beg:end))
allocate(gef%eflx_dynbal(beg:end))
gef%eflx_sh_totg(beg:end) = nan
gef%eflx_dynbal(beg:end) = nan
end subroutine init_gridcell_eflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_gridcell_wstate_type
!
! !INTERFACE:
subroutine init_gridcell_wstate_type(beg, end, gws) 1
!
! !DESCRIPTION:
! Initialize gridcell water state variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (gridcell_wstate_type), intent(inout):: gws
!
! !REVISION HISTORY:
! Created by David Lawrence
!
!EOP
!------------------------------------------------------------------------
allocate(gws%gc_liq1(beg:end))
allocate(gws%gc_liq2(beg:end))
allocate(gws%gc_ice1(beg:end))
allocate(gws%gc_ice2(beg:end))
gws%gc_liq1(beg:end) = nan
gws%gc_liq2(beg:end) = nan
gws%gc_ice1(beg:end) = nan
gws%gc_ice2(beg:end) = nan
end subroutine init_gridcell_wstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_gridcell_estate_type
!
! !INTERFACE:
subroutine init_gridcell_estate_type(beg, end, ges) 1
!
! !DESCRIPTION:
! Initialize gridcell energy state variables
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (gridcell_estate_type), intent(inout):: ges
!
! !REVISION HISTORY:
! Created by David Lawrence
!
!EOP
!------------------------------------------------------------------------
allocate(ges%gc_heat1(beg:end))
allocate(ges%gc_heat2(beg:end))
ges%gc_heat1(beg:end) = nan
ges%gc_heat2(beg:end) = nan
end subroutine init_gridcell_estate_type
! !INTERFACE:
subroutine init_atm2lnd_type(beg, end, a2l) 1
!
! !DESCRIPTION:
! Initialize atmospheric variables required by the land
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: beg, end
type (atm2lnd_type), intent(inout):: a2l
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! Modified by T Craig, 11/01/05 for finemesh project
!
!
! !LOCAL VARIABLES:
!EOP
real(r8) :: ival ! initial value
integer :: beg_atm, end_atm
!------------------------------------------------------------------------
allocate(a2l%forc_t(beg:end))
allocate(a2l%forc_u(beg:end))
allocate(a2l%forc_v(beg:end))
allocate(a2l%forc_wind(beg:end))
allocate(a2l%forc_q(beg:end))
allocate(a2l%forc_rh(beg:end))
allocate(a2l%forc_hgt(beg:end))
allocate(a2l%forc_hgt_u(beg:end))
allocate(a2l%forc_hgt_t(beg:end))
allocate(a2l%forc_hgt_q(beg:end))
allocate(a2l%forc_pbot(beg:end))
allocate(a2l%forc_th(beg:end))
allocate(a2l%forc_vp(beg:end))
allocate(a2l%forc_rho(beg:end))
allocate(a2l%forc_psrf(beg:end))
allocate(a2l%forc_pco2(beg:end))
allocate(a2l%forc_lwrad(beg:end))
allocate(a2l%forc_solad(beg:end,numrad))
allocate(a2l%forc_solai(beg:end,numrad))
allocate(a2l%forc_solar(beg:end))
allocate(a2l%forc_rain(beg:end))
allocate(a2l%forc_snow(beg:end))
allocate(a2l%forc_ndep(beg:end))
allocate(a2l%rainf(beg:end))
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
allocate(a2l%forc_pc13o2(beg:end))
#endif
allocate(a2l%forc_po2(beg:end))
allocate(a2l%forc_aer(beg:end,14))
! ival = nan ! causes core dump in map_maparray, tcx fix
ival = 0.0_r8
a2l%forc_t(beg:end) = ival
a2l%forc_u(beg:end) = ival
a2l%forc_v(beg:end) = ival
a2l%forc_wind(beg:end) = ival
a2l%forc_q(beg:end) = ival
a2l%forc_rh(beg:end) = ival
a2l%forc_hgt(beg:end) = ival
a2l%forc_hgt_u(beg:end) = ival
a2l%forc_hgt_t(beg:end) = ival
a2l%forc_hgt_q(beg:end) = ival
a2l%forc_pbot(beg:end) = ival
a2l%forc_th(beg:end) = ival
a2l%forc_vp(beg:end) = ival
a2l%forc_rho(beg:end) = ival
a2l%forc_psrf(beg:end) = ival
a2l%forc_pco2(beg:end) = ival
a2l%forc_lwrad(beg:end) = ival
a2l%forc_solad(beg:end,1:numrad) = ival
a2l%forc_solai(beg:end,1:numrad) = ival
a2l%forc_solar(beg:end) = ival
a2l%forc_rain(beg:end) = ival
a2l%forc_snow(beg:end) = ival
a2l%forc_ndep(beg:end) = ival
a2l%rainf(beg:end) = nan
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
a2l%forc_pc13o2(beg:end) = ival
#endif
a2l%forc_po2(beg:end) = ival
a2l%forc_aer(beg:end,:) = ival
end subroutine init_atm2lnd_type
subroutine clmtype_dealloc() 1,99
!
! !ARGUMENTS:
implicit none
call dealloc_pft_type ( clm3%g%l%c%p)
call dealloc_column_type ( clm3%g%l%c)
call dealloc_landunit_type( clm3%g%l)
call dealloc_gridcell_type( clm3%g)
! pft ecophysiological constants
call dealloc_pft_ecophys_constants()
#if (defined CNDV)
! pft DGVM-specific ecophysiological constants
call dealloc_pft_DGVMecophys_constants()
#endif
! energy balance structures (all levels)
call dealloc_energy_balance_type( clm3%g%l%c%p%pebal)
call dealloc_energy_balance_type( clm3%g%l%c%cebal)
call dealloc_energy_balance_type( clm3%g%l%lebal)
call dealloc_energy_balance_type( clm3%g%gebal)
call dealloc_energy_balance_type( clm3%mebal)
! water balance structures (all levels)
call dealloc_water_balance_type( clm3%g%l%c%p%pwbal)
call dealloc_water_balance_type( clm3%g%l%c%cwbal)
call dealloc_water_balance_type( clm3%g%l%lwbal)
call dealloc_water_balance_type( clm3%g%gwbal)
call dealloc_water_balance_type( clm3%mwbal)
! carbon balance structures (pft and column levels)
call dealloc_carbon_balance_type( clm3%g%l%c%p%pcbal)
call dealloc_carbon_balance_type( clm3%g%l%c%ccbal)
! nitrogen balance structures (pft and column levels)
call dealloc_nitrogen_balance_type( clm3%g%l%c%p%pnbal)
call dealloc_nitrogen_balance_type( clm3%g%l%c%cnbal)
! pft physical state variables at pft level and averaged to the column
call dealloc_pft_pstate_type( clm3%g%l%c%p%pps)
call dealloc_pft_pstate_type( clm3%g%l%c%cps%pps_a)
! pft ecophysiological variables (only at the pft level for now)
call dealloc_pft_epv_type( clm3%g%l%c%p%pepv)
#if (defined CNDV) || (defined CROP)
! pft DGVM state variables at pft level and averaged to column
call dealloc_pft_pdgvstate_type( clm3%g%l%c%p%pdgvs)
#endif
#if (defined CNDV)
call dealloc_pft_pdgvstate_type( clm3%g%l%c%cdgvs%pdgvs_a)
#endif
call dealloc_pft_vstate_type( clm3%g%l%c%p%pvs)
! pft energy state variables at the pft level and averaged to the column
call dealloc_pft_estate_type( clm3%g%l%c%p%pes)
call dealloc_pft_estate_type( clm3%g%l%c%ces%pes_a)
! pft water state variables at the pft level and averaged to the column
call dealloc_pft_wstate_type( clm3%g%l%c%p%pws)
call dealloc_pft_wstate_type( clm3%g%l%c%cws%pws_a)
! pft carbon state variables at the pft level and averaged to the column
call dealloc_pft_cstate_type( clm3%g%l%c%p%pcs)
call dealloc_pft_cstate_type( clm3%g%l%c%ccs%pcs_a)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
call dealloc_pft_cstate_type( clm3%g%l%c%p%pc13s)
call dealloc_pft_cstate_type( clm3%g%l%c%cc13s%pcs_a)
#endif
! pft nitrogen state variables at the pft level and averaged to the column
call dealloc_pft_nstate_type( clm3%g%l%c%p%pns)
call dealloc_pft_nstate_type( clm3%g%l%c%cns%pns_a)
! pft energy flux variables at pft level and averaged to column
call dealloc_pft_eflux_type( clm3%g%l%c%p%pef)
call dealloc_pft_eflux_type( clm3%g%l%c%cef%pef_a)
! pft momentum flux variables at pft level and averaged to the column
call dealloc_pft_mflux_type( clm3%g%l%c%p%pmf)
call dealloc_pft_mflux_type( clm3%g%l%c%cmf%pmf_a)
! pft water flux variables
call dealloc_pft_wflux_type( clm3%g%l%c%p%pwf)
call dealloc_pft_wflux_type( clm3%g%l%c%cwf%pwf_a)
! pft carbon flux variables at pft level and averaged to column
call dealloc_pft_cflux_type( clm3%g%l%c%p%pcf)
call dealloc_pft_cflux_type( clm3%g%l%c%ccf%pcf_a)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
call dealloc_pft_cflux_type( clm3%g%l%c%p%pc13f)
call dealloc_pft_cflux_type( clm3%g%l%c%cc13f%pcf_a)
#endif
! pft nitrogen flux variables at pft level and averaged to column
call dealloc_pft_nflux_type( clm3%g%l%c%p%pnf)
call dealloc_pft_nflux_type( clm3%g%l%c%cnf%pnf_a)
! pft VOC flux variables at pft level and averaged to column
call dealloc_pft_vflux_type( clm3%g%l%c%p%pvf)
call dealloc_pft_vflux_type( clm3%g%l%c%cvf%pvf_a)
! gridcell VOC emission factors (heald, 05/06)
call dealloc_gridcell_efstate_type( clm3%g%gve)
! pft dust flux variables at pft level and averaged to column
call dealloc_pft_dflux_type( clm3%g%l%c%p%pdf)
call dealloc_pft_dflux_type( clm3%g%l%c%cdf%pdf_a)
! pft dry dep velocity variables at pft level and averaged to column
call dealloc_pft_depvd_type( clm3%g%l%c%p%pdd)
! column physical state variables at column level and averaged to
! the landunit and gridcell and model
call dealloc_column_pstate_type( clm3%g%l%c%cps)
call dealloc_column_pstate_type( clm3%g%l%lps%cps_a)
call dealloc_column_pstate_type( clm3%g%gps%cps_a)
call dealloc_column_pstate_type( clm3%mps%cps_a)
! column energy state variables at column level and averaged to
! the landunit and gridcell and model
call dealloc_column_estate_type( clm3%g%l%c%ces)
call dealloc_column_estate_type( clm3%g%l%les%ces_a)
call dealloc_column_estate_type( clm3%g%ges%ces_a)
call dealloc_column_estate_type( clm3%mes%ces_a)
! column water state variables at column level and averaged to
! the landunit and gridcell and model
call dealloc_column_wstate_type( clm3%g%l%c%cws)
call dealloc_column_wstate_type( clm3%g%l%lws%cws_a)
call dealloc_column_wstate_type( clm3%g%gws%cws_a)
call dealloc_column_wstate_type( clm3%mws%cws_a)
! column carbon state variables at column level and averaged to
! the landunit and gridcell and model
call dealloc_column_cstate_type( clm3%g%l%c%ccs)
call dealloc_column_cstate_type( clm3%g%l%lcs%ccs_a)
call dealloc_column_cstate_type( clm3%g%gcs%ccs_a)
call dealloc_column_cstate_type( clm3%mcs%ccs_a)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
call dealloc_column_cstate_type( clm3%g%l%c%cc13s)
#endif
! column nitrogen state variables at column level and averaged to
! the landunit and gridcell and model
call dealloc_column_nstate_type( clm3%g%l%c%cns)
call dealloc_column_nstate_type( clm3%g%l%lns%cns_a)
call dealloc_column_nstate_type( clm3%g%gns%cns_a)
call dealloc_column_nstate_type( clm3%mns%cns_a)
! column energy flux variables at column level and averaged to
! the landunit and gridcell and model
call dealloc_column_eflux_type( clm3%g%l%c%cef)
call dealloc_column_eflux_type( clm3%g%l%lef%cef_a)
call dealloc_column_eflux_type( clm3%g%gef%cef_a)
call dealloc_column_eflux_type( clm3%mef%cef_a)
! column water flux variables at column level and averaged to
! landunit, gridcell and model level
call dealloc_column_wflux_type( clm3%g%l%c%cwf)
call dealloc_column_wflux_type( clm3%g%l%lwf%cwf_a)
call dealloc_column_wflux_type( clm3%g%gwf%cwf_a)
call dealloc_column_wflux_type( clm3%mwf%cwf_a)
! column carbon flux variables at column level
call dealloc_column_cflux_type( clm3%g%l%c%ccf)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
call dealloc_column_cflux_type( clm3%g%l%c%cc13f)
#endif
! column nitrogen flux variables at column level
call dealloc_column_nflux_type( clm3%g%l%c%cnf)
! land unit physical state variables
call dealloc_landunit_pstate_type( clm3%g%l%lps)
call CLMDebug('mark1')
! land unit energy flux variables
call dealloc_landunit_eflux_type( clm3%g%l%lef)
#if (defined CNDV)
! gridcell DGVM variables
call dealloc_gridcell_dgvstate_type( clm3%g%gdgvs)
#endif
! gridcell physical state variables
call dealloc_gridcell_pstate_type( clm3%g%gps)
! gridcell: water flux variables
call dealloc_gridcell_wflux_type( clm3%g%gwf)
! gridcell: energy flux variables
call dealloc_gridcell_eflux_type( clm3%g%gef)
call CLMDebug('mark2')
! gridcell: water state variables
call dealloc_gridcell_wstate_type( clm3%g%gws)
! gridcell: energy state variables
call dealloc_gridcell_estate_type( clm3%g%ges)
call CLMDebug('mark3')
call dealloc_atm2lnd_type ( clm_a2l)
call CLMDebug('done clmtype_dealloc')
end subroutine clmtype_dealloc
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_type
!
! !INTERFACE:
subroutine dealloc_pft_type ( p) 1
!
implicit none
type(pft_type), intent(inout):: p
deallocate(p%gridcell ,p%wtgcell )
deallocate(p%landunit ,p%wtlunit )
deallocate(p%column ,p%wtcol )
deallocate(p%itype )
deallocate(p%mxy )
deallocate(p%area)
end subroutine dealloc_pft_type
! !IROUTINE: dealloc_column_type
!
! !INTERFACE:
subroutine dealloc_column_type ( c) 1
!
implicit none
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
type(column_type), intent(inout):: c
deallocate(c%gridcell ,c%wtgcell )
deallocate(c%landunit ,c%wtlunit )
deallocate(c%pfti ,c%pftf ,c%npfts )
deallocate(c%itype )
deallocate(c%area)
end subroutine dealloc_column_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_landunit_type
!
! !INTERFACE:
subroutine dealloc_landunit_type ( l) 1
!
! !DESCRIPTION:
! Initialize components of landunit_type structure
!
! !ARGUMENTS:
implicit none
type(landunit_type), intent(inout):: l
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(l%gridcell ,l%wtgcell )
deallocate(l%coli ,l%colf ,l%ncolumns )
deallocate(l%pfti ,l%pftf ,l%npfts )
deallocate(l%itype )
deallocate(l%ifspecial )
deallocate(l%lakpoi )
deallocate(l%urbpoi )
! MV - these should be moved to landunit physical state -MV
deallocate(l%canyon_hwr )
deallocate(l%wtroad_perv )
deallocate(l%ht_roof )
deallocate(l%wtlunit_roof )
deallocate(l%wind_hgt_canyon )
deallocate(l%z_0_town )
deallocate(l%z_d_town )
deallocate(l%area)
end subroutine dealloc_landunit_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_gridcell_type
!
! !INTERFACE:
subroutine dealloc_gridcell_type ( g) 1
!
! !DESCRIPTION:
! Initialize components of gridcell_type structure
!
! !ARGUMENTS:
implicit none
type(gridcell_type), intent(inout):: g
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(g%luni ,g%lunf ,g%nlandunits )
deallocate(g%coli ,g%colf ,g%ncolumns )
deallocate(g%pfti ,g%pftf ,g%npfts )
deallocate(g%gindex )
deallocate(g%area )
deallocate(g%lat )
deallocate(g%lon )
deallocate(g%latdeg )
deallocate(g%londeg )
deallocate(g%gindex_a )
deallocate(g%lat_a )
deallocate(g%lon_a )
deallocate(g%latdeg_a )
deallocate(g%londeg_a )
end subroutine dealloc_gridcell_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_energy_balance_type
!
! !INTERFACE:
subroutine dealloc_energy_balance_type( ebal) 5
!
! !DESCRIPTION:
! Initialize energy balance variables
!
! !ARGUMENTS:
implicit none
type(energy_balance_type), intent(inout):: ebal
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(ebal%errsoi )
deallocate(ebal%errseb )
deallocate(ebal%errsol )
deallocate(ebal%errlon )
end subroutine dealloc_energy_balance_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_water_balance_type
!
! !INTERFACE:
subroutine dealloc_water_balance_type( wbal) 5
!
! !DESCRIPTION:
! Initialize water balance variables
!
! !ARGUMENTS:
implicit none
type(water_balance_type), intent(inout):: wbal
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(wbal%begwb )
deallocate(wbal%endwb )
deallocate(wbal%errh2o )
end subroutine dealloc_water_balance_type
!------------------------------------------------------------------------
!BOP
! !IROUTINE: dealloc_carbon_balance_type
!
! !INTERFACE:
subroutine dealloc_carbon_balance_type( cbal) 2
!
! !DESCRIPTION:
! Initialize carbon balance variables
!
! !ARGUMENTS:
implicit none
type(carbon_balance_type), intent(inout):: cbal
!
! !REVISION HISTORY:
! Created by Peter Thornton, 12/11/2003
!
!EOP
!------------------------------------------------------------------------
deallocate(cbal%begcb )
deallocate(cbal%endcb )
deallocate(cbal%errcb )
end subroutine dealloc_carbon_balance_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_nitrogen_balance_type
!
! !INTERFACE:
subroutine dealloc_nitrogen_balance_type( nbal) 2
!
! !DESCRIPTION:
! Initialize nitrogen balance variables
!
! !ARGUMENTS:
implicit none
type(nitrogen_balance_type), intent(inout):: nbal
!
! !REVISION HISTORY:
! Created by Peter Thornton, 12/11/2003
!
!EOP
!------------------------------------------------------------------------
deallocate(nbal%begnb )
deallocate(nbal%endnb )
deallocate(nbal%errnb )
end subroutine dealloc_nitrogen_balance_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_ecophys_constants
! !INTERFACE:
subroutine dealloc_pft_ecophys_constants() 1
!
! !DESCRIPTION:
! Initialize pft physical state
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(pftcon%noveg )
deallocate(pftcon%tree )
deallocate(pftcon%smpso )
deallocate(pftcon%smpsc )
deallocate(pftcon%fnitr )
deallocate(pftcon%foln )
deallocate(pftcon%dleaf )
deallocate(pftcon%c3psn )
deallocate(pftcon%vcmx25 )
deallocate(pftcon%mp )
deallocate(pftcon%qe25 )
deallocate(pftcon%xl )
deallocate(pftcon%rhol)
deallocate(pftcon%rhos)
deallocate(pftcon%taul)
deallocate(pftcon%taus)
deallocate(pftcon%z0mr )
deallocate(pftcon%displar )
deallocate(pftcon%roota_par )
deallocate(pftcon%rootb_par )
deallocate(pftcon%sla )
deallocate(pftcon%slatop )
deallocate(pftcon%dsladlai )
deallocate(pftcon%leafcn )
deallocate(pftcon%flnr )
deallocate(pftcon%woody )
deallocate(pftcon%lflitcn )
deallocate(pftcon%frootcn )
deallocate(pftcon%livewdcn )
deallocate(pftcon%deadwdcn )
#ifdef CROP
deallocate(pftcon%graincn )
#endif
deallocate(pftcon%froot_leaf )
deallocate(pftcon%stem_leaf )
deallocate(pftcon%croot_stem )
deallocate(pftcon%flivewd )
deallocate(pftcon%fcur )
deallocate(pftcon%lf_flab )
deallocate(pftcon%lf_fcel )
deallocate(pftcon%lf_flig )
deallocate(pftcon%fr_flab )
deallocate(pftcon%fr_fcel )
deallocate(pftcon%fr_flig )
deallocate(pftcon%dw_fcel )
deallocate(pftcon%dw_flig )
deallocate(pftcon%leaf_long )
deallocate(pftcon%evergreen )
deallocate(pftcon%stress_decid )
deallocate(pftcon%season_decid )
deallocate(pftcon%resist )
deallocate(pftcon%dwood )
end subroutine dealloc_pft_ecophys_constants
#if (defined CNDV) || (defined CROP)
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_DGVMecophys_constants
!
! !INTERFACE:
subroutine dealloc_pft_DGVMecophys_constants() 1
! !DESCRIPTION:
! Initialize pft physical state
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(dgv_pftcon%crownarea_max )
deallocate(dgv_pftcon%tcmin )
deallocate(dgv_pftcon%tcmax )
deallocate(dgv_pftcon%gddmin )
deallocate(dgv_pftcon%twmax )
deallocate(dgv_pftcon%reinickerp )
deallocate(dgv_pftcon%allom1 )
deallocate(dgv_pftcon%allom2 )
deallocate(dgv_pftcon%allom3 )
end subroutine dealloc_pft_DGVMecophys_constants
#endif
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_pstate_type
!
! !INTERFACE:
subroutine dealloc_pft_pstate_type( pps) 2,1
!
! !DESCRIPTION:
! Initialize pft physical state
!
! !USES:
use clm_varcon, only : spval
#if (defined CASA)
use CASAMod , only : npools, nresp_pools, nlive, npool_types
#endif
! !ARGUMENTS:
implicit none
type (pft_pstate_type), intent(inout):: pps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(pps%frac_veg_nosno )
deallocate(pps%frac_veg_nosno_alb )
deallocate(pps%emv )
deallocate(pps%z0mv )
deallocate(pps%z0hv )
deallocate(pps%z0qv )
deallocate(pps%rootfr )
deallocate(pps%rootr )
deallocate(pps%rresis )
deallocate(pps%dewmx )
deallocate(pps%rssun )
deallocate(pps%rssha )
deallocate(pps%laisun )
deallocate(pps%laisha )
deallocate(pps%btran )
deallocate(pps%fsun )
deallocate(pps%tlai )
deallocate(pps%tsai )
deallocate(pps%elai )
deallocate(pps%esai )
deallocate(pps%fwet )
deallocate(pps%fdry )
deallocate(pps%dt_veg )
deallocate(pps%htop )
deallocate(pps%hbot )
deallocate(pps%z0m )
deallocate(pps%displa )
deallocate(pps%albd )
deallocate(pps%albi )
deallocate(pps%fabd )
deallocate(pps%fabi )
deallocate(pps%ftdd )
deallocate(pps%ftid )
deallocate(pps%ftii )
deallocate(pps%u10 )
deallocate(pps%fv )
deallocate(pps%ram1 )
#if (defined CROP)
deallocate(pps%hdidx )
deallocate(pps%cumvd )
deallocate(pps%htmx )
deallocate(pps%vf )
deallocate(pps%gddmaturity )
deallocate(pps%gdd0 )
deallocate(pps%gdd8 )
deallocate(pps%gdd10 )
deallocate(pps%gdd020 )
deallocate(pps%gdd820 )
deallocate(pps%gdd1020 )
deallocate(pps%gddplant )
deallocate(pps%gddtsoi )
deallocate(pps%huileaf )
deallocate(pps%huigrain )
deallocate(pps%a10tmin )
deallocate(pps%a5tmin )
deallocate(pps%aleafi )
deallocate(pps%astemi )
deallocate(pps%aleaf )
deallocate(pps%astem )
deallocate(pps%croplive )
deallocate(pps%cropplant ) !,numpft)) ! make 2-D if using
deallocate(pps%harvdate ) !,numpft)) ! crop rotation
deallocate(pps%idop )
deallocate(pps%peaklai )
#endif
deallocate(pps%vds )
deallocate(pps%slasun )
deallocate(pps%slasha )
deallocate(pps%lncsun )
deallocate(pps%lncsha )
deallocate(pps%vcmxsun )
deallocate(pps%vcmxsha )
deallocate(pps%gdir )
deallocate(pps%omega )
deallocate(pps%eff_kid )
deallocate(pps%eff_kii )
deallocate(pps%sun_faid )
deallocate(pps%sun_faii )
deallocate(pps%sha_faid )
deallocate(pps%sha_faii )
deallocate(pps%forc_hgt_u_pft )
deallocate(pps%forc_hgt_t_pft )
deallocate(pps%forc_hgt_q_pft )
! 4/14/05: PET
! Adding isotope code
deallocate(pps%cisun )
deallocate(pps%cisha )
#if (defined C13)
deallocate(pps%alphapsnsun )
deallocate(pps%alphapsnsha )
#endif
! heald: added from CASA defdeallocion
deallocate(pps%sandfrac )
deallocate(pps%clayfrac )
deallocate(pps%mlaidiff )
deallocate(pps%rb1 )
deallocate(pps%annlai)
#if (defined CASA)
deallocate(pps%Closs) ! C lost to atm
deallocate(pps%Ctrans) ! C transfers out of pool types
deallocate(pps%Resp_C)
deallocate(pps%Tpool_C)! Total C pool size
deallocate(pps%eff)
deallocate(pps%frac_donor)
deallocate(pps%livefr) !live fraction
deallocate(pps%pet ) !potential evaporation (mm h2o/s)
deallocate(pps%co2flux ) ! net CO2 flux (g C/m2/sec) [+= atm]
deallocate(pps%fnpp ) ! NPP (g C/m2/sec)
deallocate(pps%soilt ) !soil temp for top 30cm
deallocate(pps%smoist ) !soil moisture for top 30cm
deallocate(pps%sz )
deallocate(pps%watopt )
deallocate(pps%watdry )
deallocate(pps%soiltc ) !soil temp for entire column
deallocate(pps%smoistc ) !soil moisture for entire column
deallocate(pps%szc )
deallocate(pps%watoptc )
deallocate(pps%watdryc )
deallocate(pps%Wlim )
deallocate(pps%litterscalar )
deallocate(pps%rootlitscalar )
deallocate(pps%stressCD )
deallocate(pps%excessC ) ! excess Carbon (gC/m2/timestep)
deallocate(pps%bgtemp )
deallocate(pps%bgmoist )
deallocate(pps%plai ) ! prognostic LAI (m2 leaf/m2 ground)
deallocate(pps%Cflux )
deallocate(pps%XSCpool )
deallocate(pps%tday ) ! daily accumulated temperature (deg C)
deallocate(pps%tdayavg ) ! daily averaged temperature (deg C)
deallocate(pps%tcount ) ! counter for daily avg temp
deallocate(pps%degday ) ! accumulated degree days (deg C)
deallocate(pps%ndegday ) ! counter for number of degree days
deallocate(pps%stressT )
deallocate(pps%stressW ) ! water stress function for leaf loss
deallocate(pps%iseabeg ) ! index for start of growing season
deallocate(pps%nstepbeg ) ! nstep at start of growing season
deallocate(pps%lgrow ) ! growing season index (0 or 1) to be
! passed daily to CASA to get NPP
#if (defined CLAMP)
! Summary variables added for the C-LAMP Experiments
deallocate(pps%casa_agnpp )
deallocate(pps%casa_ar )
deallocate(pps%casa_bgnpp )
deallocate(pps%casa_cwdc )
deallocate(pps%casa_cwdc_hr )
deallocate(pps%casa_cwdc_loss )
deallocate(pps%casa_frootc )
deallocate(pps%casa_frootc_alloc )
deallocate(pps%casa_frootc_loss )
deallocate(pps%casa_gpp )
deallocate(pps%casa_hr )
deallocate(pps%casa_leafc )
deallocate(pps%casa_leafc_alloc )
deallocate(pps%casa_leafc_loss )
deallocate(pps%casa_litterc )
deallocate(pps%casa_litterc_hr )
deallocate(pps%casa_litterc_loss )
deallocate(pps%casa_nee )
deallocate(pps%casa_nep )
deallocate(pps%casa_npp )
deallocate(pps%casa_soilc )
deallocate(pps%casa_soilc_hr )
deallocate(pps%casa_soilc_loss )
deallocate(pps%casa_woodc )
deallocate(pps%casa_woodc_alloc )
deallocate(pps%casa_woodc_loss )
#endif
#endif
end subroutine dealloc_pft_pstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_epv_type
!
! !INTERFACE:
subroutine dealloc_pft_epv_type( pepv) 1
!
! !DESCRIPTION:
! Initialize pft ecophysiological variables
!
! !ARGUMENTS:
implicit none
type (pft_epv_type), intent(inout):: pepv
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
deallocate(pepv%dormant_flag )
deallocate(pepv%days_active )
deallocate(pepv%onset_flag )
deallocate(pepv%onset_counter )
deallocate(pepv%onset_gddflag )
deallocate(pepv%onset_fdd )
deallocate(pepv%onset_gdd )
deallocate(pepv%onset_swi )
deallocate(pepv%offset_flag )
deallocate(pepv%offset_counter )
deallocate(pepv%offset_fdd )
deallocate(pepv%offset_swi )
deallocate(pepv%lgsf )
deallocate(pepv%bglfr )
deallocate(pepv%bgtr )
deallocate(pepv%dayl )
deallocate(pepv%prev_dayl )
deallocate(pepv%annavg_t2m )
deallocate(pepv%tempavg_t2m )
deallocate(pepv%gpp )
deallocate(pepv%availc )
deallocate(pepv%xsmrpool_recover )
#if (defined C13)
deallocate(pepv%xsmrpool_c13ratio )
#endif
deallocate(pepv%alloc_pnow )
deallocate(pepv%c_allometry )
deallocate(pepv%n_allometry )
deallocate(pepv%plant_ndemand )
deallocate(pepv%tempsum_potential_gpp )
deallocate(pepv%annsum_potential_gpp )
deallocate(pepv%tempmax_retransn )
deallocate(pepv%annmax_retransn )
deallocate(pepv%avail_retransn )
deallocate(pepv%plant_nalloc )
deallocate(pepv%plant_calloc )
deallocate(pepv%excess_cflux )
deallocate(pepv%downreg )
deallocate(pepv%prev_leafc_to_litter )
deallocate(pepv%prev_frootc_to_litter )
deallocate(pepv%tempsum_npp )
deallocate(pepv%annsum_npp )
#if (defined CNDV)
deallocate(pepv%tempsum_litfall )
deallocate(pepv%annsum_litfall )
#endif
#if (defined C13)
! 4/21/05, PET
! Adding isotope code
deallocate(pepv%rc13_canair )
deallocate(pepv%rc13_psnsun )
deallocate(pepv%rc13_psnsha )
#endif
end subroutine dealloc_pft_epv_type
#if (defined CNDV) || (defined CROP)
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_pdgvstate_type
!
! !INTERFACE:
subroutine dealloc_pft_pdgvstate_type( pdgvs) 2
!
! !DESCRIPTION:
! Initialize pft DGVM state variables
!
! !ARGUMENTS:
implicit none
type (pft_dgvstate_type), intent(inout):: pdgvs
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(pdgvs%agddtw )
deallocate(pdgvs%agdd )
deallocate(pdgvs%t10 )
deallocate(pdgvs%t_mo )
deallocate(pdgvs%t_mo_min )
deallocate(pdgvs%prec365 )
deallocate(pdgvs%present )
deallocate(pdgvs%pftmayexist )
deallocate(pdgvs%nind )
deallocate(pdgvs%lm_ind )
deallocate(pdgvs%lai_ind )
deallocate(pdgvs%fpcinc )
deallocate(pdgvs%fpcgrid )
deallocate(pdgvs%fpcgridold )
deallocate(pdgvs%crownarea )
deallocate(pdgvs%greffic )
deallocate(pdgvs%heatstress )
end subroutine dealloc_pft_pdgvstate_type
#endif
!
! !IROUTINE: dealloc_pft_vstate_type
!
! !INTERFACE:
subroutine dealloc_pft_vstate_type( pvs) 1
!
! !DESCRIPTION:
! Initialize pft VOC variables
!
! !USES:
! !ARGUMENTS:
implicit none
type (pft_vstate_type), intent(inout):: pvs
!
! !REVISION HISTORY:
! Created by Erik Kluzek
!
!EOP
!------------------------------------------------------------------------
deallocate(pvs%t_veg24 )
deallocate(pvs%t_veg240 )
deallocate(pvs%fsd24 )
deallocate(pvs%fsd240 )
deallocate(pvs%fsi24 )
deallocate(pvs%fsi240 )
deallocate(pvs%fsun24 )
deallocate(pvs%fsun240 )
deallocate(pvs%elai_p )
end subroutine dealloc_pft_vstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_estate_type
!
! !INTERFACE:
subroutine dealloc_pft_estate_type( pes) 2
!
! !DESCRIPTION:
! Initialize pft energy state
!
! !ARGUMENTS:
implicit none
type (pft_estate_type), intent(inout):: pes
!
! !REVISION HISTORY:
deallocate(pes%t_ref2m )
deallocate(pes%t_ref2m_min )
deallocate(pes%t_ref2m_max )
deallocate(pes%t_ref2m_min_inst )
deallocate(pes%t_ref2m_max_inst )
deallocate(pes%q_ref2m )
deallocate(pes%t_ref2m_u )
deallocate(pes%t_ref2m_r )
deallocate(pes%t_ref2m_min_u )
deallocate(pes%t_ref2m_min_r )
deallocate(pes%t_ref2m_max_u )
deallocate(pes%t_ref2m_max_r )
deallocate(pes%t_ref2m_min_inst_u )
deallocate(pes%t_ref2m_min_inst_r )
deallocate(pes%t_ref2m_max_inst_u )
deallocate(pes%t_ref2m_max_inst_r )
deallocate(pes%rh_ref2m )
deallocate(pes%rh_ref2m_u )
deallocate(pes%rh_ref2m_r )
deallocate(pes%t_veg )
deallocate(pes%thm )
end subroutine dealloc_pft_estate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_wstate_type
!
! !INTERFACE:
subroutine dealloc_pft_wstate_type( pws) 2
!
! !DESCRIPTION:
! Initialize pft water state
!
! !ARGUMENTS:
implicit none
type (pft_wstate_type), intent(inout):: pws !pft water state
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(pws%h2ocan )
end subroutine dealloc_pft_wstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_cstate_type
!
! !INTERFACE:
subroutine dealloc_pft_cstate_type( pcs) 4
!
! !DESCRIPTION:
! Initialize pft carbon state
!
! !ARGUMENTS:
implicit none
type (pft_cstate_type), intent(inout):: pcs !pft carbon state
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
deallocate(pcs%leafc )
deallocate(pcs%leafc_storage )
deallocate(pcs%leafc_xfer )
deallocate(pcs%frootc )
deallocate(pcs%frootc_storage )
deallocate(pcs%frootc_xfer )
deallocate(pcs%livestemc )
deallocate(pcs%livestemc_storage )
deallocate(pcs%livestemc_xfer )
deallocate(pcs%deadstemc )
deallocate(pcs%deadstemc_storage )
deallocate(pcs%deadstemc_xfer )
deallocate(pcs%livecrootc )
deallocate(pcs%livecrootc_storage )
deallocate(pcs%livecrootc_xfer )
deallocate(pcs%deadcrootc )
deallocate(pcs%deadcrootc_storage )
deallocate(pcs%deadcrootc_xfer )
deallocate(pcs%gresp_storage )
deallocate(pcs%gresp_xfer )
deallocate(pcs%cpool )
deallocate(pcs%xsmrpool )
deallocate(pcs%pft_ctrunc )
deallocate(pcs%dispvegc )
deallocate(pcs%storvegc )
deallocate(pcs%totvegc )
deallocate(pcs%totpftc )
deallocate(pcs%leafcmax )
#if (defined CROP)
deallocate(pcs%grainc )
deallocate(pcs%grainc_storage )
deallocate(pcs%grainc_xfer )
#endif
#if (defined CLAMP) && (defined CN)
!CLAMP
deallocate(pcs%woodc )
#endif
end subroutine dealloc_pft_cstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_nstate_type
!
! !INTERFACE:
subroutine dealloc_pft_nstate_type( pns) 2
!
! !DESCRIPTION:
! Initialize pft nitrogen state
!
! !ARGUMENTS:
implicit none
type (pft_nstate_type), intent(inout):: pns !pft nitrogen state
!
! !REVISION HISTORY:
! Created by Peter Thornton
#if (defined CROP)
deallocate(pns%grainn )
deallocate(pns%grainn_storage )
deallocate(pns%grainn_xfer )
#endif
deallocate(pns%leafn )
deallocate(pns%leafn_storage )
deallocate(pns%leafn_xfer )
deallocate(pns%frootn )
deallocate(pns%frootn_storage )
deallocate(pns%frootn_xfer )
deallocate(pns%livestemn )
deallocate(pns%livestemn_storage )
deallocate(pns%livestemn_xfer )
deallocate(pns%deadstemn )
deallocate(pns%deadstemn_storage )
deallocate(pns%deadstemn_xfer )
deallocate(pns%livecrootn )
deallocate(pns%livecrootn_storage )
deallocate(pns%livecrootn_xfer )
deallocate(pns%deadcrootn )
deallocate(pns%deadcrootn_storage )
deallocate(pns%deadcrootn_xfer )
deallocate(pns%retransn )
deallocate(pns%npool )
deallocate(pns%pft_ntrunc )
deallocate(pns%dispvegn )
deallocate(pns%storvegn )
deallocate(pns%totvegn )
deallocate(pns%totpftn )
end subroutine dealloc_pft_nstate_type
! !IROUTINE: dealloc_pft_eflux_type
!
! !INTERFACE:
subroutine dealloc_pft_eflux_type( pef) 2
!
! !DESCRIPTION:
! Initialize pft energy flux variables
!
! !ARGUMENTS:
implicit none
type (pft_eflux_type), intent(inout):: pef
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(pef%sabg )
deallocate(pef%sabv )
deallocate(pef%fsa )
deallocate(pef%fsa_u )
deallocate(pef%fsa_r )
deallocate(pef%fsr )
deallocate(pef%parsun )
deallocate(pef%parsha )
deallocate(pef%dlrad )
deallocate(pef%ulrad )
deallocate(pef%eflx_lh_tot )
deallocate(pef%eflx_lh_tot_u )
deallocate(pef%eflx_lh_tot_r )
deallocate(pef%eflx_lh_grnd )
deallocate(pef%eflx_soil_grnd )
deallocate(pef%eflx_soil_grnd_u )
deallocate(pef%eflx_soil_grnd_r )
deallocate(pef%eflx_sh_tot )
deallocate(pef%eflx_sh_tot_u )
deallocate(pef%eflx_sh_tot_r )
deallocate(pef%eflx_sh_grnd )
deallocate(pef%eflx_sh_veg )
deallocate(pef%eflx_lh_vege )
deallocate(pef%eflx_lh_vegt )
deallocate(pef%eflx_wasteheat_pft )
deallocate(pef%eflx_heat_from_ac_pft )
deallocate(pef%eflx_traffic_pft )
deallocate(pef%eflx_anthro )
deallocate(pef%cgrnd )
deallocate(pef%cgrndl )
deallocate(pef%cgrnds )
deallocate(pef%eflx_gnet )
deallocate(pef%dgnetdT )
deallocate(pef%eflx_lwrad_out )
deallocate(pef%eflx_lwrad_net )
deallocate(pef%eflx_lwrad_net_u )
deallocate(pef%eflx_lwrad_net_r )
deallocate(pef%netrad )
deallocate(pef%fsds_vis_d )
deallocate(pef%fsds_nir_d )
deallocate(pef%fsds_vis_i )
deallocate(pef%fsds_nir_i )
deallocate(pef%fsr_vis_d )
deallocate(pef%fsr_nir_d )
deallocate(pef%fsr_vis_i )
deallocate(pef%fsr_nir_i )
deallocate(pef%fsds_vis_d_ln )
deallocate(pef%fsds_nir_d_ln )
deallocate(pef%fsr_vis_d_ln )
deallocate(pef%fsr_nir_d_ln )
deallocate(pef%sun_add )
deallocate(pef%tot_aid )
deallocate(pef%sun_aid )
deallocate(pef%sun_aii )
deallocate(pef%sha_aid )
deallocate(pef%sha_aii )
deallocate(pef%sun_atot )
deallocate(pef%sha_atot )
deallocate(pef%sun_alf )
deallocate(pef%sha_alf )
deallocate(pef%sun_aperlai )
deallocate(pef%sha_aperlai )
deallocate(pef%sabg_lyr)
deallocate(pef%sfc_frc_aer )
deallocate(pef%sfc_frc_bc )
deallocate(pef%sfc_frc_oc )
deallocate(pef%sfc_frc_dst )
deallocate(pef%sfc_frc_aer_sno )
deallocate(pef%sfc_frc_bc_sno )
deallocate(pef%sfc_frc_oc_sno )
deallocate(pef%sfc_frc_dst_sno )
deallocate(pef%fsr_sno_vd )
deallocate(pef%fsr_sno_nd )
deallocate(pef%fsr_sno_vi )
deallocate(pef%fsr_sno_ni )
deallocate(pef%fsds_sno_vd )
deallocate(pef%fsds_sno_nd )
deallocate(pef%fsds_sno_vi )
deallocate(pef%fsds_sno_ni )
end subroutine dealloc_pft_eflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_mflux_type
!
! !INTERFACE:
subroutine dealloc_pft_mflux_type( pmf) 2
!
! !DESCRIPTION:
! Initialize pft momentum flux variables
!
! !ARGUMENTS:
implicit none
type (pft_mflux_type), intent(inout) :: pmf
deallocate(pmf%taux )
deallocate(pmf%tauy )
end subroutine dealloc_pft_mflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_wflux_type
!
! !INTERFACE:
subroutine dealloc_pft_wflux_type( pwf) 2
!
! !DESCRIPTION:
! Initialize pft water flux variables
!
! !ARGUMENTS:
implicit none
type (pft_wflux_type), intent(inout) :: pwf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(pwf%qflx_prec_intr )
deallocate(pwf%qflx_prec_grnd )
deallocate(pwf%qflx_rain_grnd )
deallocate(pwf%qflx_snow_grnd )
deallocate(pwf%qflx_snwcp_liq )
deallocate(pwf%qflx_snwcp_ice )
deallocate(pwf%qflx_evap_veg )
deallocate(pwf%qflx_tran_veg )
deallocate(pwf%qflx_evap_can )
deallocate(pwf%qflx_evap_soi )
deallocate(pwf%qflx_evap_tot )
deallocate(pwf%qflx_evap_grnd )
deallocate(pwf%qflx_dew_grnd )
deallocate(pwf%qflx_sub_snow )
deallocate(pwf%qflx_dew_snow )
end subroutine dealloc_pft_wflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_cflux_type
!
! !INTERFACE:
subroutine dealloc_pft_cflux_type( pcf) 4
!
! !DESCRIPTION:
! Initialize pft carbon flux variables
!
! !ARGUMENTS:
implicit none
type (pft_cflux_type), intent(inout) :: pcf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(pcf%psnsun )
deallocate(pcf%psnsha )
deallocate(pcf%fpsn )
deallocate(pcf%fco2 )
deallocate(pcf%m_leafc_to_litter )
deallocate(pcf%m_frootc_to_litter )
deallocate(pcf%m_leafc_storage_to_litter )
deallocate(pcf%m_frootc_storage_to_litter )
deallocate(pcf%m_livestemc_storage_to_litter )
deallocate(pcf%m_deadstemc_storage_to_litter )
deallocate(pcf%m_livecrootc_storage_to_litter )
deallocate(pcf%m_deadcrootc_storage_to_litter )
deallocate(pcf%m_leafc_xfer_to_litter )
deallocate(pcf%m_frootc_xfer_to_litter )
deallocate(pcf%m_livestemc_xfer_to_litter )
deallocate(pcf%m_deadstemc_xfer_to_litter )
deallocate(pcf%m_livecrootc_xfer_to_litter )
deallocate(pcf%m_deadcrootc_xfer_to_litter )
deallocate(pcf%m_livestemc_to_litter )
deallocate(pcf%m_deadstemc_to_litter )
deallocate(pcf%m_livecrootc_to_litter )
deallocate(pcf%m_deadcrootc_to_litter )
deallocate(pcf%m_gresp_storage_to_litter )
deallocate(pcf%m_gresp_xfer_to_litter )
deallocate(pcf%hrv_leafc_to_litter )
deallocate(pcf%hrv_leafc_storage_to_litter )
deallocate(pcf%hrv_leafc_xfer_to_litter )
deallocate(pcf%hrv_frootc_to_litter )
deallocate(pcf%hrv_frootc_storage_to_litter )
deallocate(pcf%hrv_frootc_xfer_to_litter )
deallocate(pcf%hrv_livestemc_to_litter )
deallocate(pcf%hrv_livestemc_storage_to_litter )
deallocate(pcf%hrv_livestemc_xfer_to_litter )
deallocate(pcf%hrv_deadstemc_to_prod10c )
deallocate(pcf%hrv_deadstemc_to_prod100c )
deallocate(pcf%hrv_deadstemc_storage_to_litter )
deallocate(pcf%hrv_deadstemc_xfer_to_litter )
deallocate(pcf%hrv_livecrootc_to_litter )
deallocate(pcf%hrv_livecrootc_storage_to_litter )
deallocate(pcf%hrv_livecrootc_xfer_to_litter )
deallocate(pcf%hrv_deadcrootc_to_litter )
deallocate(pcf%hrv_deadcrootc_storage_to_litter )
deallocate(pcf%hrv_deadcrootc_xfer_to_litter )
deallocate(pcf%hrv_gresp_storage_to_litter )
deallocate(pcf%hrv_gresp_xfer_to_litter )
deallocate(pcf%hrv_xsmrpool_to_atm )
deallocate(pcf%m_leafc_to_fire )
deallocate(pcf%m_frootc_to_fire )
deallocate(pcf%m_leafc_storage_to_fire )
deallocate(pcf%m_frootc_storage_to_fire )
deallocate(pcf%m_livestemc_storage_to_fire )
deallocate(pcf%m_deadstemc_storage_to_fire )
deallocate(pcf%m_livecrootc_storage_to_fire )
deallocate(pcf%m_deadcrootc_storage_to_fire )
deallocate(pcf%m_leafc_xfer_to_fire )
deallocate(pcf%m_frootc_xfer_to_fire )
deallocate(pcf%m_livestemc_xfer_to_fire )
deallocate(pcf%m_deadstemc_xfer_to_fire )
deallocate(pcf%m_livecrootc_xfer_to_fire )
deallocate(pcf%m_deadcrootc_xfer_to_fire )
deallocate(pcf%m_livestemc_to_fire )
deallocate(pcf%m_deadstemc_to_fire )
deallocate(pcf%m_deadstemc_to_litter_fire )
deallocate(pcf%m_livecrootc_to_fire )
deallocate(pcf%m_deadcrootc_to_fire )
deallocate(pcf%m_deadcrootc_to_litter_fire )
deallocate(pcf%m_gresp_storage_to_fire )
deallocate(pcf%m_gresp_xfer_to_fire )
deallocate(pcf%leafc_xfer_to_leafc )
deallocate(pcf%frootc_xfer_to_frootc )
deallocate(pcf%livestemc_xfer_to_livestemc )
deallocate(pcf%deadstemc_xfer_to_deadstemc )
deallocate(pcf%livecrootc_xfer_to_livecrootc )
deallocate(pcf%deadcrootc_xfer_to_deadcrootc )
deallocate(pcf%leafc_to_litter )
deallocate(pcf%frootc_to_litter )
deallocate(pcf%leaf_mr )
deallocate(pcf%froot_mr )
deallocate(pcf%livestem_mr )
deallocate(pcf%livecroot_mr )
deallocate(pcf%leaf_curmr )
deallocate(pcf%froot_curmr )
deallocate(pcf%livestem_curmr )
deallocate(pcf%livecroot_curmr )
deallocate(pcf%leaf_xsmr )
deallocate(pcf%froot_xsmr )
deallocate(pcf%livestem_xsmr )
deallocate(pcf%livecroot_xsmr )
deallocate(pcf%psnsun_to_cpool )
deallocate(pcf%psnshade_to_cpool )
deallocate(pcf%cpool_to_xsmrpool )
deallocate(pcf%cpool_to_leafc )
deallocate(pcf%cpool_to_leafc_storage )
deallocate(pcf%cpool_to_frootc )
deallocate(pcf%cpool_to_frootc_storage )
deallocate(pcf%cpool_to_livestemc )
deallocate(pcf%cpool_to_livestemc_storage )
deallocate(pcf%cpool_to_deadstemc )
deallocate(pcf%cpool_to_deadstemc_storage )
deallocate(pcf%cpool_to_livecrootc )
deallocate(pcf%cpool_to_livecrootc_storage )
deallocate(pcf%cpool_to_deadcrootc )
deallocate(pcf%cpool_to_deadcrootc_storage )
deallocate(pcf%cpool_to_gresp_storage )
deallocate(pcf%cpool_leaf_gr )
deallocate(pcf%cpool_leaf_storage_gr )
deallocate(pcf%transfer_leaf_gr )
deallocate(pcf%cpool_froot_gr )
deallocate(pcf%cpool_froot_storage_gr )
deallocate(pcf%transfer_froot_gr )
deallocate(pcf%cpool_livestem_gr )
deallocate(pcf%cpool_livestem_storage_gr )
deallocate(pcf%transfer_livestem_gr )
deallocate(pcf%cpool_deadstem_gr )
deallocate(pcf%cpool_deadstem_storage_gr )
deallocate(pcf%transfer_deadstem_gr )
deallocate(pcf%cpool_livecroot_gr )
deallocate(pcf%cpool_livecroot_storage_gr )
deallocate(pcf%transfer_livecroot_gr )
deallocate(pcf%cpool_deadcroot_gr )
deallocate(pcf%cpool_deadcroot_storage_gr )
deallocate(pcf%transfer_deadcroot_gr )
deallocate(pcf%leafc_storage_to_xfer )
deallocate(pcf%frootc_storage_to_xfer )
deallocate(pcf%livestemc_storage_to_xfer )
deallocate(pcf%deadstemc_storage_to_xfer )
deallocate(pcf%livecrootc_storage_to_xfer )
deallocate(pcf%deadcrootc_storage_to_xfer )
deallocate(pcf%gresp_storage_to_xfer )
deallocate(pcf%livestemc_to_deadstemc )
deallocate(pcf%livecrootc_to_deadcrootc )
deallocate(pcf%gpp )
deallocate(pcf%mr )
deallocate(pcf%current_gr )
deallocate(pcf%transfer_gr )
deallocate(pcf%storage_gr )
deallocate(pcf%gr )
deallocate(pcf%ar )
deallocate(pcf%rr )
deallocate(pcf%npp )
deallocate(pcf%agnpp )
deallocate(pcf%bgnpp )
deallocate(pcf%litfall )
deallocate(pcf%vegfire )
deallocate(pcf%wood_harvestc )
deallocate(pcf%pft_cinputs )
deallocate(pcf%pft_coutputs )
deallocate(pcf%pft_fire_closs )
#if (defined CROP)
deallocate(pcf%xsmrpool_to_atm )
deallocate(pcf%grainc_xfer_to_grainc )
deallocate(pcf%livestemc_to_litter )
deallocate(pcf%grainc_to_food )
deallocate(pcf%cpool_to_grainc )
deallocate(pcf%cpool_to_grainc_storage )
deallocate(pcf%cpool_grain_gr )
deallocate(pcf%cpool_grain_storage_gr )
deallocate(pcf%transfer_grain_gr )
deallocate(pcf%grainc_storage_to_xfer )
#endif
#if (defined CLAMP) && (defined CN)
!CLAMP
deallocate(pcf%frootc_alloc )
deallocate(pcf%frootc_loss )
deallocate(pcf%leafc_alloc )
deallocate(pcf%leafc_loss )
deallocate(pcf%woodc_alloc )
deallocate(pcf%woodc_loss )
#endif
end subroutine dealloc_pft_cflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_nflux_type
!
! !INTERFACE:
subroutine dealloc_pft_nflux_type( pnf) 2
!
! !DESCRIPTION:
! Initialize pft nitrogen flux variables
!
! !ARGUMENTS:
implicit none
type (pft_nflux_type), intent(inout) :: pnf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(pnf%m_leafn_to_litter )
deallocate(pnf%m_frootn_to_litter )
deallocate(pnf%m_leafn_storage_to_litter )
deallocate(pnf%m_frootn_storage_to_litter )
deallocate(pnf%m_livestemn_storage_to_litter )
deallocate(pnf%m_deadstemn_storage_to_litter )
deallocate(pnf%m_livecrootn_storage_to_litter )
deallocate(pnf%m_deadcrootn_storage_to_litter )
deallocate(pnf%m_leafn_xfer_to_litter )
deallocate(pnf%m_frootn_xfer_to_litter )
deallocate(pnf%m_livestemn_xfer_to_litter )
deallocate(pnf%m_deadstemn_xfer_to_litter )
deallocate(pnf%m_livecrootn_xfer_to_litter )
deallocate(pnf%m_deadcrootn_xfer_to_litter )
deallocate(pnf%m_livestemn_to_litter )
deallocate(pnf%m_deadstemn_to_litter )
deallocate(pnf%m_livecrootn_to_litter )
deallocate(pnf%m_deadcrootn_to_litter )
deallocate(pnf%m_retransn_to_litter )
deallocate(pnf%hrv_leafn_to_litter )
deallocate(pnf%hrv_frootn_to_litter )
deallocate(pnf%hrv_leafn_storage_to_litter )
deallocate(pnf%hrv_frootn_storage_to_litter )
deallocate(pnf%hrv_livestemn_storage_to_litter )
deallocate(pnf%hrv_deadstemn_storage_to_litter )
deallocate(pnf%hrv_livecrootn_storage_to_litter )
deallocate(pnf%hrv_deadcrootn_storage_to_litter )
deallocate(pnf%hrv_leafn_xfer_to_litter )
deallocate(pnf%hrv_frootn_xfer_to_litter )
deallocate(pnf%hrv_livestemn_xfer_to_litter )
deallocate(pnf%hrv_deadstemn_xfer_to_litter )
deallocate(pnf%hrv_livecrootn_xfer_to_litter )
deallocate(pnf%hrv_deadcrootn_xfer_to_litter )
deallocate(pnf%hrv_livestemn_to_litter )
deallocate(pnf%hrv_deadstemn_to_prod10n )
deallocate(pnf%hrv_deadstemn_to_prod100n )
deallocate(pnf%hrv_livecrootn_to_litter )
deallocate(pnf%hrv_deadcrootn_to_litter )
deallocate(pnf%hrv_retransn_to_litter )
deallocate(pnf%m_leafn_to_fire )
deallocate(pnf%m_frootn_to_fire )
deallocate(pnf%m_leafn_storage_to_fire )
deallocate(pnf%m_frootn_storage_to_fire )
deallocate(pnf%m_livestemn_storage_to_fire )
deallocate(pnf%m_deadstemn_storage_to_fire )
deallocate(pnf%m_livecrootn_storage_to_fire )
deallocate(pnf%m_deadcrootn_storage_to_fire )
deallocate(pnf%m_leafn_xfer_to_fire )
deallocate(pnf%m_frootn_xfer_to_fire )
deallocate(pnf%m_livestemn_xfer_to_fire )
deallocate(pnf%m_deadstemn_xfer_to_fire )
deallocate(pnf%m_livecrootn_xfer_to_fire )
deallocate(pnf%m_deadcrootn_xfer_to_fire )
deallocate(pnf%m_livestemn_to_fire )
deallocate(pnf%m_deadstemn_to_fire )
deallocate(pnf%m_deadstemn_to_litter_fire )
deallocate(pnf%m_livecrootn_to_fire )
deallocate(pnf%m_deadcrootn_to_fire )
deallocate(pnf%m_deadcrootn_to_litter_fire )
deallocate(pnf%m_retransn_to_fire )
deallocate(pnf%leafn_xfer_to_leafn )
deallocate(pnf%frootn_xfer_to_frootn )
deallocate(pnf%livestemn_xfer_to_livestemn )
deallocate(pnf%deadstemn_xfer_to_deadstemn )
deallocate(pnf%livecrootn_xfer_to_livecrootn )
deallocate(pnf%deadcrootn_xfer_to_deadcrootn )
deallocate(pnf%leafn_to_litter )
deallocate(pnf%leafn_to_retransn )
deallocate(pnf%frootn_to_litter )
deallocate(pnf%retransn_to_npool )
deallocate(pnf%sminn_to_npool )
deallocate(pnf%npool_to_leafn )
deallocate(pnf%npool_to_leafn_storage )
deallocate(pnf%npool_to_frootn )
deallocate(pnf%npool_to_frootn_storage )
deallocate(pnf%npool_to_livestemn )
deallocate(pnf%npool_to_livestemn_storage )
deallocate(pnf%npool_to_deadstemn )
deallocate(pnf%npool_to_deadstemn_storage )
deallocate(pnf%npool_to_livecrootn )
deallocate(pnf%npool_to_livecrootn_storage )
deallocate(pnf%npool_to_deadcrootn )
deallocate(pnf%npool_to_deadcrootn_storage )
deallocate(pnf%leafn_storage_to_xfer )
deallocate(pnf%frootn_storage_to_xfer )
deallocate(pnf%livestemn_storage_to_xfer )
deallocate(pnf%deadstemn_storage_to_xfer )
deallocate(pnf%livecrootn_storage_to_xfer )
deallocate(pnf%deadcrootn_storage_to_xfer )
deallocate(pnf%livestemn_to_deadstemn )
deallocate(pnf%livestemn_to_retransn )
deallocate(pnf%livecrootn_to_deadcrootn )
deallocate(pnf%livecrootn_to_retransn )
deallocate(pnf%ndeploy )
deallocate(pnf%pft_ninputs )
deallocate(pnf%pft_noutputs )
deallocate(pnf%wood_harvestn )
deallocate(pnf%pft_fire_nloss )
#if (defined CROP)
deallocate(pnf%grainn_xfer_to_grainn )
deallocate(pnf%livestemn_to_litter )
deallocate(pnf%grainn_to_food )
deallocate(pnf%npool_to_grainn )
deallocate(pnf%npool_to_grainn_storage )
deallocate(pnf%grainn_storage_to_xfer )
#endif
end subroutine dealloc_pft_nflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_vflux_type
!
! !INTERFACE:
subroutine dealloc_pft_vflux_type( pvf) 2
!
! !DESCRIPTION:
! Initialize pft VOC flux variables
!
! !ARGUMENTS:
implicit none
type (pft_vflux_type), intent(inout) :: pvf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! (heald, 08/06)
!
!EOP
!------------------------------------------------------------------------
deallocate(pvf%vocflx_tot )
deallocate(pvf%vocflx)
deallocate(pvf%vocflx_1 )
deallocate(pvf%vocflx_2 )
deallocate(pvf%vocflx_3 )
deallocate(pvf%vocflx_4 )
deallocate(pvf%vocflx_5 )
deallocate(pvf%Eopt_out )
deallocate(pvf%topt_out )
deallocate(pvf%alpha_out )
deallocate(pvf%cp_out )
deallocate(pvf%para_out )
deallocate(pvf%par24a_out )
deallocate(pvf%par240a_out )
deallocate(pvf%paru_out )
deallocate(pvf%par24u_out )
deallocate(pvf%par240u_out )
deallocate(pvf%gamma_out )
deallocate(pvf%gammaL_out )
deallocate(pvf%gammaT_out )
deallocate(pvf%gammaP_out )
deallocate(pvf%gammaA_out )
deallocate(pvf%gammaS_out )
end subroutine dealloc_pft_vflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_pft_dflux_type
!
! !INTERFACE:
subroutine dealloc_pft_dflux_type( pdf) 2
!
! !DESCRIPTION:
! Initialize pft dust flux variables
!
! !ARGUMENTS:
implicit none
type (pft_dflux_type), intent(inout):: pdf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(pdf%flx_mss_vrt_dst)
deallocate(pdf%flx_mss_vrt_dst_tot )
deallocate(pdf%vlc_trb)
deallocate(pdf%vlc_trb_1 )
deallocate(pdf%vlc_trb_2 )
deallocate(pdf%vlc_trb_3 )
deallocate(pdf%vlc_trb_4 )
end subroutine dealloc_pft_dflux_type
subroutine dealloc_pft_depvd_type( pdd) 1
!
! !DESCRIPTION:
! Initialize pft dep velocity variables
!
! !ARGUMENTS:
implicit none
type (pft_depvd_type), intent(inout):: pdd
!
! !REVISION HISTORY:
! Created by James Sulzman 541-929-6183
!
!EOP
!------------------------------------------------------------------------
! if (allocated(pdd%drydepvel)) deallocate(pdd%drydepvel)
end subroutine dealloc_pft_depvd_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_column_pstate_type
!
! !INTERFACE:
subroutine dealloc_column_pstate_type( cps) 4
!
! !DESCRIPTION:
! Initialize column physical state variables
!
! !USES:
! !ARGUMENTS:
implicit none
type (column_pstate_type), intent(inout):: cps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(cps%snl ) !* cannot be averaged up
deallocate(cps%isoicol ) !* cannot be averaged up
deallocate(cps%bsw)
deallocate(cps%watsat)
deallocate(cps%watfc)
deallocate(cps%watdry)
deallocate(cps%watopt)
deallocate(cps%hksat)
deallocate(cps%sucsat)
deallocate(cps%csol)
deallocate(cps%tkmg)
deallocate(cps%tkdry)
deallocate(cps%tksatu)
deallocate(cps%smpmin )
deallocate(cps%hkdepth )
deallocate(cps%wtfact )
deallocate(cps%fracice)
deallocate(cps%gwc_thr )
deallocate(cps%mss_frc_cly_vld )
deallocate(cps%mbl_bsn_fct )
deallocate(cps%do_capsnow )
deallocate(cps%snowdp )
deallocate(cps%frac_sno )
deallocate(cps%zi)
deallocate(cps%dz)
deallocate(cps%z )
deallocate(cps%frac_iceold)
deallocate(cps%imelt)
deallocate(cps%eff_porosity)
deallocate(cps%emg )
deallocate(cps%z0mg )
deallocate(cps%z0hg )
deallocate(cps%z0qg )
deallocate(cps%htvp )
deallocate(cps%beta )
deallocate(cps%zii )
deallocate(cps%albgrd)
deallocate(cps%albgri)
deallocate(cps%rootr_column)
deallocate(cps%rootfr_road_perv)
deallocate(cps%rootr_road_perv)
deallocate(cps%wf )
! deallocate(cps%xirrig )
deallocate(cps%max_dayl )
deallocate(cps%bsw2)
deallocate(cps%psisat)
deallocate(cps%vwcsat)
deallocate(cps%soilpsi)
deallocate(cps%decl )
deallocate(cps%coszen )
deallocate(cps%fpi )
deallocate(cps%fpg )
deallocate(cps%annsum_counter )
deallocate(cps%cannsum_npp )
deallocate(cps%cannavg_t2m )
deallocate(cps%me )
deallocate(cps%fire_prob )
deallocate(cps%mean_fire_prob )
deallocate(cps%fireseasonl )
deallocate(cps%farea_burned )
deallocate(cps%ann_farea_burned )
deallocate(cps%albsnd_hst)
deallocate(cps%albsni_hst)
deallocate(cps%albsod)
deallocate(cps%albsoi)
deallocate(cps%flx_absdv)
deallocate(cps%flx_absdn)
deallocate(cps%flx_absiv )
deallocate(cps%flx_absin )
deallocate(cps%snw_rds )
deallocate(cps%snw_rds_top )
deallocate(cps%sno_liq_top )
deallocate(cps%mss_bcpho )
deallocate(cps%mss_bcphi )
deallocate(cps%mss_bctot )
deallocate(cps%mss_bc_col )
deallocate(cps%mss_bc_top )
deallocate(cps%mss_ocpho )
deallocate(cps%mss_ocphi )
deallocate(cps%mss_octot )
deallocate(cps%mss_oc_col )
deallocate(cps%mss_oc_top )
deallocate(cps%mss_dst1 )
deallocate(cps%mss_dst2 )
deallocate(cps%mss_dst3 )
deallocate(cps%mss_dst4 )
deallocate(cps%mss_dsttot )
deallocate(cps%mss_dst_col )
deallocate(cps%mss_dst_top )
deallocate(cps%h2osno_top )
deallocate(cps%mss_cnc_bcphi )
deallocate(cps%mss_cnc_bcpho )
deallocate(cps%mss_cnc_ocphi )
deallocate(cps%mss_cnc_ocpho )
deallocate(cps%mss_cnc_dst1 )
deallocate(cps%mss_cnc_dst2 )
deallocate(cps%mss_cnc_dst3 )
deallocate(cps%mss_cnc_dst4 )
deallocate(cps%albgrd_pur )
deallocate(cps%albgri_pur )
deallocate(cps%albgrd_bc )
deallocate(cps%albgri_bc )
deallocate(cps%albgrd_oc )
deallocate(cps%albgri_oc )
deallocate(cps%albgrd_dst )
deallocate(cps%albgri_dst )
deallocate(cps%dTdz_top )
deallocate(cps%snot_top )
end subroutine dealloc_column_pstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_column_estate_type
!
! !INTERFACE:
subroutine dealloc_column_estate_type( ces) 4
!
! !DESCRIPTION:
! Initialize column energy state variables
!
! !USES:
! !ARGUMENTS:
implicit none
type (column_estate_type), intent(inout):: ces
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(ces%t_grnd )
deallocate(ces%t_grnd_u )
deallocate(ces%t_grnd_r )
deallocate(ces%dt_grnd )
deallocate(ces%t_soisno)
deallocate(ces%t_soi_10cm )
deallocate(ces%t_lake)
deallocate(ces%tssbef)
deallocate(ces%thv )
deallocate(ces%hc_soi )
deallocate(ces%hc_soisno )
end subroutine dealloc_column_estate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_column_wstate_type
!
! !INTERFACE:
subroutine dealloc_column_wstate_type( cws) 4
!
! !USES:
! !ARGUMENTS:
implicit none
type (column_wstate_type), intent(inout):: cws !column water state
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(cws%h2osno )
deallocate(cws%h2osoi_liq)
deallocate(cws%h2osoi_ice)
deallocate(cws%h2osoi_liqice_10cm )
deallocate(cws%h2osoi_vol )
deallocate(cws%h2osno_old )
deallocate(cws%qg )
deallocate(cws%dqgdT )
deallocate(cws%snowice )
deallocate(cws%snowliq )
deallocate(cws%soilalpha )
deallocate(cws%soilbeta )
deallocate(cws%soilalpha_u )
deallocate(cws%zwt )
deallocate(cws%fcov )
deallocate(cws%fsat )
deallocate(cws%wa )
deallocate(cws%wt )
deallocate(cws%qcharge )
deallocate(cws%smp_l )
deallocate(cws%hk_l )
end subroutine dealloc_column_wstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_column_cstate_type
!
! !INTERFACE:
subroutine dealloc_column_cstate_type( ccs) 5
! !DESCRIPTION:
! Initialize column carbon state variables
!
! !ARGUMENTS:
implicit none
type (column_cstate_type), intent(inout):: ccs
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(ccs%soilc )
deallocate(ccs%cwdc )
deallocate(ccs%litr1c )
deallocate(ccs%litr2c )
deallocate(ccs%litr3c )
deallocate(ccs%soil1c )
deallocate(ccs%soil2c )
deallocate(ccs%soil3c )
deallocate(ccs%soil4c )
deallocate(ccs%seedc )
deallocate(ccs%col_ctrunc )
deallocate(ccs%prod10c )
deallocate(ccs%prod100c )
deallocate(ccs%totprodc )
deallocate(ccs%totlitc )
deallocate(ccs%totsomc )
deallocate(ccs%totecosysc )
deallocate(ccs%totcolc )
end subroutine dealloc_column_cstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_column_nstate_type
!
! !INTERFACE:
subroutine dealloc_column_nstate_type( cns) 4
!
! !DESCRIPTION:
! Initialize column nitrogen state variables
!
! !ARGUMENTS:
implicit none
type (column_nstate_type), intent(inout):: cns
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
deallocate(cns%cwdn )
deallocate(cns%litr1n )
deallocate(cns%litr2n )
deallocate(cns%litr3n )
deallocate(cns%soil1n )
deallocate(cns%soil2n )
deallocate(cns%soil3n )
deallocate(cns%soil4n )
deallocate(cns%sminn )
deallocate(cns%col_ntrunc )
deallocate(cns%seedn )
deallocate(cns%prod10n )
deallocate(cns%prod100n )
deallocate(cns%totprodn )
deallocate(cns%totlitn )
deallocate(cns%totsomn )
deallocate(cns%totecosysn )
deallocate(cns%totcoln )
end subroutine dealloc_column_nstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_column_eflux_type
!
! !INTERFACE:
subroutine dealloc_column_eflux_type( cef) 4
!
! !DESCRIPTION:
! Initialize column energy flux variables
!
! !ARGUMENTS:
implicit none
type (column_eflux_type), intent(inout):: cef
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(cef%eflx_snomelt )
deallocate(cef%eflx_snomelt_u )
deallocate(cef%eflx_snomelt_r )
deallocate(cef%eflx_impsoil )
deallocate(cef%eflx_fgr12 )
deallocate(cef%eflx_building_heat )
deallocate(cef%eflx_urban_ac )
deallocate(cef%eflx_urban_heat )
end subroutine dealloc_column_eflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_column_wflux_type
!
! !INTERFACE:
subroutine dealloc_column_wflux_type( cwf) 4
!
! !DESCRIPTION:
! Initialize column water flux variables
!
! !USES:
! !ARGUMENTS:
implicit none
type (column_wflux_type), intent(inout):: cwf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(cwf%qflx_infl )
deallocate(cwf%qflx_surf )
deallocate(cwf%qflx_drain )
deallocate(cwf%qflx_top_soil )
deallocate(cwf%qflx_snomelt )
deallocate(cwf%qflx_qrgwl )
deallocate(cwf%qflx_runoff )
deallocate(cwf%qflx_runoff_u )
deallocate(cwf%qflx_runoff_r )
deallocate(cwf%qmelt )
deallocate(cwf%h2ocan_loss )
deallocate(cwf%qflx_rsub_sat )
deallocate(cwf%flx_bc_dep_dry )
deallocate(cwf%flx_bc_dep_wet )
deallocate(cwf%flx_bc_dep_pho )
deallocate(cwf%flx_bc_dep_phi )
deallocate(cwf%flx_bc_dep )
deallocate(cwf%flx_oc_dep_dry )
deallocate(cwf%flx_oc_dep_wet )
deallocate(cwf%flx_oc_dep_pho )
deallocate(cwf%flx_oc_dep_phi )
deallocate(cwf%flx_oc_dep )
deallocate(cwf%flx_dst_dep_dry1 )
deallocate(cwf%flx_dst_dep_wet1 )
deallocate(cwf%flx_dst_dep_dry2 )
deallocate(cwf%flx_dst_dep_wet2 )
deallocate(cwf%flx_dst_dep_dry3 )
deallocate(cwf%flx_dst_dep_wet3 )
deallocate(cwf%flx_dst_dep_dry4 )
deallocate(cwf%flx_dst_dep_wet4 )
deallocate(cwf%flx_dst_dep )
deallocate(cwf%qflx_snofrz_lyr)
end subroutine dealloc_column_wflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_column_cflux_type
!
! !INTERFACE:
subroutine dealloc_column_cflux_type( ccf) 2
!
! !DESCRIPTION:
! Initialize column carbon flux variables
!
! !ARGUMENTS:
implicit none
type (column_cflux_type), intent(inout):: ccf
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
deallocate(ccf%m_leafc_to_litr1c )
deallocate(ccf%m_leafc_to_litr2c )
deallocate(ccf%m_leafc_to_litr3c )
deallocate(ccf%m_frootc_to_litr1c )
deallocate(ccf%m_frootc_to_litr2c )
deallocate(ccf%m_frootc_to_litr3c )
deallocate(ccf%m_leafc_storage_to_litr1c )
deallocate(ccf%m_frootc_storage_to_litr1c )
deallocate(ccf%m_livestemc_storage_to_litr1c )
deallocate(ccf%m_deadstemc_storage_to_litr1c )
deallocate(ccf%m_livecrootc_storage_to_litr1c )
deallocate(ccf%m_deadcrootc_storage_to_litr1c )
deallocate(ccf%m_leafc_xfer_to_litr1c )
deallocate(ccf%m_frootc_xfer_to_litr1c )
deallocate(ccf%m_livestemc_xfer_to_litr1c )
deallocate(ccf%m_deadstemc_xfer_to_litr1c )
deallocate(ccf%m_livecrootc_xfer_to_litr1c )
deallocate(ccf%m_deadcrootc_xfer_to_litr1c )
deallocate(ccf%m_livestemc_to_cwdc )
deallocate(ccf%m_deadstemc_to_cwdc )
deallocate(ccf%m_livecrootc_to_cwdc )
deallocate(ccf%m_deadcrootc_to_cwdc )
deallocate(ccf%m_gresp_storage_to_litr1c )
deallocate(ccf%m_gresp_xfer_to_litr1c )
deallocate(ccf%m_deadstemc_to_cwdc_fire )
deallocate(ccf%m_deadcrootc_to_cwdc_fire )
deallocate(ccf%hrv_leafc_to_litr1c )
deallocate(ccf%hrv_leafc_to_litr2c )
deallocate(ccf%hrv_leafc_to_litr3c )
deallocate(ccf%hrv_frootc_to_litr1c )
deallocate(ccf%hrv_frootc_to_litr2c )
deallocate(ccf%hrv_frootc_to_litr3c )
deallocate(ccf%hrv_livestemc_to_cwdc )
deallocate(ccf%hrv_deadstemc_to_prod10c )
deallocate(ccf%hrv_deadstemc_to_prod100c )
deallocate(ccf%hrv_livecrootc_to_cwdc )
deallocate(ccf%hrv_deadcrootc_to_cwdc )
deallocate(ccf%hrv_leafc_storage_to_litr1c )
deallocate(ccf%hrv_frootc_storage_to_litr1c )
deallocate(ccf%hrv_livestemc_storage_to_litr1c )
deallocate(ccf%hrv_deadstemc_storage_to_litr1c )
deallocate(ccf%hrv_livecrootc_storage_to_litr1c )
deallocate(ccf%hrv_deadcrootc_storage_to_litr1c )
deallocate(ccf%hrv_gresp_storage_to_litr1c )
deallocate(ccf%hrv_leafc_xfer_to_litr1c )
deallocate(ccf%hrv_frootc_xfer_to_litr1c )
deallocate(ccf%hrv_livestemc_xfer_to_litr1c )
deallocate(ccf%hrv_deadstemc_xfer_to_litr1c )
deallocate(ccf%hrv_livecrootc_xfer_to_litr1c )
deallocate(ccf%hrv_deadcrootc_xfer_to_litr1c )
deallocate(ccf%hrv_gresp_xfer_to_litr1c )
deallocate(ccf%m_litr1c_to_fire )
deallocate(ccf%m_litr2c_to_fire )
deallocate(ccf%m_litr3c_to_fire )
deallocate(ccf%m_cwdc_to_fire )
#if (defined CROP)
deallocate(ccf%grainc_to_litr1c )
deallocate(ccf%grainc_to_litr2c )
deallocate(ccf%grainc_to_litr3c )
deallocate(ccf%livestemc_to_litr1c )
deallocate(ccf%livestemc_to_litr2c )
deallocate(ccf%livestemc_to_litr3c )
#endif
deallocate(ccf%leafc_to_litr1c )
deallocate(ccf%leafc_to_litr2c )
deallocate(ccf%leafc_to_litr3c )
deallocate(ccf%frootc_to_litr1c )
deallocate(ccf%frootc_to_litr2c )
deallocate(ccf%frootc_to_litr3c )
deallocate(ccf%cwdc_to_litr2c )
deallocate(ccf%cwdc_to_litr3c )
deallocate(ccf%litr1_hr )
deallocate(ccf%litr1c_to_soil1c )
deallocate(ccf%litr2_hr )
deallocate(ccf%litr2c_to_soil2c )
deallocate(ccf%litr3_hr )
deallocate(ccf%litr3c_to_soil3c )
deallocate(ccf%soil1_hr )
deallocate(ccf%soil1c_to_soil2c )
deallocate(ccf%soil2_hr )
deallocate(ccf%soil2c_to_soil3c )
deallocate(ccf%soil3_hr )
deallocate(ccf%soil3c_to_soil4c )
deallocate(ccf%soil4_hr )
#ifdef CN
deallocate(ccf%dwt_seedc_to_leaf )
deallocate(ccf%dwt_seedc_to_deadstem )
deallocate(ccf%dwt_conv_cflux )
deallocate(ccf%dwt_prod10c_gain )
deallocate(ccf%dwt_prod100c_gain )
deallocate(ccf%dwt_frootc_to_litr1c )
deallocate(ccf%dwt_frootc_to_litr2c )
deallocate(ccf%dwt_frootc_to_litr3c )
deallocate(ccf%dwt_livecrootc_to_cwdc )
deallocate(ccf%dwt_deadcrootc_to_cwdc )
deallocate(ccf%dwt_closs )
deallocate(ccf%landuseflux )
deallocate(ccf%landuptake )
deallocate(ccf%prod10c_loss )
deallocate(ccf%prod100c_loss )
deallocate(ccf%product_closs )
#endif
deallocate(ccf%lithr )
deallocate(ccf%somhr )
deallocate(ccf%hr )
deallocate(ccf%sr )
deallocate(ccf%er )
deallocate(ccf%litfire )
deallocate(ccf%somfire )
deallocate(ccf%totfire )
deallocate(ccf%nep )
deallocate(ccf%nbp )
deallocate(ccf%nee )
deallocate(ccf%col_cinputs )
deallocate(ccf%col_coutputs )
deallocate(ccf%col_fire_closs )
#if (defined CLAMP) && (defined CN)
!CLAMP
deallocate(ccf%cwdc_hr )
deallocate(ccf%cwdc_loss )
deallocate(ccf%litterc_loss )
#endif
end subroutine dealloc_column_cflux_type
subroutine dealloc_column_nflux_type( cnf) 1
!
! !DESCRIPTION:
! Initialize column nitrogen flux variables
!
! !ARGUMENTS:
implicit none
type (column_nflux_type), intent(inout):: cnf
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!------------------------------------------------------------------------
deallocate(cnf%ndep_to_sminn )
deallocate(cnf%nfix_to_sminn )
deallocate(cnf%m_leafn_to_litr1n )
deallocate(cnf%m_leafn_to_litr2n )
deallocate(cnf%m_leafn_to_litr3n )
deallocate(cnf%m_frootn_to_litr1n )
deallocate(cnf%m_frootn_to_litr2n )
deallocate(cnf%m_frootn_to_litr3n )
deallocate(cnf%m_leafn_storage_to_litr1n )
deallocate(cnf%m_frootn_storage_to_litr1n )
deallocate(cnf%m_livestemn_storage_to_litr1n )
deallocate(cnf%m_deadstemn_storage_to_litr1n )
deallocate(cnf%m_livecrootn_storage_to_litr1n )
deallocate(cnf%m_deadcrootn_storage_to_litr1n )
deallocate(cnf%m_leafn_xfer_to_litr1n )
deallocate(cnf%m_frootn_xfer_to_litr1n )
deallocate(cnf%m_livestemn_xfer_to_litr1n )
deallocate(cnf%m_deadstemn_xfer_to_litr1n )
deallocate(cnf%m_livecrootn_xfer_to_litr1n )
deallocate(cnf%m_deadcrootn_xfer_to_litr1n )
deallocate(cnf%m_livestemn_to_cwdn )
deallocate(cnf%m_deadstemn_to_cwdn )
deallocate(cnf%m_livecrootn_to_cwdn )
deallocate(cnf%m_deadcrootn_to_cwdn )
deallocate(cnf%m_retransn_to_litr1n )
deallocate(cnf%hrv_leafn_to_litr1n )
deallocate(cnf%hrv_leafn_to_litr2n )
deallocate(cnf%hrv_leafn_to_litr3n )
deallocate(cnf%hrv_frootn_to_litr1n )
deallocate(cnf%hrv_frootn_to_litr2n )
deallocate(cnf%hrv_frootn_to_litr3n )
deallocate(cnf%hrv_livestemn_to_cwdn )
deallocate(cnf%hrv_deadstemn_to_prod10n )
deallocate(cnf%hrv_deadstemn_to_prod100n )
deallocate(cnf%hrv_livecrootn_to_cwdn )
deallocate(cnf%hrv_deadcrootn_to_cwdn )
deallocate(cnf%hrv_retransn_to_litr1n )
deallocate(cnf%hrv_leafn_storage_to_litr1n )
deallocate(cnf%hrv_frootn_storage_to_litr1n )
deallocate(cnf%hrv_livestemn_storage_to_litr1n )
deallocate(cnf%hrv_deadstemn_storage_to_litr1n )
deallocate(cnf%hrv_livecrootn_storage_to_litr1n )
deallocate(cnf%hrv_deadcrootn_storage_to_litr1n )
deallocate(cnf%hrv_leafn_xfer_to_litr1n )
deallocate(cnf%hrv_frootn_xfer_to_litr1n )
deallocate(cnf%hrv_livestemn_xfer_to_litr1n )
deallocate(cnf%hrv_deadstemn_xfer_to_litr1n )
deallocate(cnf%hrv_livecrootn_xfer_to_litr1n )
deallocate(cnf%hrv_deadcrootn_xfer_to_litr1n )
deallocate(cnf%m_deadstemn_to_cwdn_fire )
deallocate(cnf%m_deadcrootn_to_cwdn_fire )
deallocate(cnf%m_litr1n_to_fire )
deallocate(cnf%m_litr2n_to_fire )
deallocate(cnf%m_litr3n_to_fire )
deallocate(cnf%m_cwdn_to_fire )
#if (defined CROP)
deallocate(cnf%grainn_to_litr1n )
deallocate(cnf%grainn_to_litr2n )
deallocate(cnf%grainn_to_litr3n )
deallocate(cnf%livestemn_to_litr1n )
deallocate(cnf%livestemn_to_litr2n )
deallocate(cnf%livestemn_to_litr3n )
#endif
deallocate(cnf%leafn_to_litr1n )
deallocate(cnf%leafn_to_litr2n )
deallocate(cnf%leafn_to_litr3n )
deallocate(cnf%frootn_to_litr1n )
deallocate(cnf%frootn_to_litr2n )
deallocate(cnf%frootn_to_litr3n )
deallocate(cnf%cwdn_to_litr2n )
deallocate(cnf%cwdn_to_litr3n )
deallocate(cnf%litr1n_to_soil1n )
deallocate(cnf%sminn_to_soil1n_l1 )
deallocate(cnf%litr2n_to_soil2n )
deallocate(cnf%sminn_to_soil2n_l2 )
deallocate(cnf%litr3n_to_soil3n )
deallocate(cnf%sminn_to_soil3n_l3 )
deallocate(cnf%soil1n_to_soil2n )
deallocate(cnf%sminn_to_soil2n_s1 )
deallocate(cnf%soil2n_to_soil3n )
deallocate(cnf%sminn_to_soil3n_s2 )
deallocate(cnf%soil3n_to_soil4n )
deallocate(cnf%sminn_to_soil4n_s3 )
deallocate(cnf%soil4n_to_sminn )
deallocate(cnf%sminn_to_denit_l1s1 )
deallocate(cnf%sminn_to_denit_l2s2 )
deallocate(cnf%sminn_to_denit_l3s3 )
deallocate(cnf%sminn_to_denit_s1s2 )
deallocate(cnf%sminn_to_denit_s2s3 )
deallocate(cnf%sminn_to_denit_s3s4 )
deallocate(cnf%sminn_to_denit_s4 )
deallocate(cnf%sminn_to_denit_excess )
deallocate(cnf%sminn_leached )
deallocate(cnf%dwt_seedn_to_leaf )
deallocate(cnf%dwt_seedn_to_deadstem )
deallocate(cnf%dwt_conv_nflux )
deallocate(cnf%dwt_prod10n_gain )
deallocate(cnf%dwt_prod100n_gain )
deallocate(cnf%dwt_frootn_to_litr1n )
deallocate(cnf%dwt_frootn_to_litr2n )
deallocate(cnf%dwt_frootn_to_litr3n )
deallocate(cnf%dwt_livecrootn_to_cwdn )
deallocate(cnf%dwt_deadcrootn_to_cwdn )
deallocate(cnf%dwt_nloss )
deallocate(cnf%prod10n_loss )
deallocate(cnf%prod100n_loss )
deallocate(cnf%product_nloss )
deallocate(cnf%potential_immob )
deallocate(cnf%actual_immob )
deallocate(cnf%sminn_to_plant )
deallocate(cnf%supplement_to_sminn )
deallocate(cnf%gross_nmin )
deallocate(cnf%net_nmin )
deallocate(cnf%denit )
deallocate(cnf%col_ninputs )
deallocate(cnf%col_noutputs )
deallocate(cnf%col_fire_nloss )
end subroutine dealloc_column_nflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_landunit_pstate_type
!
! !INTERFACE:
subroutine dealloc_landunit_pstate_type( lps) 1
!
! !ARGUMENTS:
implicit none
type (landunit_pstate_type), intent(inout):: lps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(lps%t_building )
deallocate(lps%t_building_max )
deallocate(lps%t_building_min )
deallocate(lps%tk_wall)
deallocate(lps%tk_roof)
deallocate(lps%tk_improad)
deallocate(lps%cv_wall)
deallocate(lps%cv_roof)
deallocate(lps%cv_improad)
deallocate(lps%thick_wall )
deallocate(lps%thick_roof )
deallocate(lps%nlev_improad )
deallocate(lps%vf_sr )
deallocate(lps%vf_wr )
deallocate(lps%vf_sw )
deallocate(lps%vf_rw )
deallocate(lps%vf_ww )
deallocate(lps%taf )
deallocate(lps%qaf )
deallocate(lps%sabs_roof_dir )
deallocate(lps%sabs_roof_dif )
deallocate(lps%sabs_sunwall_dir )
deallocate(lps%sabs_sunwall_dif )
deallocate(lps%sabs_shadewall_dir )
deallocate(lps%sabs_shadewall_dif )
deallocate(lps%sabs_improad_dir )
deallocate(lps%sabs_improad_dif )
deallocate(lps%sabs_perroad_dir )
deallocate(lps%sabs_perroad_dif )
end subroutine dealloc_landunit_pstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_landunit_eflux_type
!
! !INTERFACE:
subroutine dealloc_landunit_eflux_type( lef) 1
!
! !DESCRIPTION:
! Initialize landunit energy flux variables
!
! !ARGUMENTS:
implicit none
type (landunit_eflux_type), intent(inout):: lef
!
! !REVISION HISTORY:
! Created by Keith Oleson
!
!EOP
!------------------------------------------------------------------------
deallocate(lef%eflx_traffic )
deallocate(lef%eflx_traffic_factor )
deallocate(lef%eflx_wasteheat )
deallocate(lef%eflx_heat_from_ac )
end subroutine dealloc_landunit_eflux_type
#if (defined CNDV)
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_gridcell_dgvstate_type
!
! !INTERFACE:
subroutine dealloc_gridcell_dgvstate_type( gps) 1
!
! !DESCRIPTION:
! Initialize gridcell DGVM variables
!
! !ARGUMENTS:
implicit none
type (gridcell_dgvstate_type), intent(inout):: gps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(gps%agdd20 )
deallocate(gps%tmomin20 )
deallocate(gps%t10min )
end subroutine dealloc_gridcell_dgvstate_type
#endif
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_gridcell_pstate_type
!
! !INTERFACE:
subroutine dealloc_gridcell_pstate_type( gps) 1
!
! !DESCRIPTION:
! Initialize gridcell physical state variables
!
! !ARGUMENTS:
implicit none
type (gridcell_pstate_type), intent(inout):: gps
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
end subroutine dealloc_gridcell_pstate_type
subroutine dealloc_gridcell_efstate_type( gve) 1
!
! !DESCRIPTION:
! Initialize gridcell isoprene emission factor variables
!
! !ARGUMENTS:
implicit none
type (gridcell_efstate_type), intent(inout) :: gve
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein (heald)
!
!EOP
!------------------------------------------------------------------------
deallocate(gve%efisop)
end subroutine dealloc_gridcell_efstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_gridcell_wflux_type
!
! !INTERFACE:
subroutine dealloc_gridcell_wflux_type( gwf) 1
!
! !DESCRIPTION:
! Initialize gridcell water flux variables
!
! !ARGUMENTS:
implicit none
type (gridcell_wflux_type), intent(inout):: gwf
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------
deallocate(gwf%qflx_runoffg )
deallocate(gwf%qflx_snwcp_iceg )
deallocate(gwf%qflx_liq_dynbal )
deallocate(gwf%qflx_ice_dynbal )
end subroutine dealloc_gridcell_wflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_gridcell_eflux_type
!
!INTERFACE:
subroutine dealloc_gridcell_eflux_type( gef) 1
!
! !DESCRIPTION:
! Initialize gridcell energy flux variables
!
! !ARGUMENTS:
implicit none
type (gridcell_eflux_type), intent(inout):: gef
!
! !REVISION HISTORY:
! Created by David Lawrence
!
!EOP
!------------------------------------------------------------------------
deallocate(gef%eflx_sh_totg )
deallocate(gef%eflx_dynbal )
end subroutine dealloc_gridcell_eflux_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_gridcell_wstate_type
!
! !INTERFACE:
subroutine dealloc_gridcell_wstate_type( gws) 1
!
! !DESCRIPTION:
! Initialize gridcell water state variables
!
! !ARGUMENTS:
implicit none
type (gridcell_wstate_type), intent(inout):: gws
!
! !REVISION HISTORY:
! Created by David Lawrence
!
!EOP
!------------------------------------------------------------------------
deallocate(gws%gc_liq1 )
deallocate(gws%gc_liq2 )
deallocate(gws%gc_ice1 )
deallocate(gws%gc_ice2 )
end subroutine dealloc_gridcell_wstate_type
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: dealloc_gridcell_estate_type
!
! !INTERFACE:
subroutine dealloc_gridcell_estate_type( ges) 1
! !DESCRIPTION:
! Initialize gridcell energy state variables
!
! !ARGUMENTS:
implicit none
type (gridcell_estate_type), intent(inout):: ges
!
! !REVISION HISTORY:
! Created by David Lawrence
!
!EOP
!------------------------------------------------------------------------
deallocate(ges%gc_heat1 )
deallocate(ges%gc_heat2 )
end subroutine dealloc_gridcell_estate_type
subroutine dealloc_atm2lnd_type(a2l) 1
implicit none
type (atm2lnd_type), intent(inout):: a2l
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! Modified by T Craig, 11/01/05 for finemesh project
!
!
! !LOCAL VARIABLES:
!EOP
!------------------------------------------------------------------------
deallocate(a2l%forc_t)
deallocate(a2l%forc_u)
deallocate(a2l%forc_v)
deallocate(a2l%forc_wind)
deallocate(a2l%forc_q)
deallocate(a2l%forc_rh)
deallocate(a2l%forc_hgt)
deallocate(a2l%forc_hgt_u)
deallocate(a2l%forc_hgt_t)
deallocate(a2l%forc_hgt_q)
deallocate(a2l%forc_pbot)
deallocate(a2l%forc_th)
deallocate(a2l%forc_vp)
deallocate(a2l%forc_rho)
deallocate(a2l%forc_psrf)
deallocate(a2l%forc_pco2)
deallocate(a2l%forc_lwrad)
deallocate(a2l%forc_solad)
deallocate(a2l%forc_solai)
deallocate(a2l%forc_solar)
deallocate(a2l%forc_rain)
deallocate(a2l%forc_snow)
deallocate(a2l%forc_ndep)
deallocate(a2l%rainf)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
deallocate(a2l%forc_pc13o2)
#endif
deallocate(a2l%forc_po2)
deallocate(a2l%forc_aer)
end subroutine dealloc_atm2lnd_type
end module clmtypeInitMod
module pftvarcon 26,2
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: pftvarcon
!
! !DESCRIPTION:
! Module containing vegetation constants and method to
! eads and initialize vegetation (PFT) constants.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varpar,only : numpft, numrad
!
! !PUBLIC TYPES:
implicit none
save
!
! Vegetation type constants
!ylu add
! Set specific vegetation type values
integer,parameter :: noveg = 0 !value for not vegetated
integer,parameter :: ndllf_evr_tmp_tree = 1 !value for Needleleaf evergreen temperate tree
integer,parameter :: ndllf_evr_brl_tree = 2 !value for Needleleaf evergreen boreal tree
integer,parameter :: ndllf_dcd_brl_tree = 3 !value for Needleleaf deciduous boreal tree
integer,parameter :: nbrdlf_evr_trp_tree = 4 !value for Broadleaf evergreen tropical tree
integer,parameter :: nbrdlf_evr_tmp_tree = 5 !value for Broadleaf evergreen temperate tree
integer,parameter :: nbrdlf_dcd_trp_tree = 6 !value for Broadleaf deciduous tropical tree
integer,parameter :: nbrdlf_dcd_tmp_tree = 7 !value for Broadleaf deciduous temperate tree
integer,parameter :: nbrdlf_dcd_brl_tree = 8 !value for Broadleaf deciduous boreal tree
integer :: ntree !value for last type of tree
integer,parameter :: nbrdlf_evr_shrub = 9 !value for Broadleaf evergreen shrub
integer,parameter :: nbrdlf_dcd_tmp_shrub = 10 !value for Broadleaf deciduous temperate shrub
integer,parameter :: nbrdlf_dcd_brl_shrub = 11 !value for Broadleaf deciduous boreal shrub
integer,parameter :: nc3_arctic_grass = 12 !value for C3 arctic grass
integer,parameter :: nc3_nonarctic_grass = 13 !value for C3 non-arctic grass
integer,parameter :: nc4_grass = 14 !value for C4 grass
integer,parameter :: nc3crop = 15 !value for generic C3 crop
integer,parameter :: nc4crop = 16 !value for generic C4 crop
#if (defined CROP)
integer :: npcropmin !value for first crop
integer,parameter :: ncorn = 17 !value for corn
integer,parameter :: nswheat = 18 !value for spring wheat
integer,parameter :: nwwheat = 19 !value for winter wheat
integer,parameter :: nsoybean = 20 !value for soybean
integer :: npcropmax !value for last prognostic crop in list
real(r8):: mxtmp(0:numpft) !parameter used in accFlds
real(r8):: baset(0:numpft) !parameter used in accFlds
real(r8):: declfact(0:numpft) !parameter used in CNAllocation
real(r8):: bfact(0:numpft) !parameter used in CNAllocation
real(r8):: aleaff(0:numpft) !parameter used in CNAllocation
real(r8):: arootf(0:numpft) !parameter used in CNAllocation
real(r8):: astemf(0:numpft) !parameter used in CNAllocation
real(r8):: arooti(0:numpft) !parameter used in CNAllocation
real(r8):: fleafi(0:numpft) !parameter used in CNAllocation
real(r8):: allconsl(0:numpft) !parameter used in CNAllocation
real(r8):: allconss(0:numpft) !parameter used in CNAllocation
real(r8):: ztopmx(0:numpft) !parameter used in CNVegStructUpdate
real(r8):: laimx(0:numpft) !parameter used in CNVegStructUpdate
real(r8):: gddmin(0:numpft) !parameter used in CNPhenology
real(r8):: hybgdd(0:numpft) !parameter used in CNPhenology
real(r8):: lfemerg(0:numpft) !parameter used in CNPhenology
real(r8):: grnfill(0:numpft) !parameter used in CNPhenology
integer :: mxmat(0:numpft) !parameter used in CNPhenology
#endif
real(r8):: crop(0:numpft) ! crop pft: 0. = not crop, 1. = crop pft
!-----------------------------------------------------------------------
character(len=40) pftname(0:numpft)
real(r8):: dleaf(0:numpft) !characteristic leaf dimension (m)
real(r8):: c3psn(0:numpft) !photosynthetic pathway: 0. = c4, 1. = c3
real(r8):: vcmx25(0:numpft) !max rate of carboxylation at 25C (umol CO2/m**2/s)
real(r8):: mp(0:numpft) !slope of conductance-to-photosynthesis relationship
real(r8):: qe25(0:numpft) !quantum efficiency at 25C (umol CO2 / umol photon)
real(r8):: xl(0:numpft) !leaf/stem orientation index
real(r8):: rhol(0:numpft,numrad) !leaf reflectance: 1=vis, 2=nir
real(r8):: rhos(0:numpft,numrad) !stem reflectance: 1=vis, 2=nir
real(r8):: taul(0:numpft,numrad) !leaf transmittance: 1=vis, 2=nir
real(r8):: taus(0:numpft,numrad) !stem transmittance: 1=vis, 2=nir
real(r8):: z0mr(0:numpft) !ratio of momentum roughness length to canopy top height (-)
real(r8):: displar(0:numpft) !ratio of displacement height to canopy top height (-)
real(r8):: roota_par(0:numpft) !CLM rooting distribution parameter [1/m]
real(r8):: rootb_par(0:numpft) !CLM rooting distribution parameter [1/m]
real(r8):: slatop(0:numpft) !SLA at top of canopy [m^2/gC]
real(r8):: dsladlai(0:numpft) !dSLA/dLAI [m^2/gC]
real(r8):: leafcn(0:numpft) !leaf C:N [gC/gN]
real(r8):: flnr(0:numpft) !fraction of leaf N in Rubisco [no units]
real(r8):: smpso(0:numpft) !soil water potential at full stomatal opening (mm)
real(r8):: smpsc(0:numpft) !soil water potential at full stomatal closure (mm)
real(r8):: fnitr(0:numpft) !foliage nitrogen limitation factor (-)
real(r8):: woody(0:numpft) !woody lifeform flag (0 or 1)
real(r8):: lflitcn(0:numpft) !leaf litter C:N (gC/gN)
real(r8):: frootcn(0:numpft) !fine root C:N (gC/gN)
real(r8):: livewdcn(0:numpft) !live wood (phloem and ray parenchyma) C:N (gC/gN)
real(r8):: deadwdcn(0:numpft) !dead wood (xylem and heartwood) C:N (gC/gN)
real(r8):: froot_leaf(0:numpft) !allocation parameter: new fine root C per new leaf C (gC/gC)
real(r8):: stem_leaf(0:numpft) !allocation parameter: new stem c per new leaf C (gC/gC)
real(r8):: croot_stem(0:numpft) !allocation parameter: new coarse root C per new stem C (gC/gC)
real(r8):: flivewd(0:numpft) !allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units)
real(r8):: fcur(0:numpft) !allocation parameter: fraction of allocation that goes to currently displayed growth, remainder to storage
real(r8):: lf_flab(0:numpft) !leaf litter labile fraction
real(r8):: lf_fcel(0:numpft) !leaf litter cellulose fraction
real(r8):: lf_flig(0:numpft) !leaf litter lignin fraction
real(r8):: fr_flab(0:numpft) !fine root litter labile fraction
real(r8):: fr_fcel(0:numpft) !fine root litter cellulose fraction
real(r8):: fr_flig(0:numpft) !fine root litter lignin fraction
real(r8):: dw_fcel(0:numpft) !dead wood cellulose fraction
real(r8):: dw_flig(0:numpft) !dead wood lignin fraction
real(r8):: leaf_long(0:numpft) !leaf longevity (yrs)
real(r8):: evergreen(0:numpft) !binary flag for evergreen leaf habit (0 or 1)
real(r8):: stress_decid(0:numpft) !binary flag for stress-deciduous leaf habit (0 or 1)
real(r8):: season_decid(0:numpft) !binary flag for seasonal-deciduous leaf habit (0 or 1)
! new pft parameters for CN-fire code
real(r8):: resist(0:numpft) !resistance to fire (no units)
real(r8):: pftpar20(0:numpft) !tree maximum crown area (m2)
real(r8):: pftpar28(0:numpft) !min coldest monthly mean temperature
real(r8):: pftpar29(0:numpft) !max coldest monthly mean temperature
real(r8):: pftpar30(0:numpft) !min growing degree days (>= 5 deg C)
real(r8):: pftpar31(0:numpft) !upper limit of temperature of the warmest month (twmax)
! for crop
real(r8):: graincn(0:numpft) !grain C:N (gC/gN)
real(r8), parameter :: reinickerp = 1.6_r8 !parameter in allometric equation
real(r8), parameter :: dwood = 2.5e5_r8 !cn wood density (gC/m3); lpj:2.0e5
real(r8), parameter :: allom1 = 100.0_r8 !parameters in
real(r8), parameter :: allom2 = 40.0_r8 !...allometric
real(r8), parameter :: allom3 = 0.5_r8 !...equations
real(r8), parameter :: allom1s = 250.0_r8 !modified for shrubs by
real(r8), parameter :: allom2s = 8.0_r8 !X.D.Z
! Created by Sam Levis (put into module form by Mariana Vertenstein)
character(len=40) expected_pftnames(0:numpft)
integer, private :: i ! loop index
data (expected_pftnames(i),i=1,numpft) / &
'needleleaf_evergreen_temperate_tree' &
, 'needleleaf_evergreen_boreal_tree ' &
, 'needleleaf_deciduous_boreal_tree ' &
, 'broadleaf_evergreen_tropical_tree ' &
, 'broadleaf_evergreen_temperate_tree ' &
, 'broadleaf_deciduous_tropical_tree ' &
, 'broadleaf_deciduous_temperate_tree ' &
, 'broadleaf_deciduous_boreal_tree ' &
, 'broadleaf_evergreen_shrub ' &
, 'broadleaf_deciduous_temperate_shrub' &
, 'broadleaf_deciduous_boreal_shrub ' &
, 'c3_arctic_grass ' &
, 'c3_non-arctic_grass ' &
, 'c4_grass ' &
, 'c3_crop ' &
, 'c4_crop ' &
#if (defined CROP)
, 'corn ' &
, 'spring_wheat ' &
, 'winter_wheat ' &
, 'soybean ' &
#endif
/
!ylu 10/18/10 add new physiology data for CLM4 and CROP
data (pftname(i),i=1,numpft)/'needleleaf_evergreen_temperate_tree'&
, 'needleleaf_evergreen_boreal_tree ' &
, 'needleleaf_deciduous_boreal_tree ' &
, 'broadleaf_evergreen_tropical_tree ' &
, 'broadleaf_evergreen_temperate_tree ' &
, 'broadleaf_deciduous_tropical_tree ' &
, 'broadleaf_deciduous_temperate_tree ' &
, 'broadleaf_deciduous_boreal_tree ' &
, 'broadleaf_evergreen_shrub ' &
, 'broadleaf_deciduous_temperate_shrub' &
, 'broadleaf_deciduous_boreal_shrub ' &
, 'c3_arctic_grass ' &
, 'c3_non-arctic_grass ' &
, 'c4_grass ' &
, 'c3_crop ' &
, 'c4_crop ' &
#if (defined CROP)
, 'corn ' &
, 'spring_wheat ' &
, 'winter_wheat ' &
, 'soybean ' &
#endif
/
data (z0mr(i),i=1,numpft)/ 0.055,0.055,0.055,0.075,0.075,&
0.055,0.055,0.055,0.120,0.120,0.120,0.120,0.120,&
0.120,0.120,0.120&
#if (defined CROP)
,0.120,0.120,0.120,0.120/
#else
/
#endif
data (displar(i),i=1,numpft)/0.67,0.67,0.67,0.67,0.67,0.67,&
0.67,0.67,0.68,0.68,0.68,0.68,0.68,0.68,0.68,0.68&
#if (defined CROP)
,0.68,0.68,0.68,0.68/
#else
/
#endif
data (dleaf(i),i=1,numpft)/ 0.04,0.04,0.04,0.04,0.04,0.04,&
0.04,0.04,0.04,0.04,0.04,0.04,0.04,0.04,0.04,0.04&
#if (defined CROP)
,0.04,0.04,0.04,0.04/
#else
/
#endif
data (c3psn(i),i=1,numpft)/1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1&
#if (defined CROP)
,0,1,1,1 /
#else
/
#endif
data (vcmx25(i),i=1,numpft)/51,43,51,75,69,40,51,51,17,17,&
33,43,43,24,50,50&
#if (defined CROP)
,50,50,50,50 /
#else
/
#endif
data (mp(i),i=1,numpft)/6,6,6,9,9,9,9,9,9,9,9,9,9,5,9,9&
#if (defined CROP)
,4,9,9,9/
#else
/
#endif
data (qe25(i),i=1,numpft)/ 0.06,0.06,0.06,0.06,0.06,0.06,&
0.06,0.06,0.06,0.06,0.06,0.06,0.06,0.04,0.06,0.06&
#if (defined CROP)
,0.04,0.06,0.06,0.06/
#else
/
#endif
data (rhol(i,1),i=1,numpft)/0.07,0.07,0.07,0.10,0.10,0.10,&
0.10,0.10,0.07,0.10,0.10,0.11,0.11,0.11,0.11,0.11&
#if (defined CROP)
,0.11,0.11,0.11,0.11/
#else
/
#endif
data (rhol(i,2),i=1,numpft)/ 0.35,0.35,0.35,0.45,0.45,0.45,&
0.45,0.45,0.35,0.45,0.45,0.35,0.35,0.35,0.35,0.35&
#if (defined CROP)
,0.35,0.35,0.35,0.35/
#else
/
#endif
data (rhos(i,1),i=1,numpft) /0.16,0.16,0.16,0.16,0.16,0.16,&
0.16,0.16,0.16,0.16,0.16,0.31,0.31,0.31,0.31,0.31&
#if (defined CROP)
,0.31,0.31,0.31,0.31/
#else
/
#endif
data (rhos(i,2),i=1,numpft)/0.39,0.39,0.39,0.39,0.39,0.39,&
0.39,0.39,0.39,0.39,0.39,0.53,0.53,0.53,0.53,0.53&
#if (defined CROP)
,0.53,0.53,0.53,0.53/
#else
/
#endif
data (taul(i,1),i=1,numpft)/0.05,0.05,0.05,0.05,0.05,0.05,&
0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05&
#if (defined CROP)
,0.05,0.05,0.05,0.05/
#else
/
#endif
data (taul(i,2),i=1,numpft)/0.10,0.10,0.10,0.25,0.25,0.25,&
0.25,0.25,0.10,0.25,0.25,0.34,0.34,0.34,0.34,0.34&
#if (defined CROP)
,0.34,0.34,0.34,0.34/
#else
/
#endif
data (taus(i,1),i=1,numpft)/0.001,0.001,0.001,0.001,0.001,&
0.001,0.001,0.001,0.001,0.001,0.001,0.120,0.120,0.120,0.120,0.120&
#if (defined CROP)
,0.120,0.120,0.120,0.120/
#else
/
#endif
data (taus(i,2),i=1,numpft)/ 0.001,0.001,0.001,0.001,0.001,0.001,&
0.001,0.001,0.001,0.001,0.001,0.250,0.250,0.250,0.250,0.250&
#if (defined CROP)
,0.250,0.250,0.250,0.250/
#else
/
#endif
data (xl(i),i=1,numpft)/0.01, 0.01, 0.01, 0.10, 0.10, 0.01,&
0.25, 0.25, 0.01, 0.25, 0.25,-0.30,-0.30,-0.30,-0.30,-0.30&
#if (defined CROP)
,-0.50, 0.65, 0.65,-0.50/
#else
/
#endif
data (roota_par(i),i=1,numpft)/ 7, 7, 7, 7, 7, 6, 6, 6, 7,&
7, 7,11,11,11, 6, 6&
#if (defined CROP)
, 6, 6, 6, 6/
#else
/
#endif
data (rootb_par(i),i=1,numpft)/ 2.0,2.0,2.0,1.0,1.0,2.0,2.0,&
2.0,1.5,1.5,1.5,2.0,2.0,2.0,3.0,3.0&
#if (defined CROP)
,3.0,3.0,3.0,3.0/
#else
/
#endif
data (slatop(i),i=1,numpft)/0.010,0.008,0.024,0.012,0.012,0.030,&
0.030,0.030,0.012,0.030,0.030,0.030,0.030,0.030,0.030,0.030&
#if (defined CROP)
,0.050,0.070,0.070,0.070/
#else
/
#endif
data (dsladlai(i),i=1,numpft)/0.00125,0.00100,0.00300,0.00150,0.00150,&
0.00400,0.00400,0.00400,0.00000,0.00000,0.00000,0.00000,0.00000,&
0.00000,0.00000,0.00000&
#if (defined CROP)
,0.00000,0.00000,0.00000,0.00000/
#else
/
#endif
data (leafcn(i),i=1,numpft)/35,40,25,30,30,25,25,25,30,25,25,&
25,25,25,25,25&
#if (defined CROP)
,25,25,25,25/
#else
/
#endif
data (flnr(i),i=1,numpft)/0.05,0.04,0.08,0.06,0.06,0.09,0.09,0.09,&
0.06,0.09,0.09,0.09,0.09,0.09,0.10,0.10&
#if (defined CROP)
,0.10,0.20,0.20,0.10/
#else
/
#endif
data (smpso(i),i=1,numpft)/-66000,-66000,-66000,-66000,-66000,-35000,&
-35000,-35000,-83000,-83000,-83000,-74000,-74000,-74000,-74000,-74000&
#if (defined CROP)
,-74000,-74000,-74000,-74000/
#else
/
#endif
data (smpsc(i),i=1,numpft)/-255000,-255000,-255000,-255000,-255000,-224000,&
-224000,-224000,-428000,-428000,-428000,-275000,-275000,-275000,-275000,-275000&
#if (defined CROP)
,-275000,-275000,-275000,-275000/
#else
/
#endif
data(fnitr(i),i=1,numpft)/0.72,0.78,0.79,0.83,0.71,0.66,0.64,0.70,0.62,&
0.60,0.76,0.68,0.61,0.64,0.61,0.61&
#if (defined CROP)
,0.61,0.61,0.61,0.61/
#else
/
#endif
data(woody(i),i=1,numpft)/1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0&
#if (defined CROP)
,0,0,0,0/
#else
/
#endif
data(lflitcn(i),i=1,numpft)/70,80,50,60,60,50,50,50,60,50,50,50,50,50,50,50&
#if (defined CROP)
,25,25,25,25/
#else
/
#endif
data(frootcn(i),i=1,numpft)/42,42,42,42,42,42,42,42,42,42,42,42,42,42,42,42&
#if (defined CROP)
,42,42,42,42/
#else
/
#endif
data(livewdcn(i),i=1,numpft)/50,50,50,50,50,50,50,50,50,50,50, 50, 50, 50, 50, 50&
#if (defined CROP)
,50,50,50,50/
#else
/
#endif
data(deadwdcn(i),i=1,numpft)/500,500,500,500,500,500,500,500,500,500,500,&
500, 500, 500, 500, 500&
#if (defined CROP)
,500,500,500,500/
#else
/
#endif
data(froot_leaf(i),i=1,numpft)/1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2&
#if (defined CROP)
,2,2,2,2/
#else
/
#endif
data(stem_leaf(i),i=1,numpft)/-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,&
0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0&
#if (defined CROP)
, 0.0, 0.0, 0.0, 0.0/
#else
/
#endif
data(croot_stem(i),i=1,numpft)/0.3,0.3,0.3,0.3,0.3,0.3,0.3,0.3,0.3,0.3,&
0.3,0.0,0.0,0.0,0.0,0.0&
#if (defined CROP)
,0.0,0.0,0.0,0.0/
#else
/
#endif
data(flivewd(i),i=1,numpft)/0.1,0.1,0.1,0.1,0.1,0.1,0.1,0.1,0.5,0.5,0.1,&
0.0,0.0,0.0,0.0,0.0&
#if (defined CROP)
,1.0,1.0,1.0,1.0/
#else
/
#endif
data(fcur(i),i=1,numpft)/1,1,0,1,1,0,0,0,1,0,0,0,0,0,0,0&
#if (defined CROP)
,1,1,1,1/
#else
/
#endif
data(lf_flab(i),i=1,numpft)/0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,&
0.25,0.25,0.25,0.25,0.25,0.25,0.25&
#if (defined CROP)
,0.25,0.25,0.25,0.25/
#else
/
#endif
data(lf_fcel(i),i=1,numpft)/0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,&
0.5,0.5,0.5,0.5,0.5&
#if (defined CROP)
,0.5,0.5,0.5,0.5/
#else
/
#endif
data(lf_flig(i),i=1,numpft)/0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,&
0.25,0.25,0.25,0.25,0.25,0.25,0.25&
#if (defined CROP)
,0.25,0.25,0.25,0.25/
#else
/
#endif
data(fr_flab(i),i=1,numpft)/0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,&
0.25,0.25,0.25,0.25,0.25,0.25,0.25&
#if (defined CROP)
,0.25,0.25,0.25,0.25/
#else
/
#endif
data(fr_fcel(i),i=1,numpft)/0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,0.5,&
0.5,0.5,0.5,0.5,0.5&
#if (defined CROP)
,0.5,0.5,0.5,0.5/
#else
/
#endif
data(fr_flig(i),i=1,numpft)/0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,&
0.25,0.25,0.25,0.25,0.25,0.25,0.25&
#if (defined CROP)
,0.25,0.25,0.25,0.25/
#else
/
#endif
data(dw_fcel(i),i=1,numpft)/0.75,0.75,0.75,0.75,0.75,0.75,0.75,0.75,0.75,&
0.75,0.75,0.75,0.75,0.75,0.75,0.75&
#if (defined CROP)
,0.75,0.75,0.75,0.75/
#else
/
#endif
data(dw_flig(i),i=1,numpft)/0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,0.25,&
0.25,0.25,0.25,0.25,0.25,0.25,0.25&
#if (defined CROP)
,0.25,0.25,0.25,0.25/
#else
/
#endif
data(leaf_long(i),i=1,numpft)/3.0,6.0,1.0,1.5,1.5,1.0,1.0,1.0,1.5,1.0,1.0,&
1.0,1.0,1.0,1.0,1.0&
#if (defined CROP)
,1.0,1.0,1.0,1.0/
#else
/
#endif
data(evergreen(i),i=1,numpft)/1,1,0,1,1,0,0,0,1,0,0,0,0,0,0,0&
#if (defined CROP)
,0,0,0,0/
#else
/
#endif
data(stress_decid(i),i=1,numpft)/0,0,0,0,0,1,0,0,0,1,1,1,1,1,1,1&
#if (defined CROP)
,0,0,0,0/
#else
/
#endif
data(season_decid(i),i=1,numpft)/0,0,1,0,0,0,1,1,0,0,0,0,0,0,0,0&
#if (defined CROP)
,0,0,0,0/
#else
/
#endif
data(resist(i),i=1,numpft)/0.12,0.12,0.12,0.12,0.12,0.12,0.12,0.12,&
0.12,0.12,0.12,0.12,0.12,0.12,1.00,1.00&
#if (defined CROP)
,1.00,1.00,1.00,1.00/
#else
/
#endif
data(pftpar20(i),i=1,numpft)/15,15,15,15,15,15,15,15, 5, 5, 5, 0, 0, 0, 0, 0&
#if (defined CROP)
, 0, 0, 0, 0/
#else
/
#endif
data(pftpar28(i),i=1,numpft)/ -2.0, -32.5, 9999.9, 15.5, 3.0, 15.5,&
-17.0,-1000.0, 9999.9, -17.0,-1000.0,-1000.0, -17.0,15.5, 9999.9, 9999.9&
#if (defined CROP)
, 9999.9, 9999.9, 9999.9, 9999.9/
#else
/
#endif
data(pftpar29(i),i=1,numpft)/ 22.0, -2.0, -2.0,1000.0, 18.8,1000.0, 15.5,&
-2.0,1000.0,1000.0, -2.0, -17.0, 15.5,1000.0,1000.0,1000.0&
#if (defined CROP)
,1000.0,1000.0,1000.0,1000.0/
#else
/
#endif
data(pftpar30(i),i=1,numpft)/900, 600, 350, 0,1200, 0,1200, 350, 0,1200,&
350, 0, 0, 0, 0, 0&
#if (defined CROP)
, 0, 0, 0, 0/
#else
/
#endif
data(pftpar31(i),i=1,numpft)/1000, 23, 23,1000,1000,1000,1000, 23,1000,1000,&
23,1000,1000,1000,1000,1000&
#if (defined CROP)
,1000,1000,1000,1000/
#else
/
#endif
data(graincn(i),i=1,numpft)/0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0&
#if (defined CROP)
,50,50,50,50/
#else
/
#endif
public :: pftconrd ! Read and initialize vegetation (PFT) constants
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: pftconrd
!
! !INTERFACE:
subroutine pftconrd 1,1
use nanMod , only : inf
!
! !DESCRIPTION:
! Read and initialize vegetation (PFT) constants
!
! !USES:
!
! !ARGUMENTS:
implicit none
!
! !CALLED FROM:
! routine initialize in module initializeMod
!
! !REVISION HISTORY:
! Created by Gordon Bonan
!
!EOP
!
! !LOCAL VARIABLES:
integer :: i,n !loop indices
integer :: ier !error code
!-----------------------------------------------------------------------
! Set value for last type of tree
ntree = nbrdlf_dcd_brl_tree !value for last type of tree
! Set value for non-vegetated
!ylu moved to top noveg = 0 !value
!ylu add
#if (defined CROP)
npcropmin = ncorn ! first prognostic crop
npcropmax = nsoybean ! last prognostic crop in list
#endif
! Assign unit number to file. Get local file.
! Open file and read PFT's.
! Close and release file.
crop(:) = 0
crop(nc3crop:numpft) = 1
! crop(15) = 1
! crop(16) = 1
#if (defined CROP)
mxtmp(:) = 0._r8
mxtmp(ncorn) = 30._r8
mxtmp(nswheat) = 26._r8
mxtmp(nwwheat) = 26._r8
mxtmp(nsoybean) = 30._r8
baset(:) = 0._r8
baset(ncorn) = 8._r8
baset(nswheat) = 0._r8
baset(nwwheat) = 0._r8
baset(nsoybean) = 10._r8
declfact(:) = 0.00_r8
declfact(npcropmin:npcropmax) = 1.05_r8
bfact(:) = 0.00_r8
bfact(npcropmin:npcropmax) = 0.10_r8
aleaff(:) = 0._r8
arootf(:) = 0.00_r8
arootf(ncorn) = 0.05_r8
arootf(nsoybean) = 0.20_r8
astemf(:) = 0.00_r8
astemf(nswheat) = 0.05_r8
astemf(nwwheat) = 0.05_r8
astemf(nsoybean) = 0.30_r8
arooti(:) = 0.0_r8
arooti(ncorn) = 0.4_r8
arooti(nswheat) = 0.3_r8
arooti(nwwheat) = 0.3_r8
arooti(nsoybean) = 0.5_r8
fleafi(:) = 0.000_r8
fleafi(ncorn) = 0.800_r8
fleafi(nswheat) = 0.750_r8
fleafi(nwwheat) = 0.425_r8
fleafi(nsoybean) = 0.850_r8
allconsl(:) = 0._r8
allconsl(ncorn) = 5._r8
allconsl(nswheat) = 3._r8
allconsl(nwwheat) = 3._r8
allconsl(nsoybean) = 2._r8
allconss(:) = 0._r8
allconss(ncorn) = 2._r8
allconss(nswheat) = 1._r8
allconss(nwwheat) = 1._r8
allconss(nsoybean) = 5._r8
ztopmx(:) = 0.00_r8
ztopmx(ncorn) = 2.50_r8
ztopmx(nswheat) = 1.20_r8
ztopmx(nwwheat) = 1.20_r8
ztopmx(nsoybean) = 0.75_r8
laimx(:) = 0._r8
laimx(ncorn) = 5._r8
laimx(nswheat) = 7._r8
laimx(nwwheat) = 7._r8
laimx(nsoybean) = 6._r8
gddmin(:) = 0._r8
gddmin(ncorn) = 50._r8
gddmin(nswheat) = 50._r8
gddmin(nwwheat) = 50._r8
gddmin(nsoybean) = 50._r8
hybgdd(:) = 0._r8
hybgdd(ncorn) = 1700._r8
hybgdd(nswheat) = 1700._r8
hybgdd(nwwheat) = 1700._r8
hybgdd(nsoybean) = 1900._r8
lfemerg(:) = 0.00_r8
lfemerg(ncorn) = 0.03_r8
lfemerg(nswheat) = 0.05_r8
lfemerg(nwwheat) = 0.05_r8
lfemerg(nsoybean) = 0.03_r8
grnfill(:) = 0.00_r8
grnfill(ncorn) = 0.65_r8
grnfill(nswheat) = 0.60_r8
grnfill(nwwheat) = 0.40_r8
grnfill(nsoybean) = 0.70_r8
mxmat(:) = 0
mxmat(ncorn) = 165
mxmat(nswheat) = 150
mxmat(nwwheat) = 265
mxmat(nsoybean) = 150
#endif
pftname(noveg) = 'not_vegetated'
z0mr(noveg) = 0._r8
displar(noveg) = 0._r8
dleaf(noveg) = 0._r8
c3psn(noveg) = 1._r8
vcmx25(noveg) = 0._r8
mp(noveg) = 9._r8
qe25(noveg) = 0._r8
rhol(noveg,1) = 0._r8
rhol(noveg,2) = 0._r8
rhos(noveg,1) = 0._r8
rhos(noveg,2) = 0._r8
taul(noveg,1) = 0._r8
taul(noveg,2) = 0._r8
taus(noveg,1) = 0._r8
taus(noveg,2) = 0._r8
xl(noveg) = 0._r8
roota_par(noveg) = 0._r8
rootb_par(noveg) = 0._r8
crop(noveg) = 0._r8
smpso(noveg) = 0._r8
smpsc(noveg) = 0._r8
fnitr(noveg) = 0._r8
slatop(noveg) = 0._r8
dsladlai(noveg) = 0._r8
leafcn(noveg) = 1._r8
flnr(noveg) = 0._r8
! begin variables used only for CN code
woody(noveg) = 0._r8
lflitcn(noveg) = 1._r8
frootcn(noveg) = 1._r8
livewdcn(noveg) = 1._r8
deadwdcn(noveg) = 1._r8
#if (defined CROP)
! begin variables used only for CROP
graincn(noveg) = 1._r8
mxtmp(noveg) = 0._r8
baset(noveg) = 0._r8
declfact(noveg) = 0._r8
bfact(noveg) = 0._r8
aleaff(noveg) = 0._r8
arootf(noveg) = 0._r8
astemf(noveg) = 0._r8
arooti(noveg) = 0._r8
fleafi(noveg) = 0._r8
allconsl(noveg) = 0._r8
allconss(noveg) = 0._r8
ztopmx(noveg) = 0._r8
laimx(noveg) = 0._r8
gddmin(noveg) = 0._r8
hybgdd(noveg) = 0._r8
lfemerg(noveg) = 0._r8
grnfill(noveg) = 0._r8
mxmat(noveg) = 0
! end variables used only for CROP
#endif
froot_leaf(noveg) = 0._r8
stem_leaf(noveg) = 0._r8
croot_stem(noveg) = 0._r8
flivewd(noveg) = 0._r8
fcur(noveg) = 0._r8
lf_flab(noveg) = 0._r8
lf_fcel(noveg) = 0._r8
lf_flig(noveg) = 0._r8
fr_flab(noveg) = 0._r8
fr_fcel(noveg) = 0._r8
fr_flig(noveg) = 0._r8
dw_fcel(noveg) = 0._r8
dw_flig(noveg) = 0._r8
leaf_long(noveg) = 0._r8
evergreen(noveg) = 0._r8
stress_decid(noveg) = 0._r8
season_decid(noveg) = 0._r8
resist(noveg) = 1._r8
pftpar20(noveg) = inf
pftpar28(noveg) = 9999.9_r8
pftpar29(noveg) = 1000.0_r8
pftpar30(noveg) = 0.0_r8
pftpar31(noveg) = 1000.0_r8
end subroutine pftconrd
end module pftvarcon
module pftdynMod 6,5
!---------------------------------------------------------------------------
!BOP
!
! !MODULE: pftdynMod
!
! !USES:
use clmtype
use decompMod , only : get_proc_bounds
use clm_varpar , only : max_pft_per_col
use shr_kind_mod, only : r8 => shr_kind_r8
use module_cam_support, only: endrun
!
! !DESCRIPTION:
! Determine pft weights at current time using dynamic landuse datasets.
! ASSUMES that only have one dynamic landuse dataset.
!
! !PUBLIC TYPES:
! implicit none
private
save
public :: pftdyn_init !not used 02/23/11 ylu
public :: pftdyn_interp !not used 02/23/11 ylu
public :: pftdyn_wbal_init !not used 02/23/11 ylu
public :: pftdyn_wbal !not used 02/23/11 ylu
#ifdef CN
public :: pftdyn_cnbal !Call in driver.F
#ifdef CNDV
public :: pftwt_init !not used 02/23/11 ylu
public :: pftwt_interp !not used 02/23/11 ylu
#endif
public :: CNHarvest !Call in CNEcosystemDynMod.F
public :: CNHarvestPftToColumn !not used 02/23/11 ylu
#endif
!
! !REVISION HISTORY:
! Created by Peter Thornton
! slevis modified to handle CNDV and CROP
! 19 May 2009: PET - modified to handle harvest fluxes
!
!EOP
!
! ! PRIVATE TYPES
real(r8), parameter :: days_per_year = 365._r8
integer , pointer :: yearspft(:)
real(r8), pointer :: wtpft1(:,:)
real(r8), pointer :: wtpft2(:,:)
real(r8), pointer :: harvest(:)
real(r8), pointer :: wtcol_old(:)
integer :: nt1
integer :: nt2
integer :: ntimes
logical :: do_harvest
integer :: ncid
!---------------------------------------------------------------------------
contains
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: pftdyn_cnbal
!
! !INTERFACE:
subroutine pftdyn_cnbal() 2,33
!
! !DESCRIPTION:
! modify pft-level state and flux variables to maintain carbon and nitrogen balance with
! dynamic pft-weights.
!
! !USES:
use shr_kind_mod, only : r8 => shr_kind_r8
use shr_const_mod,only : SHR_CONST_PDB
use decompMod , only : get_proc_bounds
use clm_varcon , only : istsoil
#ifdef CROP
use clm_varcon , only : istcrop
#endif
use clm_varpar , only : numveg, numpft
#if (defined C13)
use clm_varcon , only : c13ratio
#endif
! use clm_time_manager, only : get_step_size
use globals , only: dt
!
! !ARGUMENTS:
implicit none
!
!
! !LOCAL VARIABLES:
!EOP
integer :: begp, endp ! proc beginning and ending pft indices
integer :: begc, endc ! proc beginning and ending column indices
integer :: begl, endl ! proc beginning and ending landunit indices
integer :: begg, endg ! proc beginning and ending gridcell indices
integer :: pi,p,c,l,g ! indices
integer :: ier ! error code
real(r8) :: dwt ! change in pft weight (relative to column)
! real(r8) :: dt ! land model time step (sec)
real(r8) :: init_h2ocan ! initial canopy water mass
real(r8) :: new_h2ocan ! canopy water mass after weight shift
real(r8), allocatable :: dwt_leafc_seed(:) ! pft-level mass gain due to seeding of new area
real(r8), allocatable :: dwt_leafn_seed(:) ! pft-level mass gain due to seeding of new area
#if (defined C13)
real(r8), allocatable :: dwt_leafc13_seed(:) ! pft-level mass gain due to seeding of new area
#endif
real(r8), allocatable :: dwt_deadstemc_seed(:) ! pft-level mass gain due to seeding of new area
real(r8), allocatable :: dwt_deadstemn_seed(:) ! pft-level mass gain due to seeding of new area
#if (defined C13)
real(r8), allocatable :: dwt_deadstemc13_seed(:) ! pft-level mass gain due to seeding of new area
#endif
real(r8), allocatable :: dwt_frootc_to_litter(:) ! pft-level mass loss due to weight shift
real(r8), allocatable :: dwt_livecrootc_to_litter(:) ! pft-level mass loss due to weight shift
real(r8), allocatable :: dwt_deadcrootc_to_litter(:) ! pft-level mass loss due to weight shift
#if (defined C13)
real(r8), allocatable, target :: dwt_frootc13_to_litter(:) ! pft-level mass loss due to weight shift
real(r8), allocatable, target :: dwt_livecrootc13_to_litter(:) ! pft-level mass loss due to weight shift
real(r8), allocatable, target :: dwt_deadcrootc13_to_litter(:) ! pft-level mass loss due to weight shift
#endif
real(r8), allocatable, target :: dwt_frootn_to_litter(:) ! pft-level mass loss due to weight shift
real(r8), allocatable, target :: dwt_livecrootn_to_litter(:) ! pft-level mass loss due to weight shift
real(r8), allocatable, target :: dwt_deadcrootn_to_litter(:) ! pft-level mass loss due to weight shift
real(r8), allocatable :: conv_cflux(:) ! pft-level mass loss due to weight shift
real(r8), allocatable :: prod10_cflux(:) ! pft-level mass loss due to weight shift
real(r8), allocatable :: prod100_cflux(:) ! pft-level mass loss due to weight shift
#if (defined C13)
real(r8), allocatable, target :: conv_c13flux(:) ! pft-level mass loss due to weight shift
real(r8), allocatable, target :: prod10_c13flux(:) ! pft-level mass loss due to weight shift
real(r8), allocatable, target :: prod100_c13flux(:) ! pft-level mass loss due to weight shift
#endif
real(r8), allocatable, target :: conv_nflux(:) ! pft-level mass loss due to weight shift
real(r8), allocatable, target :: prod10_nflux(:) ! pft-level mass loss due to weight shift
real(r8), allocatable, target :: prod100_nflux(:) ! pft-level mass loss due to weight shift
#if (defined C13)
real(r8) :: c3_del13c ! typical del13C for C3 photosynthesis (permil, relative to PDB)
real(r8) :: c4_del13c ! typical del13C for C4 photosynthesis (permil, relative to PDB)
real(r8) :: c3_r1 ! isotope ratio (13c/12c) for C3 photosynthesis
real(r8) :: c4_r1 ! isotope ratio (13c/12c) for C4 photosynthesis
real(r8) :: c3_r2 ! isotope ratio (13c/[12c+13c]) for C3 photosynthesis
real(r8) :: c4_r2 ! isotope ratio (13c/[12c+13c]) for C4 photosynthesis
#endif
real(r8) :: t1,t2,wt_new,wt_old
real(r8) :: init_state, change_state, new_state
real(r8) :: tot_leaf, pleaf, pstor, pxfer
real(r8) :: leafc_seed, leafn_seed
real(r8) :: deadstemc_seed, deadstemn_seed
#if (defined C13)
real(r8) :: leafc13_seed, deadstemc13_seed
#endif
real(r8), pointer :: dwt_ptr0, dwt_ptr1, dwt_ptr2, dwt_ptr3, ptr
real(r8) :: pconv(0:numpft) ! proportion of deadstem to conversion flux
real(r8) :: pprod10(0:numpft) ! proportion of deadstem to 10-yr product pool
real(r8) :: pprod100(0:numpft) ! proportion of deadstem to 100-yr product pool
type(landunit_type), pointer :: lptr ! pointer to landunit derived subtype
type(column_type), pointer :: cptr ! pointer to column derived subtype
type(pft_type) , pointer :: pptr ! pointer to pft derived subtype
character(len=32) :: subname='pftdyn_cbal' ! subroutine name
!-----------------------------------------------------------------------
! (dangerous hardwiring) (should put this into pftphysiology file)
! set deadstem proportions
! veg type: 0 1 2 3 4 5 6 7 8 9 10 11 12 &
! 13 14 15 16
pconv(0:numveg) = &
(/0.0_r8, 0.6_r8, 0.6_r8, 0.6_r8, 0.6_r8, 0.6_r8, 0.6_r8, 0.6_r8, 0.6_r8, 0.8_r8, 0.8_r8, 0.8_r8, 1.0_r8, &
1.0_r8, 1.0_r8, 1.0_r8, 1.0_r8/)
pprod10(0:numveg) = &
(/0.0_r8, 0.3_r8, 0.3_r8, 0.3_r8, 0.4_r8, 0.3_r8, 0.4_r8, 0.3_r8, 0.3_r8, 0.2_r8, 0.2_r8, 0.2_r8, 0.0_r8, &
0.0_r8, 0.0_r8, 0.0_r8, 0.0_r8/)
pprod100(0:numveg) = &
(/0.0_r8, 0.1_r8, 0.1_r8, 0.1_r8, 0.0_r8, 0.1_r8, 0.0_r8, 0.1_r8, 0.1_r8, 0.0_r8, 0.0_r8, 0.0_r8, 0.0_r8, &
0.0_r8, 0.0_r8, 0.0_r8, 0.0_r8/)
#ifdef CROP
! 17 - 20 (dangerous hardwiring)
pconv(numveg+1:numpft) = 0.0_r8
pprod10(numveg+1:numpft) = 0.0_r8
pprod100(numveg+1:numpft) = 0.0_r8
#endif
! Set pointers into derived type
lptr => clm3%g%l
cptr => clm3%g%l%c
pptr => clm3%g%l%c%p
! Get relevant sizes
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! Allocate pft-level mass loss arrays
allocate(dwt_leafc_seed(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_leafc_seed'; call endrun()
end if
allocate(dwt_leafn_seed(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_leafn_seed'; call endrun()
end if
#if (defined C13)
allocate(dwt_leafc13_seed(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_leafc13_seed'; call endrun()
end if
#endif
allocate(dwt_deadstemc_seed(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_deadstemc_seed'; call endrun()
end if
allocate(dwt_deadstemn_seed(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_deadstemn_seed'; call endrun()
end if
#if (defined C13)
allocate(dwt_deadstemc13_seed(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_deadstemc13_seed'; call endrun()
end if
#endif
allocate(dwt_frootc_to_litter(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_frootc_to_litter'; call endrun()
end if
allocate(dwt_livecrootc_to_litter(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_livecrootc_to_litter'; call endrun()
end if
allocate(dwt_deadcrootc_to_litter(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_deadcrootc_to_litter'; call endrun()
end if
#if (defined C13)
allocate(dwt_frootc13_to_litter(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_frootc13_to_litter'; call endrun()
end if
allocate(dwt_livecrootc13_to_litter(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_livecrootc13_to_litter'; call endrun()
end if
allocate(dwt_deadcrootc13_to_litter(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_deadcrootc13_to_litter'; call endrun()
end if
#endif
allocate(dwt_frootn_to_litter(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_frootn_to_litter'; call endrun()
end if
allocate(dwt_livecrootn_to_litter(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_livecrootn_to_litter'; call endrun()
end if
allocate(dwt_deadcrootn_to_litter(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for dwt_deadcrootn_to_litter'; call endrun()
end if
allocate(conv_cflux(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for conv_cflux'; call endrun()
end if
allocate(prod10_cflux(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for prod10_cflux'; call endrun()
end if
allocate(prod100_cflux(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for prod100_cflux'; call endrun()
end if
#if (defined C13)
allocate(conv_c13flux(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for conv_c13flux'; call endrun()
end if
allocate(prod10_c13flux(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for prod10_c13flux'; call endrun()
end if
allocate(prod100_c13flux(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for prod100_c13flux'; call endrun()
end if
#endif
allocate(conv_nflux(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for conv_nflux'; call endrun()
end if
allocate(prod10_nflux(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for prod10_nflux'; call endrun()
end if
allocate(prod100_nflux(begp:endp), stat=ier)
if (ier /= 0) then
write(6,*)subname,' allocation error for prod100_nflux'; call endrun()
end if
! Get time step
! dt = real( get_step_size(), r8 )
do p = begp,endp
! initialize all the pft-level local flux arrays
dwt_leafc_seed(p) = 0._r8
dwt_leafn_seed(p) = 0._r8
#if (defined C13)
dwt_leafc13_seed(p) = 0._r8
#endif
dwt_deadstemc_seed(p) = 0._r8
dwt_deadstemn_seed(p) = 0._r8
#if (defined C13)
dwt_deadstemc13_seed(p) = 0._r8
#endif
dwt_frootc_to_litter(p) = 0._r8
dwt_livecrootc_to_litter(p) = 0._r8
dwt_deadcrootc_to_litter(p) = 0._r8
#if (defined C13)
dwt_frootc13_to_litter(p) = 0._r8
dwt_livecrootc13_to_litter(p) = 0._r8
dwt_deadcrootc13_to_litter(p) = 0._r8
#endif
dwt_frootn_to_litter(p) = 0._r8
dwt_livecrootn_to_litter(p) = 0._r8
dwt_deadcrootn_to_litter(p) = 0._r8
conv_cflux(p) = 0._r8
prod10_cflux(p) = 0._r8
prod100_cflux(p) = 0._r8
#if (defined C13)
conv_c13flux(p) = 0._r8
prod10_c13flux(p) = 0._r8
prod100_c13flux(p) = 0._r8
#endif
conv_nflux(p) = 0._r8
prod10_nflux(p) = 0._r8
prod100_nflux(p) = 0._r8
l = pptr%landunit(p)
c = pptr%column(p)
#if (defined CNDV) || (! defined CROP)
if (lptr%itype(l) == istsoil) then ! CNDV incompatible with dynLU
#else
if (lptr%itype(l) == istsoil .or. lptr%itype(l) == istcrop) then
#endif
! calculate the change in weight for the timestep
dwt = pptr%wtcol(p)-wtcol_old(p)
! PFTs for which weight increases on this timestep
if (dwt > 0._r8) then
! first identify PFTs that are initiating on this timestep
! and set all the necessary state and flux variables
if (wtcol_old(p) == 0._r8) then
! set initial conditions for PFT that is being initiated
! in this time step. Based on the settings in cnIniTimeVar.
! pft-level carbon state variables
pptr%pcs%leafc(p) = 0._r8
pptr%pcs%leafc_storage(p) = 0._r8
pptr%pcs%leafc_xfer(p) = 0._r8
pptr%pcs%frootc(p) = 0._r8
pptr%pcs%frootc_storage(p) = 0._r8
pptr%pcs%frootc_xfer(p) = 0._r8
pptr%pcs%livestemc(p) = 0._r8
pptr%pcs%livestemc_storage(p) = 0._r8
pptr%pcs%livestemc_xfer(p) = 0._r8
pptr%pcs%deadstemc(p) = 0._r8
pptr%pcs%deadstemc_storage(p) = 0._r8
pptr%pcs%deadstemc_xfer(p) = 0._r8
pptr%pcs%livecrootc(p) = 0._r8
pptr%pcs%livecrootc_storage(p) = 0._r8
pptr%pcs%livecrootc_xfer(p) = 0._r8
pptr%pcs%deadcrootc(p) = 0._r8
pptr%pcs%deadcrootc_storage(p) = 0._r8
pptr%pcs%deadcrootc_xfer(p) = 0._r8
pptr%pcs%gresp_storage(p) = 0._r8
pptr%pcs%gresp_xfer(p) = 0._r8
pptr%pcs%cpool(p) = 0._r8
pptr%pcs%xsmrpool(p) = 0._r8
pptr%pcs%pft_ctrunc(p) = 0._r8
pptr%pcs%dispvegc(p) = 0._r8
pptr%pcs%storvegc(p) = 0._r8
pptr%pcs%totvegc(p) = 0._r8
pptr%pcs%totpftc(p) = 0._r8
#if (defined C13)
! pft-level carbon-13 state variables
pptr%pc13s%leafc(p) = 0._r8
pptr%pc13s%leafc_storage(p) = 0._r8
pptr%pc13s%leafc_xfer(p) = 0._r8
pptr%pc13s%frootc(p) = 0._r8
pptr%pc13s%frootc_storage(p) = 0._r8
pptr%pc13s%frootc_xfer(p) = 0._r8
pptr%pc13s%livestemc(p) = 0._r8
pptr%pc13s%livestemc_storage(p) = 0._r8
pptr%pc13s%livestemc_xfer(p) = 0._r8
pptr%pc13s%deadstemc(p) = 0._r8
pptr%pc13s%deadstemc_storage(p) = 0._r8
pptr%pc13s%deadstemc_xfer(p) = 0._r8
pptr%pc13s%livecrootc(p) = 0._r8
pptr%pc13s%livecrootc_storage(p) = 0._r8
pptr%pc13s%livecrootc_xfer(p) = 0._r8
pptr%pc13s%deadcrootc(p) = 0._r8
pptr%pc13s%deadcrootc_storage(p) = 0._r8
pptr%pc13s%deadcrootc_xfer(p) = 0._r8
pptr%pc13s%gresp_storage(p) = 0._r8
pptr%pc13s%gresp_xfer(p) = 0._r8
pptr%pc13s%cpool(p) = 0._r8
pptr%pc13s%xsmrpool(p) = 0._r8
pptr%pc13s%pft_ctrunc(p) = 0._r8
pptr%pc13s%dispvegc(p) = 0._r8
pptr%pc13s%storvegc(p) = 0._r8
pptr%pc13s%totvegc(p) = 0._r8
pptr%pc13s%totpftc(p) = 0._r8
#endif
! pft-level nitrogen state variables
pptr%pns%leafn(p) = 0._r8
pptr%pns%leafn_storage(p) = 0._r8
pptr%pns%leafn_xfer(p) = 0._r8
pptr%pns%frootn(p) = 0._r8
pptr%pns%frootn_storage(p) = 0._r8
pptr%pns%frootn_xfer(p) = 0._r8
pptr%pns%livestemn(p) = 0._r8
pptr%pns%livestemn_storage(p) = 0._r8
pptr%pns%livestemn_xfer(p) = 0._r8
pptr%pns%deadstemn(p) = 0._r8
pptr%pns%deadstemn_storage(p) = 0._r8
pptr%pns%deadstemn_xfer(p) = 0._r8
pptr%pns%livecrootn(p) = 0._r8
pptr%pns%livecrootn_storage(p) = 0._r8
pptr%pns%livecrootn_xfer(p) = 0._r8
pptr%pns%deadcrootn(p) = 0._r8
pptr%pns%deadcrootn_storage(p) = 0._r8
pptr%pns%deadcrootn_xfer(p) = 0._r8
pptr%pns%retransn(p) = 0._r8
pptr%pns%npool(p) = 0._r8
pptr%pns%pft_ntrunc(p) = 0._r8
pptr%pns%dispvegn(p) = 0._r8
pptr%pns%storvegn(p) = 0._r8
pptr%pns%totvegn(p) = 0._r8
pptr%pns%totpftn (p) = 0._r8
! initialize same flux and epv variables that are set
! in CNiniTimeVar
pptr%pcf%psnsun(p) = 0._r8
pptr%pcf%psnsha(p) = 0._r8
#if (defined C13)
pptr%pc13f%psnsun(p) = 0._r8
pptr%pc13f%psnsha(p) = 0._r8
#endif
pptr%pps%laisun(p) = 0._r8
pptr%pps%laisha(p) = 0._r8
pptr%pps%lncsun(p) = 0._r8
pptr%pps%lncsha(p) = 0._r8
pptr%pps%vcmxsun(p) = 0._r8
pptr%pps%vcmxsha(p) = 0._r8
#if (defined C13)
pptr%pps%alphapsnsun(p) = 0._r8
pptr%pps%alphapsnsha(p) = 0._r8
#endif
pptr%pepv%dormant_flag(p) = 1._r8
pptr%pepv%days_active(p) = 0._r8
pptr%pepv%onset_flag(p) = 0._r8
pptr%pepv%onset_counter(p) = 0._r8
pptr%pepv%onset_gddflag(p) = 0._r8
pptr%pepv%onset_fdd(p) = 0._r8
pptr%pepv%onset_gdd(p) = 0._r8
pptr%pepv%onset_swi(p) = 0.0_r8
pptr%pepv%offset_flag(p) = 0._r8
pptr%pepv%offset_counter(p) = 0._r8
pptr%pepv%offset_fdd(p) = 0._r8
pptr%pepv%offset_swi(p) = 0._r8
pptr%pepv%lgsf(p) = 0._r8
pptr%pepv%bglfr(p) = 0._r8
pptr%pepv%bgtr(p) = 0._r8
! difference from CNiniTimeVar: using column-level
! information to initialize annavg_t2m.
pptr%pepv%annavg_t2m(p) = cptr%cps%cannavg_t2m(c)
pptr%pepv%tempavg_t2m(p) = 0._r8
pptr%pepv%gpp(p) = 0._r8
pptr%pepv%availc(p) = 0._r8
pptr%pepv%xsmrpool_recover(p) = 0._r8
#if (defined C13)
pptr%pepv%xsmrpool_c13ratio(p) = c13ratio
#endif
pptr%pepv%alloc_pnow(p) = 1._r8
pptr%pepv%c_allometry(p) = 0._r8
pptr%pepv%n_allometry(p) = 0._r8
pptr%pepv%plant_ndemand(p) = 0._r8
pptr%pepv%tempsum_potential_gpp(p) = 0._r8
pptr%pepv%annsum_potential_gpp(p) = 0._r8
pptr%pepv%tempmax_retransn(p) = 0._r8
pptr%pepv%annmax_retransn(p) = 0._r8
pptr%pepv%avail_retransn(p) = 0._r8
pptr%pepv%plant_nalloc(p) = 0._r8
pptr%pepv%plant_calloc(p) = 0._r8
pptr%pepv%excess_cflux(p) = 0._r8
pptr%pepv%downreg(p) = 0._r8
pptr%pepv%prev_leafc_to_litter(p) = 0._r8
pptr%pepv%prev_frootc_to_litter(p) = 0._r8
pptr%pepv%tempsum_npp(p) = 0._r8
pptr%pepv%annsum_npp(p) = 0._r8
#if (defined C13)
pptr%pepv%rc13_canair(p) = 0._r8
pptr%pepv%rc13_psnsun(p) = 0._r8
pptr%pepv%rc13_psnsha(p) = 0._r8
#endif
end if ! end initialization of new pft
! (still in dwt > 0 block)
! set the seed sources for leaf and deadstem
! leaf source is split later between leaf, leaf_storage, leaf_xfer
leafc_seed = 0._r8
leafn_seed = 0._r8
#if (defined C13)
leafc13_seed = 0._r8
#endif
deadstemc_seed = 0._r8
deadstemn_seed = 0._r8
#if (defined C13)
deadstemc13_seed = 0._r8
#endif
if (pptr%itype(p) /= 0) then
leafc_seed = 1._r8
leafn_seed = leafc_seed / pftcon%leafcn(pptr%itype(p))
if (pftcon%woody(pptr%itype(p)) == 1._r8) then
deadstemc_seed = 0.1_r8
deadstemn_seed = deadstemc_seed / pftcon%deadwdcn(pptr%itype(p))
end if
#if (defined C13)
! 13c state is initialized assuming del13c = -28 permil for C3, and -13 permil for C4.
! That translates to ratios of (13c/(12c+13c)) of 0.01080455 for C3, and 0.01096945 for C4
! based on the following formulae:
! r1 (13/12) = PDB + (del13c * PDB)/1000.0
! r2 (13/(13+12)) = r1/(1+r1)
! PDB = 0.0112372_R8 (ratio of 13C/12C in Pee Dee Belemnite, C isotope standard)
c3_del13c = -28._r8
c4_del13c = -13._r8
c3_r1 = SHR_CONST_PDB + ((c3_del13c*SHR_CONST_PDB)/1000._r8)
c3_r2 = c3_r1/(1._r8 + c3_r1)
c4_r1 = SHR_CONST_PDB + ((c4_del13c*SHR_CONST_PDB)/1000._r8)
c4_r2 = c4_r1/(1._r8 + c4_r1)
if (pftcon%c3psn(pptr%itype(p)) == 1._r8) then
leafc13_seed = leafc_seed * c3_r2
deadstemc13_seed = deadstemc_seed * c3_r2
else
leafc13_seed = leafc_seed * c4_r2
deadstemc13_seed = deadstemc_seed * c4_r2
end if
#endif
end if
! When PFT area expands (dwt > 0), the pft-level mass density
! is modified to conserve the original pft mass distributed
! over the new (larger) area, plus a term to account for the
! introduction of new seed source for leaf and deadstem
t1 = wtcol_old(p)/pptr%wtcol(p)
t2 = dwt/pptr%wtcol(p)
tot_leaf = pptr%pcs%leafc(p) + pptr%pcs%leafc_storage(p) + pptr%pcs%leafc_xfer(p)
pleaf = 0._r8
pstor = 0._r8
pxfer = 0._r8
if (tot_leaf /= 0._r8) then
! when adding seed source to non-zero leaf state, use current proportions
pleaf = pptr%pcs%leafc(p)/tot_leaf
pstor = pptr%pcs%leafc_storage(p)/tot_leaf
pxfer = pptr%pcs%leafc_xfer(p)/tot_leaf
else
! when initiating from zero leaf state, use evergreen flag to set proportions
if (pftcon%evergreen(pptr%itype(p)) == 1._r8) then
pleaf = 1._r8
else
pstor = 1._r8
end if
end if
pptr%pcs%leafc(p) = pptr%pcs%leafc(p)*t1 + leafc_seed*pleaf*t2
pptr%pcs%leafc_storage(p) = pptr%pcs%leafc_storage(p)*t1 + leafc_seed*pstor*t2
pptr%pcs%leafc_xfer(p) = pptr%pcs%leafc_xfer(p)*t1 + leafc_seed*pxfer*t2
pptr%pcs%frootc(p) = pptr%pcs%frootc(p) * t1
pptr%pcs%frootc_storage(p) = pptr%pcs%frootc_storage(p) * t1
pptr%pcs%frootc_xfer(p) = pptr%pcs%frootc_xfer(p) * t1
pptr%pcs%livestemc(p) = pptr%pcs%livestemc(p) * t1
pptr%pcs%livestemc_storage(p) = pptr%pcs%livestemc_storage(p) * t1
pptr%pcs%livestemc_xfer(p) = pptr%pcs%livestemc_xfer(p) * t1
pptr%pcs%deadstemc(p) = pptr%pcs%deadstemc(p)*t1 + deadstemc_seed*t2
pptr%pcs%deadstemc_storage(p) = pptr%pcs%deadstemc_storage(p) * t1
pptr%pcs%deadstemc_xfer(p) = pptr%pcs%deadstemc_xfer(p) * t1
pptr%pcs%livecrootc(p) = pptr%pcs%livecrootc(p) * t1
pptr%pcs%livecrootc_storage(p) = pptr%pcs%livecrootc_storage(p) * t1
pptr%pcs%livecrootc_xfer(p) = pptr%pcs%livecrootc_xfer(p) * t1
pptr%pcs%deadcrootc(p) = pptr%pcs%deadcrootc(p) * t1
pptr%pcs%deadcrootc_storage(p) = pptr%pcs%deadcrootc_storage(p) * t1
pptr%pcs%deadcrootc_xfer(p) = pptr%pcs%deadcrootc_xfer(p) * t1
pptr%pcs%gresp_storage(p) = pptr%pcs%gresp_storage(p) * t1
pptr%pcs%gresp_xfer(p) = pptr%pcs%gresp_xfer(p) * t1
pptr%pcs%cpool(p) = pptr%pcs%cpool(p) * t1
pptr%pcs%xsmrpool(p) = pptr%pcs%xsmrpool(p) * t1
pptr%pcs%pft_ctrunc(p) = pptr%pcs%pft_ctrunc(p) * t1
pptr%pcs%dispvegc(p) = pptr%pcs%dispvegc(p) * t1
pptr%pcs%storvegc(p) = pptr%pcs%storvegc(p) * t1
pptr%pcs%totvegc(p) = pptr%pcs%totvegc(p) * t1
pptr%pcs%totpftc(p) = pptr%pcs%totpftc(p) * t1
#if (defined C13)
! pft-level carbon-13 state variables
tot_leaf = pptr%pc13s%leafc(p) + pptr%pc13s%leafc_storage(p) + pptr%pc13s%leafc_xfer(p)
pleaf = 0._r8
pstor = 0._r8
pxfer = 0._r8
if (tot_leaf /= 0._r8) then
pleaf = pptr%pc13s%leafc(p)/tot_leaf
pstor = pptr%pc13s%leafc_storage(p)/tot_leaf
pxfer = pptr%pc13s%leafc_xfer(p)/tot_leaf
else
! when initiating from zero leaf state, use evergreen flag to set proportions
if (pftcon%evergreen(pptr%itype(p)) == 1._r8) then
pleaf = 1._r8
else
pstor = 1._r8
end if
end if
pptr%pc13s%leafc(p) = pptr%pc13s%leafc(p)*t1 + leafc13_seed*pleaf*t2
pptr%pc13s%leafc_storage(p) = pptr%pc13s%leafc_storage(p)*t1 + leafc13_seed*pstor*t2
pptr%pc13s%leafc_xfer(p) = pptr%pc13s%leafc_xfer(p)*t1 + leafc13_seed*pxfer*t2
pptr%pc13s%frootc(p) = pptr%pc13s%frootc(p) * t1
pptr%pc13s%frootc_storage(p) = pptr%pc13s%frootc_storage(p) * t1
pptr%pc13s%frootc_xfer(p) = pptr%pc13s%frootc_xfer(p) * t1
pptr%pc13s%livestemc(p) = pptr%pc13s%livestemc(p) * t1
pptr%pc13s%livestemc_storage(p) = pptr%pc13s%livestemc_storage(p) * t1
pptr%pc13s%livestemc_xfer(p) = pptr%pc13s%livestemc_xfer(p) * t1
pptr%pc13s%deadstemc(p) = pptr%pc13s%deadstemc(p)*t1 + deadstemc13_seed*t2
pptr%pc13s%deadstemc_storage(p) = pptr%pc13s%deadstemc_storage(p) * t1
pptr%pc13s%deadstemc_xfer(p) = pptr%pc13s%deadstemc_xfer(p) * t1
pptr%pc13s%livecrootc(p) = pptr%pc13s%livecrootc(p) * t1
pptr%pc13s%livecrootc_storage(p) = pptr%pc13s%livecrootc_storage(p) * t1
pptr%pc13s%livecrootc_xfer(p) = pptr%pc13s%livecrootc_xfer(p) * t1
pptr%pc13s%deadcrootc(p) = pptr%pc13s%deadcrootc(p) * t1
pptr%pc13s%deadcrootc_storage(p) = pptr%pc13s%deadcrootc_storage(p) * t1
pptr%pc13s%deadcrootc_xfer(p) = pptr%pc13s%deadcrootc_xfer(p) * t1
pptr%pc13s%gresp_storage(p) = pptr%pc13s%gresp_storage(p) * t1
pptr%pc13s%gresp_xfer(p) = pptr%pc13s%gresp_xfer(p) * t1
pptr%pc13s%cpool(p) = pptr%pc13s%cpool(p) * t1
pptr%pc13s%xsmrpool(p) = pptr%pc13s%xsmrpool(p) * t1
pptr%pc13s%pft_ctrunc(p) = pptr%pc13s%pft_ctrunc(p) * t1
pptr%pc13s%dispvegc(p) = pptr%pc13s%dispvegc(p) * t1
pptr%pc13s%storvegc(p) = pptr%pc13s%storvegc(p) * t1
pptr%pc13s%totvegc(p) = pptr%pc13s%totvegc(p) * t1
pptr%pc13s%totpftc(p) = pptr%pc13s%totpftc(p) * t1
#endif
tot_leaf = pptr%pns%leafn(p) + pptr%pns%leafn_storage(p) + pptr%pns%leafn_xfer(p)
pleaf = 0._r8
pstor = 0._r8
pxfer = 0._r8
if (tot_leaf /= 0._r8) then
pleaf = pptr%pns%leafn(p)/tot_leaf
pstor = pptr%pns%leafn_storage(p)/tot_leaf
pxfer = pptr%pns%leafn_xfer(p)/tot_leaf
else
! when initiating from zero leaf state, use evergreen flag to set proportions
if (pftcon%evergreen(pptr%itype(p)) == 1._r8) then
pleaf = 1._r8
else
pstor = 1._r8
end if
end if
! pft-level nitrogen state variables
pptr%pns%leafn(p) = pptr%pns%leafn(p)*t1 + leafn_seed*pleaf*t2
pptr%pns%leafn_storage(p) = pptr%pns%leafn_storage(p)*t1 + leafn_seed*pstor*t2
pptr%pns%leafn_xfer(p) = pptr%pns%leafn_xfer(p)*t1 + leafn_seed*pxfer*t2
pptr%pns%frootn(p) = pptr%pns%frootn(p) * t1
pptr%pns%frootn_storage(p) = pptr%pns%frootn_storage(p) * t1
pptr%pns%frootn_xfer(p) = pptr%pns%frootn_xfer(p) * t1
pptr%pns%livestemn(p) = pptr%pns%livestemn(p) * t1
pptr%pns%livestemn_storage(p) = pptr%pns%livestemn_storage(p) * t1
pptr%pns%livestemn_xfer(p) = pptr%pns%livestemn_xfer(p) * t1
pptr%pns%deadstemn(p) = pptr%pns%deadstemn(p)*t1 + deadstemn_seed*t2
pptr%pns%deadstemn_storage(p) = pptr%pns%deadstemn_storage(p) * t1
pptr%pns%deadstemn_xfer(p) = pptr%pns%deadstemn_xfer(p) * t1
pptr%pns%livecrootn(p) = pptr%pns%livecrootn(p) * t1
pptr%pns%livecrootn_storage(p) = pptr%pns%livecrootn_storage(p) * t1
pptr%pns%livecrootn_xfer(p) = pptr%pns%livecrootn_xfer(p) * t1
pptr%pns%deadcrootn(p) = pptr%pns%deadcrootn(p) * t1
pptr%pns%deadcrootn_storage(p) = pptr%pns%deadcrootn_storage(p) * t1
pptr%pns%deadcrootn_xfer(p) = pptr%pns%deadcrootn_xfer(p) * t1
pptr%pns%retransn(p) = pptr%pns%retransn(p) * t1
pptr%pns%npool(p) = pptr%pns%npool(p) * t1
pptr%pns%pft_ntrunc(p) = pptr%pns%pft_ntrunc(p) * t1
pptr%pns%dispvegn(p) = pptr%pns%dispvegn(p) * t1
pptr%pns%storvegn(p) = pptr%pns%storvegn(p) * t1
pptr%pns%totvegn(p) = pptr%pns%totvegn(p) * t1
pptr%pns%totpftn(p) = pptr%pns%totpftn(p) * t1
! update temporary seed source arrays
! These are calculated in terms of the required contributions from
! column-level seed source
dwt_leafc_seed(p) = leafc_seed * dwt
#if (defined C13)
dwt_leafc13_seed(p) = leafc13_seed * dwt
#endif
dwt_leafn_seed(p) = leafn_seed * dwt
dwt_deadstemc_seed(p) = deadstemc_seed * dwt
#if (defined C13)
dwt_deadstemc13_seed(p) = deadstemc13_seed * dwt
#endif
dwt_deadstemn_seed(p) = deadstemn_seed * dwt
else if (dwt < 0._r8) then
! if the pft lost weight on the timestep, then the carbon and nitrogen state
! variables are directed to litter, CWD, and wood product pools.
! N.B. : the conv_cflux, prod10_cflux, and prod100_cflux fluxes are accumulated
! as negative values, but the fluxes for pft-to-litter are accumulated as
! positive values
! set local weight variables for this pft
wt_new = pptr%wtcol(p)
wt_old = wtcol_old(p)
!---------------
! C state update
!---------------
! leafc
ptr => pptr%pcs%leafc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! leafc_storage
ptr => pptr%pcs%leafc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! leafc_xfer
ptr => pptr%pcs%leafc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! frootc
ptr => pptr%pcs%frootc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_frootc_to_litter(p) = dwt_frootc_to_litter(p) - change_state
else
ptr = 0._r8
dwt_frootc_to_litter(p) = dwt_frootc_to_litter(p) + init_state
end if
! frootc_storage
ptr => pptr%pcs%frootc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! frootc_xfer
ptr => pptr%pcs%frootc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! livestemc
ptr => pptr%pcs%livestemc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! livestemc_storage
ptr => pptr%pcs%livestemc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! livestemc_xfer
ptr => pptr%pcs%livestemc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! deadstemc
ptr => pptr%pcs%deadstemc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state*pconv(pptr%itype(p))
prod10_cflux(p) = prod10_cflux(p) + change_state*pprod10(pptr%itype(p))
prod100_cflux(p) = prod100_cflux(p) + change_state*pprod100(pptr%itype(p))
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state*pconv(pptr%itype(p))
prod10_cflux(p) = prod10_cflux(p) - init_state*pprod10(pptr%itype(p))
prod100_cflux(p) = prod100_cflux(p) - init_state*pprod100(pptr%itype(p))
end if
! deadstemc_storage
ptr => pptr%pcs%deadstemc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! deadstemc_xfer
ptr => pptr%pcs%deadstemc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! livecrootc
ptr => pptr%pcs%livecrootc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_livecrootc_to_litter(p) = dwt_livecrootc_to_litter(p) - change_state
else
ptr = 0._r8
dwt_livecrootc_to_litter(p) = dwt_livecrootc_to_litter(p) + init_state
end if
! livecrootc_storage
ptr => pptr%pcs%livecrootc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! livecrootc_xfer
ptr => pptr%pcs%livecrootc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! deadcrootc
ptr => pptr%pcs%deadcrootc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_deadcrootc_to_litter(p) = dwt_deadcrootc_to_litter(p) - change_state
else
ptr = 0._r8
dwt_deadcrootc_to_litter(p) = dwt_deadcrootc_to_litter(p) + init_state
end if
! deadcrootc_storage
ptr => pptr%pcs%deadcrootc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! deadcrootc_xfer
ptr => pptr%pcs%deadcrootc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! gresp_storage
ptr => pptr%pcs%gresp_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! gresp_xfer
ptr => pptr%pcs%gresp_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! cpool
ptr => pptr%pcs%cpool(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! xsmrpool
ptr => pptr%pcs%xsmrpool(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
! pft_ctrunc
ptr => pptr%pcs%pft_ctrunc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
conv_cflux(p) = conv_cflux(p) + change_state
else
ptr = 0._r8
conv_cflux(p) = conv_cflux(p) - init_state
end if
#if (defined C13)
!-----------------
! C13 state update
!-----------------
! set pointers to the conversion and product pool fluxes for this pft
! dwt_ptr0 is reserved for local assignment to dwt_xxx_to_litter fluxes
dwt_ptr1 => conv_c13flux(p)
dwt_ptr2 => prod10_c13flux(p)
dwt_ptr3 => prod100_c13flux(p)
! leafc
ptr => pptr%pc13s%leafc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! leafc_storage
ptr => pptr%pc13s%leafc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! leafc_xfer
ptr => pptr%pc13s%leafc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! frootc
ptr => pptr%pc13s%frootc(p)
dwt_ptr0 => dwt_frootc13_to_litter(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr0 = dwt_ptr0 - change_state
else
ptr = 0._r8
dwt_ptr0 = dwt_ptr0 + init_state
end if
! frootc_storage
ptr => pptr%pc13s%frootc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! frootc_xfer
ptr => pptr%pc13s%frootc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livestemc
ptr => pptr%pc13s%livestemc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livestemc_storage
ptr => pptr%pc13s%livestemc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livestemc_xfer
ptr => pptr%pc13s%livestemc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! deadstemc
ptr => pptr%pc13s%deadstemc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state*pconv(pptr%itype(p))
dwt_ptr2 = dwt_ptr2 + change_state*pprod10(pptr%itype(p))
dwt_ptr3 = dwt_ptr3 + change_state*pprod100(pptr%itype(p))
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state*pconv(pptr%itype(p))
dwt_ptr2 = dwt_ptr2 - init_state*pprod10(pptr%itype(p))
dwt_ptr3 = dwt_ptr3 - init_state*pprod100(pptr%itype(p))
end if
! deadstemc_storage
ptr => pptr%pc13s%deadstemc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! deadstemc_xfer
ptr => pptr%pc13s%deadstemc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livecrootc
ptr => pptr%pc13s%livecrootc(p)
dwt_ptr0 => dwt_livecrootc13_to_litter(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr0 = dwt_ptr0 - change_state
else
ptr = 0._r8
dwt_ptr0 = dwt_ptr0 + init_state
end if
! livecrootc_storage
ptr => pptr%pc13s%livecrootc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livecrootc_xfer
ptr => pptr%pc13s%livecrootc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! deadcrootc
ptr => pptr%pc13s%deadcrootc(p)
dwt_ptr0 => dwt_deadcrootc13_to_litter(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr0 = dwt_ptr0 - change_state
else
ptr = 0._r8
dwt_ptr0 = dwt_ptr0 + init_state
end if
! deadcrootc_storage
ptr => pptr%pc13s%deadcrootc_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! deadcrootc_xfer
ptr => pptr%pc13s%deadcrootc_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! gresp_storage
ptr => pptr%pc13s%gresp_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! gresp_xfer
ptr => pptr%pc13s%gresp_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! cpool
ptr => pptr%pc13s%cpool(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! pft_ctrunc
ptr => pptr%pc13s%pft_ctrunc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
#endif
!---------------
! N state update
!---------------
! set pointers to the conversion and product pool fluxes for this pft
! dwt_ptr0 is reserved for local assignment to dwt_xxx_to_litter fluxes
dwt_ptr1 => conv_nflux(p)
dwt_ptr2 => prod10_nflux(p)
dwt_ptr3 => prod100_nflux(p)
! leafn
ptr => pptr%pns%leafn(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! leafn_storage
ptr => pptr%pns%leafn_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! leafn_xfer
ptr => pptr%pns%leafn_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! frootn
ptr => pptr%pns%frootn(p)
dwt_ptr0 => dwt_frootn_to_litter(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr0 = dwt_ptr0 - change_state
else
ptr = 0._r8
dwt_ptr0 = dwt_ptr0 + init_state
end if
! frootn_storage
ptr => pptr%pns%frootn_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! frootn_xfer
ptr => pptr%pns%frootn_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livestemn
ptr => pptr%pns%livestemn(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livestemn_storage
ptr => pptr%pns%livestemn_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livestemn_xfer
ptr => pptr%pns%livestemn_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! deadstemn
ptr => pptr%pns%deadstemn(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state*pconv(pptr%itype(p))
dwt_ptr2 = dwt_ptr2 + change_state*pprod10(pptr%itype(p))
dwt_ptr3 = dwt_ptr3 + change_state*pprod100(pptr%itype(p))
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state*pconv(pptr%itype(p))
dwt_ptr2 = dwt_ptr2 - init_state*pprod10(pptr%itype(p))
dwt_ptr3 = dwt_ptr3 - init_state*pprod100(pptr%itype(p))
end if
! deadstemn_storage
ptr => pptr%pns%deadstemn_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! deadstemn_xfer
ptr => pptr%pns%deadstemn_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livecrootn
ptr => pptr%pns%livecrootn(p)
dwt_ptr0 => dwt_livecrootn_to_litter(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr0 = dwt_ptr0 - change_state
else
ptr = 0._r8
dwt_ptr0 = dwt_ptr0 + init_state
end if
! livecrootn_storage
ptr => pptr%pns%livecrootn_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! livecrootn_xfer
ptr => pptr%pns%livecrootn_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! deadcrootn
ptr => pptr%pns%deadcrootn(p)
dwt_ptr0 => dwt_deadcrootn_to_litter(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr0 = dwt_ptr0 - change_state
else
ptr = 0._r8
dwt_ptr0 = dwt_ptr0 + init_state
end if
! deadcrootn_storage
ptr => pptr%pns%deadcrootn_storage(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! deadcrootn_xfer
ptr => pptr%pns%deadcrootn_xfer(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! retransn
ptr => pptr%pns%retransn(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! npool
ptr => pptr%pns%npool(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
! pft_ntrunc
ptr => pptr%pns%pft_ntrunc(p)
init_state = ptr*wt_old
change_state = ptr*dwt
new_state = init_state+change_state
if (wt_new /= 0._r8) then
ptr = new_state/wt_new
dwt_ptr1 = dwt_ptr1 + change_state
else
ptr = 0._r8
dwt_ptr1 = dwt_ptr1 - init_state
end if
end if ! weight decreasing
end if ! is soil
end do ! pft loop
! calculate column-level seeding fluxes
do pi = 1,max_pft_per_col
do c = begc, endc
if ( pi <= cptr%npfts(c) ) then
p = cptr%pfti(c) + pi - 1
! C fluxes
cptr%ccf%dwt_seedc_to_leaf(c) = cptr%ccf%dwt_seedc_to_leaf(c) + dwt_leafc_seed(p)/dt
cptr%ccf%dwt_seedc_to_deadstem(c) = cptr%ccf%dwt_seedc_to_deadstem(c) &
+ dwt_deadstemc_seed(p)/dt
#if (defined C13)
! C13 fluxes
cptr%cc13f%dwt_seedc_to_leaf(c) = cptr%cc13f%dwt_seedc_to_leaf(c) + dwt_leafc13_seed(p)/dt
cptr%cc13f%dwt_seedc_to_deadstem(c) = cptr%cc13f%dwt_seedc_to_deadstem(c) &
+ dwt_deadstemc13_seed(p)/dt
#endif
! N fluxes
cptr%cnf%dwt_seedn_to_leaf(c) = cptr%cnf%dwt_seedn_to_leaf(c) + dwt_leafn_seed(p)/dt
cptr%cnf%dwt_seedn_to_deadstem(c) = cptr%cnf%dwt_seedn_to_deadstem(c) &
+ dwt_deadstemn_seed(p)/dt
end if
end do
end do
! calculate pft-to-column for fluxes into litter and CWD pools
do pi = 1,max_pft_per_col
do c = begc, endc
if ( pi <= cptr%npfts(c) ) then
p = cptr%pfti(c) + pi - 1
! fine root litter carbon fluxes
cptr%ccf%dwt_frootc_to_litr1c(c) = cptr%ccf%dwt_frootc_to_litr1c(c) + &
(dwt_frootc_to_litter(p)*pftcon%fr_flab(pptr%itype(p)))/dt
cptr%ccf%dwt_frootc_to_litr2c(c) = cptr%ccf%dwt_frootc_to_litr2c(c) + &
(dwt_frootc_to_litter(p)*pftcon%fr_fcel(pptr%itype(p)))/dt
cptr%ccf%dwt_frootc_to_litr3c(c) = cptr%ccf%dwt_frootc_to_litr3c(c) + &
(dwt_frootc_to_litter(p)*pftcon%fr_flig(pptr%itype(p)))/dt
#if (defined C13)
! fine root litter C13 fluxes
cptr%cc13f%dwt_frootc_to_litr1c(c) = cptr%cc13f%dwt_frootc_to_litr1c(c) + &
(dwt_frootc13_to_litter(p)*pftcon%fr_flab(pptr%itype(p)))/dt
cptr%cc13f%dwt_frootc_to_litr2c(c) = cptr%cc13f%dwt_frootc_to_litr2c(c) + &
(dwt_frootc13_to_litter(p)*pftcon%fr_fcel(pptr%itype(p)))/dt
cptr%cc13f%dwt_frootc_to_litr3c(c) = cptr%cc13f%dwt_frootc_to_litr3c(c) + &
(dwt_frootc13_to_litter(p)*pftcon%fr_flig(pptr%itype(p)))/dt
#endif
! fine root litter nitrogen fluxes
cptr%cnf%dwt_frootn_to_litr1n(c) = cptr%cnf%dwt_frootn_to_litr1n(c) + &
(dwt_frootn_to_litter(p)*pftcon%fr_flab(pptr%itype(p)))/dt
cptr%cnf%dwt_frootn_to_litr2n(c) = cptr%cnf%dwt_frootn_to_litr2n(c) + &
(dwt_frootn_to_litter(p)*pftcon%fr_fcel(pptr%itype(p)))/dt
cptr%cnf%dwt_frootn_to_litr3n(c) = cptr%cnf%dwt_frootn_to_litr3n(c) + &
(dwt_frootn_to_litter(p)*pftcon%fr_flig(pptr%itype(p)))/dt
! livecroot fluxes to cwd
cptr%ccf%dwt_livecrootc_to_cwdc(c) = cptr%ccf%dwt_livecrootc_to_cwdc(c) + &
(dwt_livecrootc_to_litter(p))/dt
#if (defined C13)
cptr%cc13f%dwt_livecrootc_to_cwdc(c) = cptr%cc13f%dwt_livecrootc_to_cwdc(c) + &
(dwt_livecrootc13_to_litter(p))/dt
#endif
cptr%cnf%dwt_livecrootn_to_cwdn(c) = cptr%cnf%dwt_livecrootn_to_cwdn(c) + &
(dwt_livecrootn_to_litter(p))/dt
! deadcroot fluxes to cwd
cptr%ccf%dwt_deadcrootc_to_cwdc(c) = cptr%ccf%dwt_deadcrootc_to_cwdc(c) + &
(dwt_deadcrootc_to_litter(p))/dt
#if (defined C13)
cptr%cc13f%dwt_deadcrootc_to_cwdc(c) = cptr%cc13f%dwt_deadcrootc_to_cwdc(c) + &
(dwt_deadcrootc13_to_litter(p))/dt
#endif
cptr%cnf%dwt_deadcrootn_to_cwdn(c) = cptr%cnf%dwt_deadcrootn_to_cwdn(c) + &
(dwt_deadcrootn_to_litter(p))/dt
end if
end do
end do
! calculate pft-to-column for fluxes into product pools and conversion flux
do pi = 1,max_pft_per_col
do c = begc,endc
if (pi <= cptr%npfts(c)) then
p = cptr%pfti(c) + pi - 1
! column-level fluxes are accumulated as positive fluxes.
! column-level C flux updates
cptr%ccf%dwt_conv_cflux(c) = cptr%ccf%dwt_conv_cflux(c) - conv_cflux(p)/dt
cptr%ccf%dwt_prod10c_gain(c) = cptr%ccf%dwt_prod10c_gain(c) - prod10_cflux(p)/dt
cptr%ccf%dwt_prod100c_gain(c) = cptr%ccf%dwt_prod100c_gain(c) - prod100_cflux(p)/dt
#if (defined C13)
! column-level C13 flux updates
cptr%cc13f%dwt_conv_cflux(c) = cptr%cc13f%dwt_conv_cflux(c) - conv_c13flux(p)/dt
cptr%cc13f%dwt_prod10c_gain(c) = cptr%cc13f%dwt_prod10c_gain(c) - prod10_c13flux(p)/dt
cptr%cc13f%dwt_prod100c_gain(c) = cptr%cc13f%dwt_prod100c_gain(c) - prod100_c13flux(p)/dt
#endif
! column-level N flux updates
cptr%cnf%dwt_conv_nflux(c) = cptr%cnf%dwt_conv_nflux(c) - conv_nflux(p)/dt
cptr%cnf%dwt_prod10n_gain(c) = cptr%cnf%dwt_prod10n_gain(c) - prod10_nflux(p)/dt
cptr%cnf%dwt_prod100n_gain(c) = cptr%cnf%dwt_prod100n_gain(c) - prod100_nflux(p)/dt
end if
end do
end do
! Deallocate pft-level flux arrays
deallocate(dwt_leafc_seed)
deallocate(dwt_leafn_seed)
#if (defined C13)
deallocate(dwt_leafc13_seed)
#endif
deallocate(dwt_deadstemc_seed)
deallocate(dwt_deadstemn_seed)
#if (defined C13)
deallocate(dwt_deadstemc13_seed)
#endif
deallocate(dwt_frootc_to_litter)
deallocate(dwt_livecrootc_to_litter)
deallocate(dwt_deadcrootc_to_litter)
#if (defined C13)
deallocate(dwt_frootc13_to_litter)
deallocate(dwt_livecrootc13_to_litter)
deallocate(dwt_deadcrootc13_to_litter)
#endif
deallocate(dwt_frootn_to_litter)
deallocate(dwt_livecrootn_to_litter)
deallocate(dwt_deadcrootn_to_litter)
deallocate(conv_cflux)
deallocate(prod10_cflux)
deallocate(prod100_cflux)
#if (defined C13)
deallocate(conv_c13flux)
deallocate(prod10_c13flux)
deallocate(prod100_c13flux)
#endif
deallocate(conv_nflux)
deallocate(prod10_nflux)
deallocate(prod100_nflux)
end subroutine pftdyn_cnbal
#endif
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNHarvest
!
! !INTERFACE:
subroutine CNHarvest (num_soilc, filter_soilc, num_soilp, filter_soilp) 1,3
!
! !DESCRIPTION:
! Harvest mortality routine for coupled carbon-nitrogen code (CN)
!
! !USES:
use clmtype
use pftvarcon, only : noveg, nbrdlf_evr_shrub
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! column filter for soil points
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! pft filter for soil points
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 3/29/04: Created by Peter Thornton
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arrays
integer , pointer :: pgridcell(:) ! pft-level index into gridcell-level quantities
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: xsmrpool(:) ! (gC/m2) abstract C pool to meet excess MR demand
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
!
! local pointers to implicit in/out arrays
!
! local pointers to implicit out arrays
real(r8), pointer :: hrv_leafc_to_litter(:)
real(r8), pointer :: hrv_frootc_to_litter(:)
real(r8), pointer :: hrv_livestemc_to_litter(:)
real(r8), pointer :: hrv_deadstemc_to_prod10c(:)
real(r8), pointer :: hrv_deadstemc_to_prod100c(:)
real(r8), pointer :: hrv_livecrootc_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_to_litter(:)
real(r8), pointer :: hrv_xsmrpool_to_atm(:)
real(r8), pointer :: hrv_leafc_storage_to_litter(:)
real(r8), pointer :: hrv_frootc_storage_to_litter(:)
real(r8), pointer :: hrv_livestemc_storage_to_litter(:)
real(r8), pointer :: hrv_deadstemc_storage_to_litter(:)
real(r8), pointer :: hrv_livecrootc_storage_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_storage_to_litter(:)
real(r8), pointer :: hrv_gresp_storage_to_litter(:)
real(r8), pointer :: hrv_leafc_xfer_to_litter(:)
real(r8), pointer :: hrv_frootc_xfer_to_litter(:)
real(r8), pointer :: hrv_livestemc_xfer_to_litter(:)
real(r8), pointer :: hrv_deadstemc_xfer_to_litter(:)
real(r8), pointer :: hrv_livecrootc_xfer_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_xfer_to_litter(:)
real(r8), pointer :: hrv_gresp_xfer_to_litter(:)
real(r8), pointer :: hrv_leafn_to_litter(:)
real(r8), pointer :: hrv_frootn_to_litter(:)
real(r8), pointer :: hrv_livestemn_to_litter(:)
real(r8), pointer :: hrv_deadstemn_to_prod10n(:)
real(r8), pointer :: hrv_deadstemn_to_prod100n(:)
real(r8), pointer :: hrv_livecrootn_to_litter(:)
real(r8), pointer :: hrv_deadcrootn_to_litter(:)
real(r8), pointer :: hrv_retransn_to_litter(:)
real(r8), pointer :: hrv_leafn_storage_to_litter(:)
real(r8), pointer :: hrv_frootn_storage_to_litter(:)
real(r8), pointer :: hrv_livestemn_storage_to_litter(:)
real(r8), pointer :: hrv_deadstemn_storage_to_litter(:)
real(r8), pointer :: hrv_livecrootn_storage_to_litter(:)
real(r8), pointer :: hrv_deadcrootn_storage_to_litter(:)
real(r8), pointer :: hrv_leafn_xfer_to_litter(:)
real(r8), pointer :: hrv_frootn_xfer_to_litter(:)
real(r8), pointer :: hrv_livestemn_xfer_to_litter(:)
real(r8), pointer :: hrv_deadstemn_xfer_to_litter(:)
real(r8), pointer :: hrv_livecrootn_xfer_to_litter(:)
real(r8), pointer :: hrv_deadcrootn_xfer_to_litter(:)
!
! !OTHER LOCAL VARIABLES:
integer :: p ! pft index
integer :: g ! gridcell index
integer :: fp ! pft filter index
real(r8):: am ! rate for fractional harvest mortality (1/yr)
real(r8):: m ! rate for fractional harvest mortality (1/s)
real(r8) :: pprod10(1:8) ! proportion of deadstem to 10-yr product pool (for tree pfts - 1 through 8)
!EOP
!-----------------------------------------------------------------------
! assign local pointers to pft-level arrays
pgridcell => clm3%g%l%c%p%gridcell
ivt => clm3%g%l%c%p%itype
leafc => clm3%g%l%c%p%pcs%leafc
frootc => clm3%g%l%c%p%pcs%frootc
livestemc => clm3%g%l%c%p%pcs%livestemc
deadstemc => clm3%g%l%c%p%pcs%deadstemc
livecrootc => clm3%g%l%c%p%pcs%livecrootc
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
xsmrpool => clm3%g%l%c%p%pcs%xsmrpool
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
leafn => clm3%g%l%c%p%pns%leafn
frootn => clm3%g%l%c%p%pns%frootn
livestemn => clm3%g%l%c%p%pns%livestemn
deadstemn => clm3%g%l%c%p%pns%deadstemn
livecrootn => clm3%g%l%c%p%pns%livecrootn
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
retransn => clm3%g%l%c%p%pns%retransn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
hrv_leafc_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_to_litter
hrv_frootc_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_to_litter
hrv_livestemc_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_to_litter
hrv_deadstemc_to_prod10c => clm3%g%l%c%p%pcf%hrv_deadstemc_to_prod10c
hrv_deadstemc_to_prod100c => clm3%g%l%c%p%pcf%hrv_deadstemc_to_prod100c
hrv_livecrootc_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_to_litter
hrv_deadcrootc_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_to_litter
hrv_xsmrpool_to_atm => clm3%g%l%c%p%pcf%hrv_xsmrpool_to_atm
hrv_leafc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_storage_to_litter
hrv_frootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_storage_to_litter
hrv_livestemc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_storage_to_litter
hrv_deadstemc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_deadstemc_storage_to_litter
hrv_livecrootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_storage_to_litter
hrv_deadcrootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_storage_to_litter
hrv_gresp_storage_to_litter => clm3%g%l%c%p%pcf%hrv_gresp_storage_to_litter
hrv_leafc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_xfer_to_litter
hrv_frootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_xfer_to_litter
hrv_livestemc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_xfer_to_litter
hrv_deadstemc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_deadstemc_xfer_to_litter
hrv_livecrootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_xfer_to_litter
hrv_deadcrootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_xfer_to_litter
hrv_gresp_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_gresp_xfer_to_litter
hrv_leafn_to_litter => clm3%g%l%c%p%pnf%hrv_leafn_to_litter
hrv_frootn_to_litter => clm3%g%l%c%p%pnf%hrv_frootn_to_litter
hrv_livestemn_to_litter => clm3%g%l%c%p%pnf%hrv_livestemn_to_litter
hrv_deadstemn_to_prod10n => clm3%g%l%c%p%pnf%hrv_deadstemn_to_prod10n
hrv_deadstemn_to_prod100n => clm3%g%l%c%p%pnf%hrv_deadstemn_to_prod100n
hrv_livecrootn_to_litter => clm3%g%l%c%p%pnf%hrv_livecrootn_to_litter
hrv_deadcrootn_to_litter => clm3%g%l%c%p%pnf%hrv_deadcrootn_to_litter
hrv_retransn_to_litter => clm3%g%l%c%p%pnf%hrv_retransn_to_litter
hrv_leafn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_leafn_storage_to_litter
hrv_frootn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_frootn_storage_to_litter
hrv_livestemn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_livestemn_storage_to_litter
hrv_deadstemn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_deadstemn_storage_to_litter
hrv_livecrootn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_livecrootn_storage_to_litter
hrv_deadcrootn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_deadcrootn_storage_to_litter
hrv_leafn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_leafn_xfer_to_litter
hrv_frootn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_frootn_xfer_to_litter
hrv_livestemn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_livestemn_xfer_to_litter
hrv_deadstemn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_deadstemn_xfer_to_litter
hrv_livecrootn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_livecrootn_xfer_to_litter
hrv_deadcrootn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_deadcrootn_xfer_to_litter
! set deadstem proportions to 10-year product pool.
! remainder (1-pprod10) is assumed to go to 100-year product pool
! veg type: 1 2 3 4 5 6 7 8
pprod10 = (/0.75_r8, 0.75_r8, 0.75_r8, 1.0_r8, 0.75_r8, 1.0_r8, 0.75_r8, 0.75_r8/)
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
! If this is a tree pft, then
! get the annual harvest "mortality" rate (am) from harvest array
! and convert to rate per second
if (ivt(p) > noveg .and. ivt(p) < nbrdlf_evr_shrub) then
if (do_harvest) then
am = harvest(g)
m = am/(365._r8 * 86400._r8)
else
m = 0._r8
end if
! pft-level harvest carbon fluxes
! displayed pools
hrv_leafc_to_litter(p) = leafc(p) * m
hrv_frootc_to_litter(p) = frootc(p) * m
hrv_livestemc_to_litter(p) = livestemc(p) * m
hrv_deadstemc_to_prod10c(p) = deadstemc(p) * m * pprod10(ivt(p))
hrv_deadstemc_to_prod100c(p) = deadstemc(p) * m * (1.0_r8 - pprod10(ivt(p)))
hrv_livecrootc_to_litter(p) = livecrootc(p) * m
hrv_deadcrootc_to_litter(p) = deadcrootc(p) * m
hrv_xsmrpool_to_atm(p) = xsmrpool(p) * m
! storage pools
hrv_leafc_storage_to_litter(p) = leafc_storage(p) * m
hrv_frootc_storage_to_litter(p) = frootc_storage(p) * m
hrv_livestemc_storage_to_litter(p) = livestemc_storage(p) * m
hrv_deadstemc_storage_to_litter(p) = deadstemc_storage(p) * m
hrv_livecrootc_storage_to_litter(p) = livecrootc_storage(p) * m
hrv_deadcrootc_storage_to_litter(p) = deadcrootc_storage(p) * m
hrv_gresp_storage_to_litter(p) = gresp_storage(p) * m
! transfer pools
hrv_leafc_xfer_to_litter(p) = leafc_xfer(p) * m
hrv_frootc_xfer_to_litter(p) = frootc_xfer(p) * m
hrv_livestemc_xfer_to_litter(p) = livestemc_xfer(p) * m
hrv_deadstemc_xfer_to_litter(p) = deadstemc_xfer(p) * m
hrv_livecrootc_xfer_to_litter(p) = livecrootc_xfer(p) * m
hrv_deadcrootc_xfer_to_litter(p) = deadcrootc_xfer(p) * m
hrv_gresp_xfer_to_litter(p) = gresp_xfer(p) * m
! pft-level harvest mortality nitrogen fluxes
! displayed pools
hrv_leafn_to_litter(p) = leafn(p) * m
hrv_frootn_to_litter(p) = frootn(p) * m
hrv_livestemn_to_litter(p) = livestemn(p) * m
hrv_deadstemn_to_prod10n(p) = deadstemn(p) * m * pprod10(ivt(p))
hrv_deadstemn_to_prod100n(p) = deadstemn(p) * m * (1.0_r8 - pprod10(ivt(p)))
hrv_livecrootn_to_litter(p) = livecrootn(p) * m
hrv_deadcrootn_to_litter(p) = deadcrootn(p) * m
hrv_retransn_to_litter(p) = retransn(p) * m
! storage pools
hrv_leafn_storage_to_litter(p) = leafn_storage(p) * m
hrv_frootn_storage_to_litter(p) = frootn_storage(p) * m
hrv_livestemn_storage_to_litter(p) = livestemn_storage(p) * m
hrv_deadstemn_storage_to_litter(p) = deadstemn_storage(p) * m
hrv_livecrootn_storage_to_litter(p) = livecrootn_storage(p) * m
hrv_deadcrootn_storage_to_litter(p) = deadcrootn_storage(p) * m
! transfer pools
hrv_leafn_xfer_to_litter(p) = leafn_xfer(p) * m
hrv_frootn_xfer_to_litter(p) = frootn_xfer(p) * m
hrv_livestemn_xfer_to_litter(p) = livestemn_xfer(p) * m
hrv_deadstemn_xfer_to_litter(p) = deadstemn_xfer(p) * m
hrv_livecrootn_xfer_to_litter(p) = livecrootn_xfer(p) * m
hrv_deadcrootn_xfer_to_litter(p) = deadcrootn_xfer(p) * m
end if ! end tree block
end do ! end of pft loop
! gather all pft-level litterfall fluxes from harvest to the column
! for litter C and N inputs
call CNHarvestPftToColumn(num_soilc, filter_soilc)
end subroutine CNHarvest
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNHarvestPftToColumn
!
! !INTERFACE:
subroutine CNHarvestPftToColumn (num_soilc, filter_soilc) 1,2
!
! !DESCRIPTION:
! called at the end of CNHarvest to gather all pft-level harvest litterfall fluxes
! to the column level and assign them to the three litter pools
!
! !USES:
use clmtype
use clm_varpar, only : max_pft_per_col, maxpatch_pft
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! soil column filter
!
! !CALLED FROM:
! subroutine CNphenology
!
! !REVISION HISTORY:
! 9/8/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in scalars
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: wtcol(:) ! pft weight relative to column (0-1)
real(r8), pointer :: pwtgcell(:) ! weight of pft relative to corresponding gridcell
real(r8), pointer :: lf_flab(:) ! leaf litter labile fraction
real(r8), pointer :: lf_fcel(:) ! leaf litter cellulose fraction
real(r8), pointer :: lf_flig(:) ! leaf litter lignin fraction
real(r8), pointer :: fr_flab(:) ! fine root litter labile fraction
real(r8), pointer :: fr_fcel(:) ! fine root litter cellulose fraction
real(r8), pointer :: fr_flig(:) ! fine root litter lignin fraction
integer , pointer :: npfts(:) ! number of pfts for each column
integer , pointer :: pfti(:) ! beginning pft index for each column
real(r8), pointer :: hrv_leafc_to_litter(:)
real(r8), pointer :: hrv_frootc_to_litter(:)
real(r8), pointer :: hrv_livestemc_to_litter(:)
real(r8), pointer :: phrv_deadstemc_to_prod10c(:)
real(r8), pointer :: phrv_deadstemc_to_prod100c(:)
real(r8), pointer :: hrv_livecrootc_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_to_litter(:)
real(r8), pointer :: hrv_leafc_storage_to_litter(:)
real(r8), pointer :: hrv_frootc_storage_to_litter(:)
real(r8), pointer :: hrv_livestemc_storage_to_litter(:)
real(r8), pointer :: hrv_deadstemc_storage_to_litter(:)
real(r8), pointer :: hrv_livecrootc_storage_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_storage_to_litter(:)
real(r8), pointer :: hrv_gresp_storage_to_litter(:)
real(r8), pointer :: hrv_leafc_xfer_to_litter(:)
real(r8), pointer :: hrv_frootc_xfer_to_litter(:)
real(r8), pointer :: hrv_livestemc_xfer_to_litter(:)
real(r8), pointer :: hrv_deadstemc_xfer_to_litter(:)
real(r8), pointer :: hrv_livecrootc_xfer_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_xfer_to_litter(:)
real(r8), pointer :: hrv_gresp_xfer_to_litter(:)
real(r8), pointer :: hrv_leafn_to_litter(:)
real(r8), pointer :: hrv_frootn_to_litter(:)
real(r8), pointer :: hrv_livestemn_to_litter(:)
real(r8), pointer :: phrv_deadstemn_to_prod10n(:)
real(r8), pointer :: phrv_deadstemn_to_prod100n(:)
real(r8), pointer :: hrv_livecrootn_to_litter(:)
real(r8), pointer :: hrv_deadcrootn_to_litter(:)
real(r8), pointer :: hrv_retransn_to_litter(:)
real(r8), pointer :: hrv_leafn_storage_to_litter(:)
real(r8), pointer :: hrv_frootn_storage_to_litter(:)
real(r8), pointer :: hrv_livestemn_storage_to_litter(:)
real(r8), pointer :: hrv_deadstemn_storage_to_litter(:)
real(r8), pointer :: hrv_livecrootn_storage_to_litter(:)
real(r8), pointer :: hrv_deadcrootn_storage_to_litter(:)
real(r8), pointer :: hrv_leafn_xfer_to_litter(:)
real(r8), pointer :: hrv_frootn_xfer_to_litter(:)
real(r8), pointer :: hrv_livestemn_xfer_to_litter(:)
real(r8), pointer :: hrv_deadstemn_xfer_to_litter(:)
real(r8), pointer :: hrv_livecrootn_xfer_to_litter(:)
real(r8), pointer :: hrv_deadcrootn_xfer_to_litter(:)
!
! local pointers to implicit in/out arrays
real(r8), pointer :: hrv_leafc_to_litr1c(:)
real(r8), pointer :: hrv_leafc_to_litr2c(:)
real(r8), pointer :: hrv_leafc_to_litr3c(:)
real(r8), pointer :: hrv_frootc_to_litr1c(:)
real(r8), pointer :: hrv_frootc_to_litr2c(:)
real(r8), pointer :: hrv_frootc_to_litr3c(:)
real(r8), pointer :: hrv_livestemc_to_cwdc(:)
real(r8), pointer :: chrv_deadstemc_to_prod10c(:)
real(r8), pointer :: chrv_deadstemc_to_prod100c(:)
real(r8), pointer :: hrv_livecrootc_to_cwdc(:)
real(r8), pointer :: hrv_deadcrootc_to_cwdc(:)
real(r8), pointer :: hrv_leafc_storage_to_litr1c(:)
real(r8), pointer :: hrv_frootc_storage_to_litr1c(:)
real(r8), pointer :: hrv_livestemc_storage_to_litr1c(:)
real(r8), pointer :: hrv_deadstemc_storage_to_litr1c(:)
real(r8), pointer :: hrv_livecrootc_storage_to_litr1c(:)
real(r8), pointer :: hrv_deadcrootc_storage_to_litr1c(:)
real(r8), pointer :: hrv_gresp_storage_to_litr1c(:)
real(r8), pointer :: hrv_leafc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_frootc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_livestemc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_deadstemc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_livecrootc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_deadcrootc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_gresp_xfer_to_litr1c(:)
real(r8), pointer :: hrv_leafn_to_litr1n(:)
real(r8), pointer :: hrv_leafn_to_litr2n(:)
real(r8), pointer :: hrv_leafn_to_litr3n(:)
real(r8), pointer :: hrv_frootn_to_litr1n(:)
real(r8), pointer :: hrv_frootn_to_litr2n(:)
real(r8), pointer :: hrv_frootn_to_litr3n(:)
real(r8), pointer :: hrv_livestemn_to_cwdn(:)
real(r8), pointer :: chrv_deadstemn_to_prod10n(:)
real(r8), pointer :: chrv_deadstemn_to_prod100n(:)
real(r8), pointer :: hrv_livecrootn_to_cwdn(:)
real(r8), pointer :: hrv_deadcrootn_to_cwdn(:)
real(r8), pointer :: hrv_retransn_to_litr1n(:)
real(r8), pointer :: hrv_leafn_storage_to_litr1n(:)
real(r8), pointer :: hrv_frootn_storage_to_litr1n(:)
real(r8), pointer :: hrv_livestemn_storage_to_litr1n(:)
real(r8), pointer :: hrv_deadstemn_storage_to_litr1n(:)
real(r8), pointer :: hrv_livecrootn_storage_to_litr1n(:)
real(r8), pointer :: hrv_deadcrootn_storage_to_litr1n(:)
real(r8), pointer :: hrv_leafn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_frootn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_livestemn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_deadstemn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_livecrootn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_deadcrootn_xfer_to_litr1n(:)
!
! local pointers to implicit out arrays
!
!
! !OTHER LOCAL VARIABLES:
integer :: fc,c,pi,p ! indices
!EOP
!-----------------------------------------------------------------------
! assign local pointers
lf_flab => pftcon%lf_flab
lf_fcel => pftcon%lf_fcel
lf_flig => pftcon%lf_flig
fr_flab => pftcon%fr_flab
fr_fcel => pftcon%fr_fcel
fr_flig => pftcon%fr_flig
! assign local pointers to column-level arrays
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
hrv_leafc_to_litr1c => clm3%g%l%c%ccf%hrv_leafc_to_litr1c
hrv_leafc_to_litr2c => clm3%g%l%c%ccf%hrv_leafc_to_litr2c
hrv_leafc_to_litr3c => clm3%g%l%c%ccf%hrv_leafc_to_litr3c
hrv_frootc_to_litr1c => clm3%g%l%c%ccf%hrv_frootc_to_litr1c
hrv_frootc_to_litr2c => clm3%g%l%c%ccf%hrv_frootc_to_litr2c
hrv_frootc_to_litr3c => clm3%g%l%c%ccf%hrv_frootc_to_litr3c
hrv_livestemc_to_cwdc => clm3%g%l%c%ccf%hrv_livestemc_to_cwdc
chrv_deadstemc_to_prod10c => clm3%g%l%c%ccf%hrv_deadstemc_to_prod10c
chrv_deadstemc_to_prod100c => clm3%g%l%c%ccf%hrv_deadstemc_to_prod100c
hrv_livecrootc_to_cwdc => clm3%g%l%c%ccf%hrv_livecrootc_to_cwdc
hrv_deadcrootc_to_cwdc => clm3%g%l%c%ccf%hrv_deadcrootc_to_cwdc
hrv_leafc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_leafc_storage_to_litr1c
hrv_frootc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_frootc_storage_to_litr1c
hrv_livestemc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_livestemc_storage_to_litr1c
hrv_deadstemc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_deadstemc_storage_to_litr1c
hrv_livecrootc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_livecrootc_storage_to_litr1c
hrv_deadcrootc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_deadcrootc_storage_to_litr1c
hrv_gresp_storage_to_litr1c => clm3%g%l%c%ccf%hrv_gresp_storage_to_litr1c
hrv_leafc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_leafc_xfer_to_litr1c
hrv_frootc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_frootc_xfer_to_litr1c
hrv_livestemc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_livestemc_xfer_to_litr1c
hrv_deadstemc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_deadstemc_xfer_to_litr1c
hrv_livecrootc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_livecrootc_xfer_to_litr1c
hrv_deadcrootc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_deadcrootc_xfer_to_litr1c
hrv_gresp_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_gresp_xfer_to_litr1c
hrv_leafn_to_litr1n => clm3%g%l%c%cnf%hrv_leafn_to_litr1n
hrv_leafn_to_litr2n => clm3%g%l%c%cnf%hrv_leafn_to_litr2n
hrv_leafn_to_litr3n => clm3%g%l%c%cnf%hrv_leafn_to_litr3n
hrv_frootn_to_litr1n => clm3%g%l%c%cnf%hrv_frootn_to_litr1n
hrv_frootn_to_litr2n => clm3%g%l%c%cnf%hrv_frootn_to_litr2n
hrv_frootn_to_litr3n => clm3%g%l%c%cnf%hrv_frootn_to_litr3n
hrv_livestemn_to_cwdn => clm3%g%l%c%cnf%hrv_livestemn_to_cwdn
chrv_deadstemn_to_prod10n => clm3%g%l%c%cnf%hrv_deadstemn_to_prod10n
chrv_deadstemn_to_prod100n => clm3%g%l%c%cnf%hrv_deadstemn_to_prod100n
hrv_livecrootn_to_cwdn => clm3%g%l%c%cnf%hrv_livecrootn_to_cwdn
hrv_deadcrootn_to_cwdn => clm3%g%l%c%cnf%hrv_deadcrootn_to_cwdn
hrv_retransn_to_litr1n => clm3%g%l%c%cnf%hrv_retransn_to_litr1n
hrv_leafn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_leafn_storage_to_litr1n
hrv_frootn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_frootn_storage_to_litr1n
hrv_livestemn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_livestemn_storage_to_litr1n
hrv_deadstemn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_deadstemn_storage_to_litr1n
hrv_livecrootn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_livecrootn_storage_to_litr1n
hrv_deadcrootn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_deadcrootn_storage_to_litr1n
hrv_leafn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_leafn_xfer_to_litr1n
hrv_frootn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_frootn_xfer_to_litr1n
hrv_livestemn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_livestemn_xfer_to_litr1n
hrv_deadstemn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_deadstemn_xfer_to_litr1n
hrv_livecrootn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_livecrootn_xfer_to_litr1n
hrv_deadcrootn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_deadcrootn_xfer_to_litr1n
! assign local pointers to pft-level arrays
ivt => clm3%g%l%c%p%itype
wtcol => clm3%g%l%c%p%wtcol
pwtgcell => clm3%g%l%c%p%wtgcell
hrv_leafc_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_to_litter
hrv_frootc_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_to_litter
hrv_livestemc_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_to_litter
phrv_deadstemc_to_prod10c => clm3%g%l%c%p%pcf%hrv_deadstemc_to_prod10c
phrv_deadstemc_to_prod100c => clm3%g%l%c%p%pcf%hrv_deadstemc_to_prod100c
hrv_livecrootc_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_to_litter
hrv_deadcrootc_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_to_litter
hrv_leafc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_storage_to_litter
hrv_frootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_storage_to_litter
hrv_livestemc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_storage_to_litter
hrv_deadstemc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_deadstemc_storage_to_litter
hrv_livecrootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_storage_to_litter
hrv_deadcrootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_storage_to_litter
hrv_gresp_storage_to_litter => clm3%g%l%c%p%pcf%hrv_gresp_storage_to_litter
hrv_leafc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_xfer_to_litter
hrv_frootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_xfer_to_litter
hrv_livestemc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_xfer_to_litter
hrv_deadstemc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_deadstemc_xfer_to_litter
hrv_livecrootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_xfer_to_litter
hrv_deadcrootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_xfer_to_litter
hrv_gresp_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_gresp_xfer_to_litter
hrv_leafn_to_litter => clm3%g%l%c%p%pnf%hrv_leafn_to_litter
hrv_frootn_to_litter => clm3%g%l%c%p%pnf%hrv_frootn_to_litter
hrv_livestemn_to_litter => clm3%g%l%c%p%pnf%hrv_livestemn_to_litter
phrv_deadstemn_to_prod10n => clm3%g%l%c%p%pnf%hrv_deadstemn_to_prod10n
phrv_deadstemn_to_prod100n => clm3%g%l%c%p%pnf%hrv_deadstemn_to_prod100n
hrv_livecrootn_to_litter => clm3%g%l%c%p%pnf%hrv_livecrootn_to_litter
hrv_deadcrootn_to_litter => clm3%g%l%c%p%pnf%hrv_deadcrootn_to_litter
hrv_retransn_to_litter => clm3%g%l%c%p%pnf%hrv_retransn_to_litter
hrv_leafn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_leafn_storage_to_litter
hrv_frootn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_frootn_storage_to_litter
hrv_livestemn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_livestemn_storage_to_litter
hrv_deadstemn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_deadstemn_storage_to_litter
hrv_livecrootn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_livecrootn_storage_to_litter
hrv_deadcrootn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_deadcrootn_storage_to_litter
hrv_leafn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_leafn_xfer_to_litter
hrv_frootn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_frootn_xfer_to_litter
hrv_livestemn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_livestemn_xfer_to_litter
hrv_deadstemn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_deadstemn_xfer_to_litter
hrv_livecrootn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_livecrootn_xfer_to_litter
hrv_deadcrootn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_deadcrootn_xfer_to_litter
do pi = 1,maxpatch_pft
do fc = 1,num_soilc
c = filter_soilc(fc)
if (pi <= npfts(c)) then
p = pfti(c) + pi - 1
if (pwtgcell(p)>0._r8) then
! leaf harvest mortality carbon fluxes
hrv_leafc_to_litr1c(c) = hrv_leafc_to_litr1c(c) + &
hrv_leafc_to_litter(p) * lf_flab(ivt(p)) * wtcol(p)
hrv_leafc_to_litr2c(c) = hrv_leafc_to_litr2c(c) + &
hrv_leafc_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p)
hrv_leafc_to_litr3c(c) = hrv_leafc_to_litr3c(c) + &
hrv_leafc_to_litter(p) * lf_flig(ivt(p)) * wtcol(p)
! fine root harvest mortality carbon fluxes
hrv_frootc_to_litr1c(c) = hrv_frootc_to_litr1c(c) + &
hrv_frootc_to_litter(p) * fr_flab(ivt(p)) * wtcol(p)
hrv_frootc_to_litr2c(c) = hrv_frootc_to_litr2c(c) + &
hrv_frootc_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p)
hrv_frootc_to_litr3c(c) = hrv_frootc_to_litr3c(c) + &
hrv_frootc_to_litter(p) * fr_flig(ivt(p)) * wtcol(p)
! wood harvest mortality carbon fluxes
hrv_livestemc_to_cwdc(c) = hrv_livestemc_to_cwdc(c) + &
hrv_livestemc_to_litter(p) * wtcol(p)
chrv_deadstemc_to_prod10c(c) = chrv_deadstemc_to_prod10c(c) + &
phrv_deadstemc_to_prod10c(p) * wtcol(p)
chrv_deadstemc_to_prod100c(c) = chrv_deadstemc_to_prod100c(c) + &
phrv_deadstemc_to_prod100c(p) * wtcol(p)
hrv_livecrootc_to_cwdc(c) = hrv_livecrootc_to_cwdc(c) + &
hrv_livecrootc_to_litter(p) * wtcol(p)
hrv_deadcrootc_to_cwdc(c) = hrv_deadcrootc_to_cwdc(c) + &
hrv_deadcrootc_to_litter(p) * wtcol(p)
! storage harvest mortality carbon fluxes
hrv_leafc_storage_to_litr1c(c) = hrv_leafc_storage_to_litr1c(c) + &
hrv_leafc_storage_to_litter(p) * wtcol(p)
hrv_frootc_storage_to_litr1c(c) = hrv_frootc_storage_to_litr1c(c) + &
hrv_frootc_storage_to_litter(p) * wtcol(p)
hrv_livestemc_storage_to_litr1c(c) = hrv_livestemc_storage_to_litr1c(c) + &
hrv_livestemc_storage_to_litter(p) * wtcol(p)
hrv_deadstemc_storage_to_litr1c(c) = hrv_deadstemc_storage_to_litr1c(c) + &
hrv_deadstemc_storage_to_litter(p) * wtcol(p)
hrv_livecrootc_storage_to_litr1c(c) = hrv_livecrootc_storage_to_litr1c(c) + &
hrv_livecrootc_storage_to_litter(p) * wtcol(p)
hrv_deadcrootc_storage_to_litr1c(c) = hrv_deadcrootc_storage_to_litr1c(c) + &
hrv_deadcrootc_storage_to_litter(p) * wtcol(p)
hrv_gresp_storage_to_litr1c(c) = hrv_gresp_storage_to_litr1c(c) + &
hrv_gresp_storage_to_litter(p) * wtcol(p)
! transfer harvest mortality carbon fluxes
hrv_leafc_xfer_to_litr1c(c) = hrv_leafc_xfer_to_litr1c(c) + &
hrv_leafc_xfer_to_litter(p) * wtcol(p)
hrv_frootc_xfer_to_litr1c(c) = hrv_frootc_xfer_to_litr1c(c) + &
hrv_frootc_xfer_to_litter(p) * wtcol(p)
hrv_livestemc_xfer_to_litr1c(c) = hrv_livestemc_xfer_to_litr1c(c) + &
hrv_livestemc_xfer_to_litter(p) * wtcol(p)
hrv_deadstemc_xfer_to_litr1c(c) = hrv_deadstemc_xfer_to_litr1c(c) + &
hrv_deadstemc_xfer_to_litter(p) * wtcol(p)
hrv_livecrootc_xfer_to_litr1c(c) = hrv_livecrootc_xfer_to_litr1c(c) + &
hrv_livecrootc_xfer_to_litter(p) * wtcol(p)
hrv_deadcrootc_xfer_to_litr1c(c) = hrv_deadcrootc_xfer_to_litr1c(c) + &
hrv_deadcrootc_xfer_to_litter(p) * wtcol(p)
hrv_gresp_xfer_to_litr1c(c) = hrv_gresp_xfer_to_litr1c(c) + &
hrv_gresp_xfer_to_litter(p) * wtcol(p)
! leaf harvest mortality nitrogen fluxes
hrv_leafn_to_litr1n(c) = hrv_leafn_to_litr1n(c) + &
hrv_leafn_to_litter(p) * lf_flab(ivt(p)) * wtcol(p)
hrv_leafn_to_litr2n(c) = hrv_leafn_to_litr2n(c) + &
hrv_leafn_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p)
hrv_leafn_to_litr3n(c) = hrv_leafn_to_litr3n(c) + &
hrv_leafn_to_litter(p) * lf_flig(ivt(p)) * wtcol(p)
! fine root litter nitrogen fluxes
hrv_frootn_to_litr1n(c) = hrv_frootn_to_litr1n(c) + &
hrv_frootn_to_litter(p) * fr_flab(ivt(p)) * wtcol(p)
hrv_frootn_to_litr2n(c) = hrv_frootn_to_litr2n(c) + &
hrv_frootn_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p)
hrv_frootn_to_litr3n(c) = hrv_frootn_to_litr3n(c) + &
hrv_frootn_to_litter(p) * fr_flig(ivt(p)) * wtcol(p)
! wood harvest mortality nitrogen fluxes
hrv_livestemn_to_cwdn(c) = hrv_livestemn_to_cwdn(c) + &
hrv_livestemn_to_litter(p) * wtcol(p)
chrv_deadstemn_to_prod10n(c) = chrv_deadstemn_to_prod10n(c) + &
phrv_deadstemn_to_prod10n(p) * wtcol(p)
chrv_deadstemn_to_prod100n(c) = chrv_deadstemn_to_prod100n(c) + &
phrv_deadstemn_to_prod100n(p) * wtcol(p)
hrv_livecrootn_to_cwdn(c) = hrv_livecrootn_to_cwdn(c) + &
hrv_livecrootn_to_litter(p) * wtcol(p)
hrv_deadcrootn_to_cwdn(c) = hrv_deadcrootn_to_cwdn(c) + &
hrv_deadcrootn_to_litter(p) * wtcol(p)
! retranslocated N pool harvest mortality fluxes
hrv_retransn_to_litr1n(c) = hrv_retransn_to_litr1n(c) + &
hrv_retransn_to_litter(p) * wtcol(p)
! storage harvest mortality nitrogen fluxes
hrv_leafn_storage_to_litr1n(c) = hrv_leafn_storage_to_litr1n(c) + &
hrv_leafn_storage_to_litter(p) * wtcol(p)
hrv_frootn_storage_to_litr1n(c) = hrv_frootn_storage_to_litr1n(c) + &
hrv_frootn_storage_to_litter(p) * wtcol(p)
hrv_livestemn_storage_to_litr1n(c) = hrv_livestemn_storage_to_litr1n(c) + &
hrv_livestemn_storage_to_litter(p) * wtcol(p)
hrv_deadstemn_storage_to_litr1n(c) = hrv_deadstemn_storage_to_litr1n(c) + &
hrv_deadstemn_storage_to_litter(p) * wtcol(p)
hrv_livecrootn_storage_to_litr1n(c) = hrv_livecrootn_storage_to_litr1n(c) + &
hrv_livecrootn_storage_to_litter(p) * wtcol(p)
hrv_deadcrootn_storage_to_litr1n(c) = hrv_deadcrootn_storage_to_litr1n(c) + &
hrv_deadcrootn_storage_to_litter(p) * wtcol(p)
! transfer harvest mortality nitrogen fluxes
hrv_leafn_xfer_to_litr1n(c) = hrv_leafn_xfer_to_litr1n(c) + &
hrv_leafn_xfer_to_litter(p) * wtcol(p)
hrv_frootn_xfer_to_litr1n(c) = hrv_frootn_xfer_to_litr1n(c) + &
hrv_frootn_xfer_to_litter(p) * wtcol(p)
hrv_livestemn_xfer_to_litr1n(c) = hrv_livestemn_xfer_to_litr1n(c) + &
hrv_livestemn_xfer_to_litter(p) * wtcol(p)
hrv_deadstemn_xfer_to_litr1n(c) = hrv_deadstemn_xfer_to_litr1n(c) + &
hrv_deadstemn_xfer_to_litter(p) * wtcol(p)
hrv_livecrootn_xfer_to_litr1n(c) = hrv_livecrootn_xfer_to_litr1n(c) + &
hrv_livecrootn_xfer_to_litter(p) * wtcol(p)
hrv_deadcrootn_xfer_to_litr1n(c) = hrv_deadcrootn_xfer_to_litr1n(c) + &
hrv_deadcrootn_xfer_to_litter(p) * wtcol(p)
end if
end if
end do
end do
end subroutine CNHarvestPftToColumn
!-----------------------------------------------------------------------
! !ROUTINE: pftdyn_wbal_init
!
! !INTERFACE:
subroutine pftdyn_wbal_init() 1,1
!
! !DESCRIPTION:
! initialize the column-level mass-balance correction term.
! Called in every timestep.
!
! !USES:
!
! !ARGUMENTS:
implicit none
!
!
! !LOCAL VARIABLES:
!EOP
integer :: begp, endp ! proc beginning and ending pft indices
integer :: begc, endc ! proc beginning and ending column indices
integer :: begl, endl ! proc beginning and ending landunit indices
integer :: begg, endg ! proc beginning and ending gridcell indices
integer :: c ! indices
type(column_type), pointer :: cptr ! pointer to column derived subtype
!-----------------------------------------------------------------------
! Set pointers into derived type
cptr => clm3%g%l%c
! Get relevant sizes
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! set column-level canopy water mass balance correction flux
! term to 0 at the beginning of every timestep
do c = begc,endc
cptr%cwf%h2ocan_loss(c) = 0._r8
end do
end subroutine pftdyn_wbal_init
end module pftdynMod
module filterMod 4,1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: filterMod
!
! !DESCRIPTION:
! Module of filters used for processing columns and pfts of particular
! types, including lake, non-lake, urban, soil, snow, non-snow, and
! naturally-vegetated patches.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
!
! !PUBLIC TYPES:
implicit none
save
type clumpfilter
#if (defined CNDV)
integer, pointer :: natvegp(:) ! CNDV nat-vegetated (present) filter (pfts)
integer :: num_natvegp ! number of pfts in nat-vegetated filter
#endif
#if (defined CROP)
integer, pointer :: pcropp(:) ! prognostic crop filter (pfts)
integer :: num_pcropp ! number of pfts in prognostic crop filter
integer, pointer :: soilnopcropp(:) ! soil w/o prog. crops (pfts)
integer :: num_soilnopcropp ! number of pfts in soil w/o prog crops
#endif
integer, pointer :: lakep(:) ! lake filter (pfts)
integer :: num_lakep ! number of pfts in lake filter
integer, pointer :: nolakep(:) ! non-lake filter (pfts)
integer :: num_nolakep ! number of pfts in non-lake filter
integer, pointer :: lakec(:) ! lake filter (columns)
integer :: num_lakec ! number of columns in lake filter
integer, pointer :: nolakec(:) ! non-lake filter (columns)
integer :: num_nolakec ! number of columns in non-lake filter
integer, pointer :: soilc(:) ! soil filter (columns)
integer :: num_soilc ! number of columns in soil filter
integer, pointer :: soilp(:) ! soil filter (pfts)
integer :: num_soilp ! number of pfts in soil filter
integer, pointer :: snowc(:) ! snow filter (columns)
integer :: num_snowc ! number of columns in snow filter
integer, pointer :: nosnowc(:) ! non-snow filter (columns)
integer :: num_nosnowc ! number of columns in non-snow filter
integer, pointer :: hydrologyc(:) ! hydrology filter (columns)
integer :: num_hydrologyc ! number of columns in hydrology filter
integer, pointer :: urbanl(:) ! urban filter (landunits)
integer :: num_urbanl ! number of landunits in urban filter
integer, pointer :: nourbanl(:) ! non-urban filter (landunits)
integer :: num_nourbanl ! number of landunits in non-urban filter
integer, pointer :: urbanc(:) ! urban filter (columns)
integer :: num_urbanc ! number of columns in urban filter
integer, pointer :: nourbanc(:) ! non-urban filter (columns)
integer :: num_nourbanc ! number of columns in non-urban filter
integer, pointer :: urbanp(:) ! urban filter (pfts)
integer :: num_urbanp ! number of pfts in urban filter
integer, pointer :: nourbanp(:) ! non-urban filter (pfts)
integer :: num_nourbanp ! number of pfts in non-urban filter
integer, pointer :: nolakeurbanp(:) ! non-lake, non-urban filter (pfts)
integer :: num_nolakeurbanp ! number of pfts in non-lake, non-urban filter
end type clumpfilter
public clumpfilter
type(clumpfilter), public :: filter
!
public allocFilters ! allocate memory for filters
public setFilters ! set filters
public filters_dealloc
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! 11/13/03, Peter Thornton: Added soilp and num_soilp
! Jan/08, S. Levis: Added crop-related filters
!
!EOP
!-----------------------------------------------------------------------
contains
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: allocFilters
!
! !INTERFACE:
subroutine allocFilters() 1,3
!
! !DESCRIPTION:
! Allocate CLM filters.
!
! !USES:
use clmtype
use decompMod , only : get_proc_bounds
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! 2004.04.27 DGVM naturally-vegetated filter added by Forrest Hoffman
!
!EOP
!
! LOCAL VARAIBLES:
integer :: begp, endp ! per-clump beginning and ending pft indices
integer :: begc, endc ! per-clump beginning and ending column indices
integer :: begl, endl ! per-clump beginning and ending landunit indices
integer :: begg, endg ! per-clump beginning and ending gridcell indices
!------------------------------------------------------------------------
! Determine clump variables for this processor
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
allocate(filter%lakep(endp-begp+1))
allocate(filter%nolakep(endp-begp+1))
allocate(filter%nolakeurbanp(endp-begp+1))
allocate(filter%lakec(endc-begc+1))
allocate(filter%nolakec(endc-begc+1))
allocate(filter%soilc(endc-begc+1))
allocate(filter%soilp(endp-begp+1))
allocate(filter%snowc(endc-begc+1))
allocate(filter%nosnowc(endc-begc+1))
#if (defined CNDV)
allocate(filter%natvegp(endp-begp+1))
#endif
allocate(filter%hydrologyc(endc-begc+1))
allocate(filter%urbanp(endp-begp+1))
allocate(filter%nourbanp(endp-begp+1))
allocate(filter%urbanc(endc-begc+1))
allocate(filter%nourbanc(endc-begc+1))
allocate(filter%urbanl(endl-begl+1))
allocate(filter%nourbanl(endl-begl+1))
#if (defined CROP)
allocate(filter%pcropp(endp-begp+1))
allocate(filter%soilnopcropp(endp-begp+1))
#endif
end subroutine allocFilters
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: setFilters
!
! !INTERFACE:
subroutine setFilters() 2,6
!
! !DESCRIPTION:
! Set CLM filters.
!
! !USES:
use clmtype
use decompMod , only : get_proc_bounds
#if (defined CROP)
use pftvarcon , only : npcropmin
#endif
use clm_varcon, only : istsoil, isturb, icol_road_perv
#ifdef CROP
use clm_varcon, only : istcrop
#endif
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! 2004.04.27 DGVM naturally-vegetated filter added by Forrest Hoffman
! 2005.09.12 Urban related filters added by Mariana Vertenstein
!
!EOP
!
! LOCAL VARAIBLES:
integer , pointer :: ctype(:) ! column type
integer :: c,l,p ! column, landunit, pft indices
integer :: fl ! lake filter index
integer :: fnl,fnlu ! non-lake filter index
integer :: fs ! soil filter index
integer :: f, fn ! general indices
integer :: begp, endp ! per-clump beginning and ending pft indices
integer :: begc, endc ! per-clump beginning and ending column indices
integer :: begl, endl ! per-clump beginning and ending landunit indices
integer :: begg, endg ! per-clump beginning and ending gridcell indices
!------------------------------------------------------------------------
ctype => clm3%g%l%c%itype
! Loop over clumps on this processor
! Determine clump boundaries
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! Create lake and non-lake filters at column-level
fl = 0
fnl = 0
do c = begc,endc
l = clm3%g%l%c%landunit(c)
if (clm3%g%l%lakpoi(l)) then
fl = fl + 1
filter%lakec(fl) = c
else
fnl = fnl + 1
filter%nolakec(fnl) = c
end if
end do
filter%num_lakec = fl
filter%num_nolakec = fnl
! Create lake and non-lake filters at pft-level
! Filter will only be active if weight of pft wrt gcell is nonzero
fl = 0
fnl = 0
fnlu = 0
do p = begp,endp
if (clm3%g%l%c%p%wtgcell(p) > 0._r8) then
l = clm3%g%l%c%p%landunit(p)
if (clm3%g%l%lakpoi(l) ) then
fl = fl + 1
filter%lakep(fl) = p
else
fnl = fnl + 1
filter%nolakep(fnl) = p
if (clm3%g%l%itype(l) /= isturb) then
fnlu = fnlu + 1
filter%nolakeurbanp(fnlu) = p
end if
end if
end if
end do
filter%num_lakep = fl
filter%num_nolakep = fnl
filter%num_nolakeurbanp = fnlu
! Create soil filter at column-level
fs = 0
do c = begc,endc
l = clm3%g%l%c%landunit(c)
#ifndef CROP
if (clm3%g%l%itype(l) == istsoil) then
#else
if (clm3%g%l%itype(l) == istsoil .or. clm3%g%l%itype(l) == istcrop) then
#endif
fs = fs + 1
filter%soilc(fs) = c
end if
end do
filter%num_soilc = fs
! Create soil filter at pft-level
! Filter will only be active if weight of pft wrt gcell is nonzero
fs = 0
do p = begp,endp
if (clm3%g%l%c%p%wtgcell(p) > 0._r8) then
l = clm3%g%l%c%p%landunit(p)
#ifndef CROP
if (clm3%g%l%itype(l) == istsoil) then
#else
if (clm3%g%l%itype(l) == istsoil .or. clm3%g%l%itype(l) == istcrop) then
#endif
fs = fs + 1
filter%soilp(fs) = p
end if
end if
end do
filter%num_soilp = fs
#if (defined CROP)
! Create prognostic crop and soil w/o prog. crop filters at pft-level
! according to where the CROP model should be used
fl = 0
fnl = 0
do p = begp,endp
if (clm3%g%l%c%p%wtgcell(p) > 0._r8) then
if (clm3%g%l%c%p%itype(p) >= npcropmin) then !skips 2 generic crop types
fl = fl + 1
filter%pcropp(fl) = p
else
l = clm3%g%l%c%p%landunit(p)
if (clm3%g%l%itype(l) == istsoil .or. clm3%g%l%itype(l) == istcrop) then
fnl = fnl + 1
filter%soilnopcropp(fnl) = p
end if
end if
end if
end do
filter%num_pcropp = fl
#endif
! Create column-level hydrology filter (soil and Urban pervious road cols)
f = 0
do c = begc,endc
l = clm3%g%l%c%landunit(c)
#ifndef CROP
if (clm3%g%l%itype(l) == istsoil .or. ctype(c) == icol_road_perv ) then
#else
if (clm3%g%l%itype(l) == istsoil .or. clm3%g%l%itype(l) == istcrop .or. ctype(c) == icol_road_perv ) then
#endif
f = f + 1
filter%hydrologyc(f) = c
end if
end do
filter%num_hydrologyc = f
! Create landunit-level urban and non-urban filters
f = 0
fn = 0
do l = begl,endl
if (clm3%g%l%itype(l) == isturb) then
f = f + 1
filter%urbanl(f) = l
else
fn = fn + 1
filter%nourbanl(fn) = l
end if
end do
filter%num_urbanl = f
filter%num_nourbanl = fn
! Create column-level urban and non-urban filters
f = 0
fn = 0
do c = begc,endc
l = clm3%g%l%c%landunit(c)
if (clm3%g%l%itype(l) == isturb) then
f = f + 1
filter%urbanc(f) = c
else
fn = fn + 1
filter%nourbanc(fn) = c
end if
end do
filter%num_urbanc = f
filter%num_nourbanc = fn
! Create pft-level urban and non-urban filters
f = 0
fn = 0
do p = begp,endp
l = clm3%g%l%c%p%landunit(p)
if (clm3%g%l%itype(l) == isturb .and. clm3%g%l%c%p%wtgcell(p) > 0._r8) then
f = f + 1
filter%urbanp(f) = p
else
fn = fn + 1
filter%nourbanp(fn) = p
end if
end do
filter%num_urbanp = f
filter%num_nourbanp = fn
! Note: snow filters are reconstructed each time step in Hydrology2
! Note: CNDV "pft present" filter is reconstructed each time CNDV is run
end subroutine setFilters
subroutine filters_dealloc 1,2
!
implicit none
deallocate(filter%lakep)
call CLMDebug('mark1')
deallocate(filter%nolakep)
deallocate(filter%nolakeurbanp)
deallocate(filter%lakec)
deallocate(filter%nolakec)
deallocate(filter%soilc)
deallocate(filter%soilp)
deallocate(filter%snowc)
deallocate(filter%nosnowc)
#if (defined CNDV)
deallocate(filter%natvegp)
#endif
deallocate(filter%hydrologyc)
deallocate(filter%urbanp)
deallocate(filter%nourbanp)
deallocate(filter%urbanc)
deallocate(filter%nourbanc)
deallocate(filter%urbanl)
deallocate(filter%nourbanl)
#if (defined CROP)
deallocate(filter%pcropp)
deallocate(filter%soilnopcropp)
#endif
call CLMDebug('done filters_dealloc')
end subroutine filters_dealloc
end module filterMod
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: iniTimeConst
!
! !INTERFACE:
subroutine iniTimeConst 1,21
!
! !DESCRIPTION:
! Initialize time invariant clm variables
! 1) removed references to shallow lake - since it is not used
! 2) ***Make c%z, c%zi and c%dz allocatable depending on if you
! have lake or soil
! 3) rootfr only initialized for soil points
!
! !USES:
use shr_kind_mod, only : r8 => shr_kind_r8
use nanMod , only : nan
use clmtype
use decompMod , only : get_proc_bounds
use clm_varpar , only : nlevsoi, nlevgrnd, nlevlak, lsmlon, lsmlat, numpft, numrad, nlevurb
use clm_varcon , only : istice, istdlak, istwet, isturb, &
icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, icol_road_imperv, &
zlak, dzlak, zsoi, dzsoi, zisoi, spval
use pftvarcon , only : noveg, ntree, roota_par, rootb_par, &
smpso, smpsc, fnitr, nbrdlf_dcd_brl_shrub, &
z0mr, displar, dleaf, rhol, rhos, taul, taus, xl, &
qe25, vcmx25, mp, c3psn, slatop, dsladlai, leafcn, flnr, woody, &
lflitcn, frootcn, livewdcn, deadwdcn, froot_leaf, stem_leaf, croot_stem, &
flivewd, fcur, lf_flab, lf_fcel, lf_flig, fr_flab, fr_fcel, fr_flig, &
dw_fcel, dw_flig, leaf_long, evergreen, stress_decid, season_decid, &
resist, pftpar20, pftpar28, pftpar29, pftpar30, pftpar31, &
allom1s, allom2s, &
allom1 , allom2 , allom3 , reinickerp, dwood
use module_cam_support, only: endrun
#if (defined CROP)
use pftvarcon , only : graincn
#endif
use globals , only : nstep
use clm_varsur , only : gti,soic2d,efisop2d,sand3d,clay3d,organic3d
!
! !ARGUMENTS:
implicit none
!
! !CALLED FROM:
! subroutine initialize in module initializeMod.
!
! !REVISION HISTORY:
! Created by Gordon Bonan.
! Updated to clm2.1 data structrues by Mariana Vertenstein
! 4/26/05, Peter Thornton: Eliminated exponential decrease in saturated hydraulic
! conductivity (hksat) with depth.
! Updated: Colette L. Heald (05/06) reading in VOC emission factors
! 27 February 2008: Keith Oleson; Qing Liu (2004) saturated hydraulic conductivity
! and matric potential
! 29 February 2008: David Lawrence; modified soil thermal and hydraulic properties to
! account for organic matter
! 18 March 2008: David Lawrence; nlevgrnd changes
! 03/28/08 Mark Flanner, read in netcdf files for SNICAR parameters
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: ivt(:) ! vegetation type index
integer , pointer :: pcolumn(:) ! column index of corresponding pft
integer , pointer :: pgridcell(:) ! gridcell index of corresponding pft
integer , pointer :: clandunit(:) ! landunit index of column
integer , pointer :: cgridcell(:) ! gridcell index of column
integer , pointer :: ctype(:) ! column type index
integer , pointer :: ltype(:) ! landunit type index
real(r8), pointer :: thick_wall(:) ! total thickness of urban wall
real(r8), pointer :: thick_roof(:) ! total thickness of urban roof
real(r8), pointer :: lat(:) ! gridcell latitude (radians)
!
! local pointers to implicit out arguments
!
real(r8), pointer :: z(:,:) ! layer depth (m)
real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m)
real(r8), pointer :: dz(:,:) ! layer thickness depth (m)
real(r8), pointer :: rootfr(:,:) ! fraction of roots in each soil layer
real(r8), pointer :: rootfr_road_perv(:,:) ! fraction of roots in each soil layer for urban pervious road
real(r8), pointer :: rresis(:,:) !root resistance by layer (0-1) (nlevgrnd)
real(r8), pointer :: dewmx(:) ! maximum allowed dew [mm]
real(r8), pointer :: bsw(:,:) ! Clapp and Hornberger "b" (nlevgrnd)
real(r8), pointer :: bsw2(:,:) ! Clapp and Hornberger "b" for CN code
real(r8), pointer :: psisat(:,:) ! soil water potential at saturation for CN code (MPa)
real(r8), pointer :: vwcsat(:,:) ! volumetric water content at saturation for CN code (m3/m3)
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity) (nlevgrnd)
real(r8), pointer :: watfc(:,:) ! volumetric soil water at field capacity (nlevsoi)
real(r8), pointer :: watdry(:,:) ! btran parameter for btran=0
real(r8), pointer :: watopt(:,:) ! btran parameter for btran = 1
real(r8), pointer :: hksat(:,:) ! hydraulic conductivity at saturation (mm H2O /s) (nlevgrnd)
real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm) (nlevgrnd)
real(r8), pointer :: csol(:,:) ! heat capacity, soil solids (J/m**3/Kelvin) (nlevgrnd)
real(r8), pointer :: tkmg(:,:) ! thermal conductivity, soil minerals [W/m-K] (new) (nlevgrnd)
real(r8), pointer :: tkdry(:,:) ! thermal conductivity, dry soil (W/m/Kelvin) (nlevgrnd)
real(r8), pointer :: tksatu(:,:) ! thermal conductivity, saturated soil [W/m-K] (new) (nlevgrnd)
real(r8), pointer :: wtfact(:) ! maximum saturated fraction for a gridcell
real(r8), pointer :: smpmin(:) ! restriction for min of soil potential (mm) (new)
real(r8), pointer :: hkdepth(:) ! decay factor (m)
integer , pointer :: isoicol(:) ! soil color class
real(r8), pointer :: gwc_thr(:) ! threshold soil moisture based on clay content
real(r8), pointer :: mss_frc_cly_vld(:) ! [frc] Mass fraction clay limited to 0.20
real(r8), pointer :: forc_ndep(:) ! nitrogen deposition rate (gN/m2/s)
real(r8), pointer :: efisop(:,:) ! emission factors for isoprene (ug isoprene m-2 h-1)
real(r8), pointer :: max_dayl(:) ! maximum daylength (s)
real(r8), pointer :: sandfrac(:)
real(r8), pointer :: clayfrac(:)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
integer :: ncid ! netCDF file id
integer :: n,j,ib,lev,bottom! indices
integer :: g,l,c,p ! indices
integer :: m ! vegetation type index
real(r8) :: bd ! bulk density of dry soil material [kg/m^3]
real(r8) :: tkm ! mineral conductivity
real(r8) :: xksat ! maximum hydraulic conductivity of soil [mm/s]
real(r8) :: scalez = 0.025_r8 ! Soil layer thickness discretization (m)
real(r8) :: clay,sand ! temporaries
real(r8) :: slope,intercept ! temporary, for rooting distribution
real(r8) :: temp, max_decl ! temporary, for calculation of max_dayl
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
real(r8) :: om_frac ! organic matter fraction
real(r8) :: om_watsat = 0.9_r8 ! porosity of organic soil
real(r8) :: om_hksat = 0.1_r8 ! saturated hydraulic conductivity of organic soil [mm/s]
real(r8) :: om_tkm = 0.25_r8 ! thermal conductivity of organic soil (Farouki, 1986) [W/m/K]
real(r8) :: om_sucsat = 10.3_r8 ! saturated suction for organic matter (Letts, 2000)
real(r8) :: om_csol = 2.5_r8 ! heat capacity of peat soil *10^6 (J/K m3) (Farouki, 1986)
real(r8) :: om_tkd = 0.05_r8 ! thermal conductivity of dry organic soil (Farouki, 1981)
real(r8) :: om_b = 2.7_r8 ! Clapp Hornberger paramater for oragnic soil (Letts, 2000)
real(r8) :: organic_max = 130._r8 ! organic matter (kg/m3) where soil is assumed to act like peat
real(r8) :: csol_bedrock = 2.0e6_r8 ! vol. heat capacity of granite/sandstone J/(m3 K)(Shabbir, 2000)
real(r8) :: pc = 0.5_r8 ! percolation threshold
real(r8) :: pcbeta = 0.139_r8 ! percolation exponent
real(r8) :: perc_frac ! "percolating" fraction of organic soil
real(r8) :: perc_norm ! normalize to 1 when 100% organic soil
real(r8) :: uncon_hksat ! series conductivity of mineral/organic soil
real(r8) :: uncon_frac ! fraction of "unconnected" soil
integer :: start(3),count(3) ! netcdf start/count arrays
integer :: varid ! netCDF id's
integer :: ret
integer :: ier ! error status
character(len=256) :: locfn ! local filename
character(len= 32) :: subname = 'iniTimeConst' ! subroutine name
integer :: mxsoil_color ! maximum number of soil color classes
real(r8), allocatable :: zurb_wall(:,:) ! wall (layer node depth)
real(r8), allocatable :: zurb_roof(:,:) ! roof (layer node depth)
real(r8), allocatable :: dzurb_wall(:,:) ! wall (layer thickness)
real(r8), allocatable :: dzurb_roof(:,:) ! roof (layer thickness)
real(r8), allocatable :: ziurb_wall(:,:) ! wall (layer interface)
real(r8), allocatable :: ziurb_roof(:,:) ! roof (layer interface)
!------------------------------------------------------------------------
integer :: closelatidx,closelonidx
real(r8):: closelat,closelon
integer :: iostat
!------------------------------------------------------------------------
! write(6,*) 'Attempting to initialize time invariant variables'
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
efisop => clm3%g%gve%efisop
! Assign local pointers to derived subtypes components (gridcell-level)
lat => clm3%g%lat
! Assign local pointers to derived subtypes components (landunit-level)
ltype => clm3%g%l%itype
thick_wall => clm3%g%l%lps%thick_wall
thick_roof => clm3%g%l%lps%thick_roof
! Assign local pointers to derived subtypes components (column-level)
ctype => clm3%g%l%c%itype
clandunit => clm3%g%l%c%landunit
cgridcell => clm3%g%l%c%gridcell
z => clm3%g%l%c%cps%z
dz => clm3%g%l%c%cps%dz
zi => clm3%g%l%c%cps%zi
bsw => clm3%g%l%c%cps%bsw
bsw2 => clm3%g%l%c%cps%bsw2
psisat => clm3%g%l%c%cps%psisat
vwcsat => clm3%g%l%c%cps%vwcsat
watsat => clm3%g%l%c%cps%watsat
watfc => clm3%g%l%c%cps%watfc
watdry => clm3%g%l%c%cps%watdry
watopt => clm3%g%l%c%cps%watopt
rootfr_road_perv => clm3%g%l%c%cps%rootfr_road_perv
hksat => clm3%g%l%c%cps%hksat
sucsat => clm3%g%l%c%cps%sucsat
tkmg => clm3%g%l%c%cps%tkmg
tksatu => clm3%g%l%c%cps%tksatu
tkdry => clm3%g%l%c%cps%tkdry
csol => clm3%g%l%c%cps%csol
smpmin => clm3%g%l%c%cps%smpmin
hkdepth => clm3%g%l%c%cps%hkdepth
wtfact => clm3%g%l%c%cps%wtfact
isoicol => clm3%g%l%c%cps%isoicol
gwc_thr => clm3%g%l%c%cps%gwc_thr
mss_frc_cly_vld => clm3%g%l%c%cps%mss_frc_cly_vld
max_dayl => clm3%g%l%c%cps%max_dayl
forc_ndep => clm_a2l%forc_ndep
! Assign local pointers to derived subtypes components (pft-level)
ivt => clm3%g%l%c%p%itype
pgridcell => clm3%g%l%c%p%gridcell
pcolumn => clm3%g%l%c%p%column
dewmx => clm3%g%l%c%p%pps%dewmx
rootfr => clm3%g%l%c%p%pps%rootfr
rresis => clm3%g%l%c%p%pps%rresis
sandfrac => clm3%g%l%c%p%pps%sandfrac
clayfrac => clm3%g%l%c%p%pps%clayfrac
allocate(zurb_wall(begl:endl,nlevurb), zurb_roof(begl:endl,nlevurb), &
dzurb_wall(begl:endl,nlevurb), dzurb_roof(begl:endl,nlevurb), &
ziurb_wall(begl:endl,0:nlevurb), ziurb_roof(begl:endl,0:nlevurb), stat=ier)
if (ier /= 0) then
call endrun( 'iniTimeConst: allocation error for zurb_wall,zurb_roof,dzurb_wall,dzurb_roof,ziurb_wall,ziurb_roof' )
end if
! --------------------------------------------------------------------
! Read soil color, sand and clay from surface dataset
! --------------------------------------------------------------------
call CLMDebug('TimeConst mark1')
do p = begp,endp
g = pgridcell(p)
sandfrac(p) = sand3d(g,1)/100.0_r8
clayfrac(p) = clay3d(g,1)/100.0_r8
end do
do m = 0,numpft
if (m <= ntree) then
pftcon%tree(m) = 1
else
pftcon%tree(m) = 0
end if
pftcon%z0mr(m) = z0mr(m)
pftcon%displar(m) = displar(m)
pftcon%dleaf(m) = dleaf(m)
pftcon%xl(m) = xl(m)
do ib = 1,numrad
pftcon%rhol(m,ib) = rhol(m,ib)
pftcon%rhos(m,ib) = rhos(m,ib)
pftcon%taul(m,ib) = taul(m,ib)
pftcon%taus(m,ib) = taus(m,ib)
end do
pftcon%qe25(m) = qe25(m)
pftcon%vcmx25(m) = vcmx25(m)
pftcon%mp(m) = mp(m)
pftcon%c3psn(m) = c3psn(m)
pftcon%slatop(m) = slatop(m)
pftcon%dsladlai(m) = dsladlai(m)
pftcon%leafcn(m) = leafcn(m)
pftcon%flnr(m) = flnr(m)
pftcon%smpso(m) = smpso(m)
pftcon%smpsc(m) = smpsc(m)
pftcon%fnitr(m) = fnitr(m)
pftcon%woody(m) = woody(m)
pftcon%lflitcn(m) = lflitcn(m)
pftcon%frootcn(m) = frootcn(m)
pftcon%livewdcn(m) = livewdcn(m)
pftcon%deadwdcn(m) = deadwdcn(m)
#if (defined CROP)
pftcon%graincn(m) = graincn(m)
#endif
pftcon%froot_leaf(m) = froot_leaf(m)
pftcon%stem_leaf(m) = stem_leaf(m)
pftcon%croot_stem(m) = croot_stem(m)
pftcon%flivewd(m) = flivewd(m)
pftcon%fcur(m) = fcur(m)
pftcon%lf_flab(m) = lf_flab(m)
pftcon%lf_fcel(m) = lf_fcel(m)
pftcon%lf_flig(m) = lf_flig(m)
pftcon%fr_flab(m) = fr_flab(m)
pftcon%fr_fcel(m) = fr_fcel(m)
pftcon%fr_flig(m) = fr_flig(m)
pftcon%dw_fcel(m) = dw_fcel(m)
pftcon%dw_flig(m) = dw_flig(m)
pftcon%leaf_long(m) = leaf_long(m)
pftcon%evergreen(m) = evergreen(m)
pftcon%stress_decid(m) = stress_decid(m)
pftcon%season_decid(m) = season_decid(m)
pftcon%resist(m) = resist(m)
pftcon%dwood(m) = dwood
end do
#ifdef CNDV
do m = 0,numpft
dgv_pftcon%crownarea_max(m) = pftpar20(m)
dgv_pftcon%tcmin(m) = pftpar28(m)
dgv_pftcon%tcmax(m) = pftpar29(m)
dgv_pftcon%gddmin(m) = pftpar30(m)
dgv_pftcon%twmax(m) = pftpar31(m)
dgv_pftcon%reinickerp(m) = reinickerp
dgv_pftcon%allom1(m) = allom1
dgv_pftcon%allom2(m) = allom2
dgv_pftcon%allom3(m) = allom3
! modification for shrubs by X.D.Z
if (m > ntree .and. m <= nbrdlf_dcd_brl_shrub ) then
dgv_pftcon%allom1(m) = allom1s
dgv_pftcon%allom2(m) = allom2s
end if
end do
#endif
! --------------------------------------------------------------------
! Define layer structure for soil, lakes, urban walls and roof
! Vertical profile of snow is not initialized here
! --------------------------------------------------------------------
! Lake layers (assumed same for all lake patches)
dzlak(1) = 0.1_r8
dzlak(2) = 1._r8
dzlak(3) = 2._r8
dzlak(4) = 3._r8
dzlak(5) = 4._r8
dzlak(6) = 5._r8
dzlak(7) = 7._r8
dzlak(8) = 7._r8
dzlak(9) = 10.45_r8
dzlak(10)= 10.45_r8
zlak(1) = 0.05_r8
zlak(2) = 0.6_r8
zlak(3) = 2.1_r8
zlak(4) = 4.6_r8
zlak(5) = 8.1_r8
zlak(6) = 12.6_r8
zlak(7) = 18.6_r8
zlak(8) = 25.6_r8
zlak(9) = 34.325_r8
zlak(10)= 44.775_r8
! Soil layers and interfaces (assumed same for all non-lake patches)
! "0" refers to soil surface and "nlevsoi" refers to the bottom of model soil
do j = 1, nlevgrnd
zsoi(j) = scalez*(exp(0.5_r8*(j-0.5_r8))-1._r8) !node depths
enddo
dzsoi(1) = 0.5_r8*(zsoi(1)+zsoi(2)) !thickness b/n two interfaces
do j = 2,nlevgrnd-1
dzsoi(j)= 0.5_r8*(zsoi(j+1)-zsoi(j-1))
enddo
dzsoi(nlevgrnd) = zsoi(nlevgrnd)-zsoi(nlevgrnd-1)
zisoi(0) = 0._r8
do j = 1, nlevgrnd-1
zisoi(j) = 0.5_r8*(zsoi(j)+zsoi(j+1)) !interface depths
enddo
zisoi(nlevgrnd) = zsoi(nlevgrnd) + 0.5_r8*dzsoi(nlevgrnd)
! Column level initialization for urban wall and roof layers and interfaces
do l = begl, endl
! "0" refers to urban wall/roof surface and "nlevsoi" refers to urban wall/roof bottom
if (ltype(l)==isturb) then
do j = 1, nlevurb
zurb_wall(l,j) = (j-0.5)*(thick_wall(l)/float(nlevurb)) !node depths
end do
do j = 1, nlevurb
zurb_roof(l,j) = (j-0.5)*(thick_roof(l)/float(nlevurb)) !node depths
end do
dzurb_wall(l,1) = 0.5*(zurb_wall(l,1)+zurb_wall(l,2)) !thickness b/n two interfaces
do j = 2,nlevurb-1
dzurb_wall(l,j)= 0.5*(zurb_wall(l,j+1)-zurb_wall(l,j-1))
enddo
dzurb_wall(l,nlevurb) = zurb_wall(l,nlevurb)-zurb_wall(l,nlevurb-1)
dzurb_roof(l,1) = 0.5*(zurb_roof(l,1)+zurb_roof(l,2)) !thickness b/n two interfaces
do j = 2,nlevurb-1
dzurb_roof(l,j)= 0.5*(zurb_roof(l,j+1)-zurb_roof(l,j-1))
enddo
dzurb_roof(l,nlevurb) = zurb_roof(l,nlevurb)-zurb_roof(l,nlevurb-1)
ziurb_wall(l,0) = 0.
do j = 1, nlevurb-1
ziurb_wall(l,j) = 0.5*(zurb_wall(l,j)+zurb_wall(l,j+1)) !interface depths
enddo
ziurb_wall(l,nlevurb) = zurb_wall(l,nlevurb) + 0.5*dzurb_wall(l,nlevurb)
ziurb_roof(l,0) = 0.
do j = 1, nlevurb-1
ziurb_roof(l,j) = 0.5*(zurb_roof(l,j)+zurb_roof(l,j+1)) !interface depths
enddo
ziurb_roof(l,nlevurb) = zurb_roof(l,nlevurb) + 0.5*dzurb_roof(l,nlevurb)
end if
end do
! --------------------------------------------------------------------
! Initialize nitrogen deposition values
! for now these are constants by gridcell, eventually they
! will be variables from the atmosphere, and at some point in between
! they will be specified time varying fields.
! --------------------------------------------------------------------
! Grid level initialization
do g = begg, endg
! nitrogen deposition (forcing flux from atmosphere)
! convert rate from 1/yr -> 1/s
!ndep moved to module_sf_clm and clm
! forc_ndep(g) = ndep(g)/(86400._r8 * 365._r8)
! VOC emission factors
! Set gridcell and landunit indices
efisop(:,g)=efisop2d(:,g)
end do
! write(6,*) 'efisop=',efisop
call CLMDebug('mark2')
! --------------------------------------------------------------------
! Initialize soil and lake levels
! Initialize soil color, thermal and hydraulic properties
! --------------------------------------------------------------------
! Column level initialization
do c = begc, endc
! Set gridcell and landunit indices
g = cgridcell(c)
l = clandunit(c)
! initialize maximum daylength, based on latitude and maximum declination
! maximum declination hardwired for present-day orbital parameters,
! +/- 23.4667 degrees = +/- 0.409571 radians, use negative value for S. Hem
call CLMDebug('mark21')
max_decl = 0.409571
if (lat(g) .lt. 0._r8) max_decl = -max_decl
temp = -(sin(lat(g))*sin(max_decl))/(cos(lat(g)) * cos(max_decl))
temp = min(1._r8,max(-1._r8,temp))
max_dayl(c) = 2.0_r8 * 13750.9871_r8 * acos(temp)
! Initialize restriction for min of soil potential (mm)
smpmin(c) = -1.e8_r8
! Decay factor (m)
hkdepth(c) = 1._r8/2.5_r8
call CLMDebug('mark22')
! Maximum saturated fraction
wtfact(c) = gti(g)
call CLMDebug('mark23')
! Soil color
isoicol(c) = soic2d(g)
! Soil hydraulic and thermal properties
! Note that urban roof, sunwall and shadewall thermal properties used to
! derive thermal conductivity and heat capacity are set to special
! value because thermal conductivity and heat capacity for urban
! roof, sunwall and shadewall are prescribed in SoilThermProp.F90 in
! SoilTemperatureMod.F90
if (ltype(l)==istdlak .or. ltype(l)==istwet .or. ltype(l)==istice) then
do lev = 1,nlevgrnd
bsw(c,lev) = spval
bsw2(c,lev) = spval
psisat(c,lev) = spval
vwcsat(c,lev) = spval
watsat(c,lev) = spval
watfc(c,lev) = spval
hksat(c,lev) = spval
sucsat(c,lev) = spval
tkmg(c,lev) = spval
tksatu(c,lev) = spval
tkdry(c,lev) = spval
if (ltype(l)==istwet .and. lev > nlevsoi) then
csol(c,lev) = csol_bedrock
else
csol(c,lev)= spval
endif
watdry(c,lev) = spval
watopt(c,lev) = spval
end do
else if (ltype(l)==isturb .and. (ctype(c) /= icol_road_perv) .and. (ctype(c) /= icol_road_imperv) )then
! Urban Roof, sunwall, shadewall properties set to special value
do lev = 1,nlevurb
watsat(c,lev) = spval
watfc(c,lev) = spval
bsw(c,lev) = spval
bsw2(c,lev) = spval
psisat(c,lev) = spval
vwcsat(c,lev) = spval
hksat(c,lev) = spval
sucsat(c,lev) = spval
tkmg(c,lev) = spval
tksatu(c,lev) = spval
tkdry(c,lev) = spval
csol(c,lev) = spval
watdry(c,lev) = spval
watopt(c,lev) = spval
end do
else ! soil columns of both urban and non-urban types
do lev = 1,nlevgrnd
! duplicate clay and sand values from 10th soil layer
if (lev .le. nlevsoi) then
clay = clay3d(g,lev)
sand = sand3d(g,lev)
om_frac = (organic3d(g,lev)/organic_max)**2._r8
else
clay = clay3d(g,nlevsoi)
sand = sand3d(g,nlevsoi)
om_frac = 0._r8
endif
! No organic matter for urban
if (ltype(l)==isturb) then
om_frac = 0._r8
end if
! Note that the following properties are overwritten for urban impervious road
! layers that are not soil in SoilThermProp.F90 within SoilTemperatureMod.F90
watsat(c,lev) = 0.489_r8 - 0.00126_r8*sand
bsw(c,lev) = 2.91 + 0.159*clay
sucsat(c,lev) = 10._r8 * ( 10._r8**(1.88_r8-0.0131_r8*sand) )
bd = (1._r8-watsat(c,lev))*2.7e3_r8
watsat(c,lev) = (1._r8 - om_frac)*watsat(c,lev) + om_watsat*om_frac
tkm = (1._r8-om_frac)*(8.80_r8*sand+2.92_r8*clay)/(sand+clay)+om_tkm*om_frac ! W/(m K)
bsw(c,lev) = (1._r8-om_frac)*(2.91_r8 + 0.159_r8*clay) + om_frac*om_b
bsw2(c,lev) = -(3.10_r8 + 0.157_r8*clay - 0.003_r8*sand)
psisat(c,lev) = -(exp((1.54_r8 - 0.0095_r8*sand + 0.0063_r8*(100.0_r8-sand-clay))*log(10.0_r8))*9.8e-5_r8)
vwcsat(c,lev) = (50.5_r8 - 0.142_r8*sand - 0.037_r8*clay)/100.0_r8
sucsat(c,lev) = (1._r8-om_frac)*sucsat(c,lev) + om_sucsat*om_frac
xksat = 0.0070556 *( 10.**(-0.884+0.0153*sand) ) ! mm/s
! perc_frac is zero unless perf_frac greater than percolation threshold
if (om_frac > pc) then
perc_norm=(1._r8 - pc)**(-pcbeta)
perc_frac=perc_norm*(om_frac - pc)**pcbeta
else
perc_frac=0._r8
endif
! uncon_frac is fraction of mineral soil plus fraction of "nonpercolating" organic soil
uncon_frac=(1._r8-om_frac)+(1._r8-perc_frac)*om_frac
! uncon_hksat is series addition of mineral/organic conductivites
if (om_frac .lt. 1._r8) then
uncon_hksat=uncon_frac/((1._r8-om_frac)/xksat &
+((1._r8-perc_frac)*om_frac)/om_hksat)
else
uncon_hksat = 0._r8
end if
hksat(c,lev) = uncon_frac*uncon_hksat + (perc_frac*om_frac)*om_hksat
tkmg(c,lev) = tkm ** (1._r8- watsat(c,lev))
tksatu(c,lev) = tkmg(c,lev)*0.57_r8**watsat(c,lev)
tkdry(c,lev) = ((0.135_r8*bd + 64.7_r8) / (2.7e3_r8 - 0.947_r8*bd))*(1._r8-om_frac) + &
om_tkd*om_frac
csol(c,lev) = ((1._r8-om_frac)*(2.128_r8*sand+2.385_r8*clay) / (sand+clay) + &
om_csol*om_frac)*1.e6_r8 ! J/(m3 K)
if (lev .gt. nlevsoi) then
csol(c,lev) = csol_bedrock
endif
watdry(c,lev) = watsat(c,lev) * (316230._r8/sucsat(c,lev)) ** (-1._r8/bsw(c,lev))
watopt(c,lev) = watsat(c,lev) * (158490._r8/sucsat(c,lev)) ** (-1._r8/bsw(c,lev))
!! added by K.Sakaguchi for beta from Lee and Pielke, 1992
! water content at field capacity, defined as hk = 0.1 mm/day
! used eqn (7.70) in CLM3 technote with k = 0.1 (mm/day) / 86400 (day/sec)
watfc(c,lev) = watsat(c,lev) * (0.1_r8 / (hksat(c,lev)*86400._r8))**(1._r8/(2._r8*bsw(c,lev)+3._r8))
end do
!
! Urban pervious and impervious road
!
! Impervious road layers -- same as above except set watdry and watopt as missing
if (ctype(c) == icol_road_imperv) then
do lev = 1,nlevgrnd
watdry(c,lev) = spval
watopt(c,lev) = spval
end do
! pervious road layers -- same as above except also set rootfr_road_perv
! Currently, pervious road has same properties as soil
else if (ctype(c) == icol_road_perv) then
do lev = 1, nlevgrnd
rootfr_road_perv(c,lev) = 0._r8
enddo
do lev = 1,nlevsoi
rootfr_road_perv(c,lev) = 0.1_r8 ! uniform profile
end do
end if
endif
! Define lake or non-lake levels, layers and interfaces
if (ltype(l) == istdlak) then
z(c,1:nlevlak) = zlak(1:nlevlak)
dz(c,1:nlevlak) = dzlak(1:nlevlak)
else if (ltype(l) == isturb) then
if (ctype(c)==icol_sunwall .or. ctype(c)==icol_shadewall) then
z(c,1:nlevurb) = zurb_wall(l,1:nlevurb)
zi(c,0:nlevurb) = ziurb_wall(l,0:nlevurb)
dz(c,1:nlevurb) = dzurb_wall(l,1:nlevurb)
else if (ctype(c)==icol_roof) then
z(c,1:nlevurb) = zurb_roof(l,1:nlevurb)
zi(c,0:nlevurb) = ziurb_roof(l,0:nlevurb)
dz(c,1:nlevurb) = dzurb_roof(l,1:nlevurb)
else
z(c,1:nlevurb) = zsoi(1:nlevurb)
zi(c,0:nlevurb) = zisoi(0:nlevurb)
dz(c,1:nlevurb) = dzsoi(1:nlevurb)
end if
else
z(c,1:nlevgrnd) = zsoi(1:nlevgrnd)
zi(c,0:nlevgrnd) = zisoi(0:nlevgrnd)
dz(c,1:nlevgrnd) = dzsoi(1:nlevgrnd)
end if
! Initialize terms needed for dust model
clay = clay3d(g,1)
gwc_thr(c) = 0.17_r8 + 0.14_r8*clay*0.01_r8
mss_frc_cly_vld(c) = min(clay*0.01_r8, 0.20_r8)
end do
call CLMDebug('mark3')
! pft level initialization
do p = begp, endp
! Initialize maximum allowed dew
dewmx(p) = 0.1_r8
! Initialize root fraction (computing from surface, d is depth in meter):
! Y = 1 -1/2 (exp(-ad)+exp(-bd) under the constraint that
! Y(d =0.1m) = 1-beta^(10 cm) and Y(d=d_obs)=0.99 with
! beta & d_obs given in Zeng et al. (1998).
c = pcolumn(p)
if (ivt(p) /= noveg) then
do lev = 1, nlevgrnd
rootfr(p,lev) = 0._r8
enddo
do lev = 1, nlevsoi-1
rootfr(p,lev) = .5_r8*( exp(-roota_par(ivt(p)) * zi(c,lev-1)) &
+ exp(-rootb_par(ivt(p)) * zi(c,lev-1)) &
- exp(-roota_par(ivt(p)) * zi(c,lev )) &
- exp(-rootb_par(ivt(p)) * zi(c,lev )) )
end do
rootfr(p,nlevsoi) = .5_r8*( exp(-roota_par(ivt(p)) * zi(c,nlevsoi-1)) &
+ exp(-rootb_par(ivt(p)) * zi(c,nlevsoi-1)) )
rootfr(p,nlevsoi+1:nlevgrnd) = 0.0_r8
else
rootfr(p,1:nlevsoi) = 0._r8
endif
! initialize rresis, for use in ecosystemdyn
do lev = 1,nlevgrnd
rresis(p,lev) = 0._r8
end do
end do ! end pft level initialization
#if (defined CN)
! initialize the CN variables for special landunits, including lake points
if(nstep==1) call CNiniSpecial()
#endif
call CLMDebug('Successfully initialized time invariant variables')
deallocate(zurb_wall)
deallocate(zurb_roof)
deallocate(dzurb_wall)
deallocate(dzurb_roof)
deallocate(ziurb_wall)
deallocate(ziurb_roof)
end subroutine iniTimeConst
module QSatMod 4,1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: QSatMod
!
! !DESCRIPTION:
! Computes saturation mixing ratio and the change in saturation
!
use module_cam_support, only: endrun
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: QSat
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: QSat
!
! !INTERFACE:
subroutine QSat (T, p, es, esdT, qs, qsdT) 8,2
!
! !DESCRIPTION:
! Computes saturation mixing ratio and the change in saturation
! mixing ratio with respect to temperature.
! Reference: Polynomial approximations from:
! Piotr J. Flatau, et al.,1992: Polynomial fits to saturation
! vapor pressure. Journal of Applied Meteorology, 31, 1507-1513.
!
! !USES:
use shr_kind_mod , only: r8 => shr_kind_r8
use shr_const_mod, only: SHR_CONST_TKFRZ
!
! !ARGUMENTS:
implicit none
real(r8), intent(in) :: T ! temperature (K)
real(r8), intent(in) :: p ! surface atmospheric pressure (pa)
real(r8), intent(out) :: es ! vapor pressure (pa)
real(r8), intent(out) :: esdT ! d(es)/d(T)
real(r8), intent(out) :: qs ! humidity (kg/kg)
real(r8), intent(out) :: qsdT ! d(qs)/d(T)
!
! !CALLED FROM:
! subroutine Biogeophysics1 in module Biogeophysics1Mod
! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod
! subroutine CanopyFluxesMod CanopyFluxesMod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
!
!
! !LOCAL VARIABLES:
!EOP
!
real(r8) :: T_limit
real(r8) :: td,vp,vp1,vp2
!
! For water vapor (temperature range 0C-100C)
!
real(r8), parameter :: a0 = 6.11213476_r8
real(r8), parameter :: a1 = 0.444007856_r8
real(r8), parameter :: a2 = 0.143064234e-01_r8
real(r8), parameter :: a3 = 0.264461437e-03_r8
real(r8), parameter :: a4 = 0.305903558e-05_r8
real(r8), parameter :: a5 = 0.196237241e-07_r8
real(r8), parameter :: a6 = 0.892344772e-10_r8
real(r8), parameter :: a7 = -0.373208410e-12_r8
real(r8), parameter :: a8 = 0.209339997e-15_r8
!
! For derivative:water vapor
!
real(r8), parameter :: b0 = 0.444017302_r8
real(r8), parameter :: b1 = 0.286064092e-01_r8
real(r8), parameter :: b2 = 0.794683137e-03_r8
real(r8), parameter :: b3 = 0.121211669e-04_r8
real(r8), parameter :: b4 = 0.103354611e-06_r8
real(r8), parameter :: b5 = 0.404125005e-09_r8
real(r8), parameter :: b6 = -0.788037859e-12_r8
real(r8), parameter :: b7 = -0.114596802e-13_r8
real(r8), parameter :: b8 = 0.381294516e-16_r8
!
! For ice (temperature range -75C-0C)
!
real(r8), parameter :: c0 = 6.11123516_r8
real(r8), parameter :: c1 = 0.503109514_r8
real(r8), parameter :: c2 = 0.188369801e-01_r8
real(r8), parameter :: c3 = 0.420547422e-03_r8
real(r8), parameter :: c4 = 0.614396778e-05_r8
real(r8), parameter :: c5 = 0.602780717e-07_r8
real(r8), parameter :: c6 = 0.387940929e-09_r8
real(r8), parameter :: c7 = 0.149436277e-11_r8
real(r8), parameter :: c8 = 0.262655803e-14_r8
!
! For derivative:ice
!
real(r8), parameter :: d0 = 0.503277922_r8
real(r8), parameter :: d1 = 0.377289173e-01_r8
real(r8), parameter :: d2 = 0.126801703e-02_r8
real(r8), parameter :: d3 = 0.249468427e-04_r8
real(r8), parameter :: d4 = 0.313703411e-06_r8
real(r8), parameter :: d5 = 0.257180651e-08_r8
real(r8), parameter :: d6 = 0.133268878e-10_r8
real(r8), parameter :: d7 = 0.394116744e-13_r8
real(r8), parameter :: d8 = 0.498070196e-16_r8
!-----------------------------------------------------------------------
T_limit = T - SHR_CONST_TKFRZ
if (T_limit > 100.0_r8) T_limit=100.0_r8
if (T_limit < -75.0_r8) T_limit=-75.0_r8
td = T_limit
if (td >= 0.0_r8) then
es = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 &
+ td*(a5 + td*(a6 + td*(a7 + td*a8)))))))
esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 &
+ td*(b5 + td*(b6 + td*(b7 + td*b8)))))))
else
es = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 &
+ td*(c5 + td*(c6 + td*(c7 + td*c8)))))))
esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 &
+ td*(d5 + td*(d6 + td*(d7 + td*d8)))))))
endif
es = es * 100._r8 ! pa
esdT = esdT * 100._r8 ! pa/K
vp = 1.0_r8 / (p - 0.378_r8*es)
vp1 = 0.622_r8 * vp
vp2 = vp1 * vp
qs = es * vp1 ! kg/kg
qsdT = esdT * vp2 * p ! 1 / K
end subroutine QSat
end module QSatMod
module initGridcellsMod 1,5
!Edited to 3.5 from Jiming Jin's 3.0 version by Zack Subin, 7/17/08.
!Latdeg, londeg, & area for l, c, & p, and itype for g, was eliminated.
!To prevent redoing equations, areas are put back in clmtype, but
!latdeg & londeg are redundant and left out.
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: initGridcellsMod
!
! !DESCRIPTION:
! Initializes sub-grid mapping for each land grid cell
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype
use clm_varpar, only : lsmlon, lsmlat,npatch_urban,npatch_glacier,npatch_crop, maxpatch, maxpatch_pft
use clm_varsur, only : wtxy,vegxy,numlon, area, latixy, longxy
use module_cam_support, only: endrun
! !PUBLIC TYPES:
implicit none
private
save
!
! !PUBLIC MEMBER FUNCTIONS:
public initGridcells ! Initialize sub-grid gridcell mapping
!
! !PIVATE MEMBER FUNCTIONS:
private landunit_veg_compete
private landunit_veg_noncompete
private landunit_special
private landunit_crop_noncompete
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!
! !LOCAL MODULE VARIABLES:
type(gridcell_type), pointer :: gptr ! pointer to gridcell derived subtype
type(landunit_type), pointer :: lptr ! pointer to landunit derived subtype
type(column_type) , pointer :: cptr ! pointer to column derived subtype
type(pft_type) , pointer :: pptr ! pointer to pft derived subtype
!-----------------------------------------------------------------------
contains
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: initGridcells
!
! !INTERFACE:
subroutine initGridcells 1,12
!
! !DESCRIPTION:
! Initialize sub-grid mapping and allocates space for derived type
! hierarchy. For each land gridcell determine landunit, column and
! pft properties. Note that ngcells, nlunits, ncols and npfts are
! per-processor totals here and are currently not used for anything other
! than placeholders. Determine if there are any vegetated landunits and
! if so---the weight of the vegetated landunit relative to the gridcell
! The first landunit contains all the vegetated patches (if any) For now,
! the vegetated patches will all be gathered on a single landunit, with
! each vegetated type having its own column on that landunit. The special
! patches (urban, lake, wetland, glacier) each get their own landunit
! having a single column and one non-vegetated pfts
!
! !USES:
use decompMod , only : get_proc_bounds, get_gcell_xyind, &
get_gcell_info
use clm_varcon, only : pie
!
! !ARGUMENTS:
implicit none
! weights
!
! !REVISION HISTORY:
! Created by Peter Thornton and Mariana Vertenstein
!
!EOP
!
! !LOCAL VARIABLES:
integer :: g,i,j,m,n,gi,li,ci,pi ! indices
integer :: ngcells ! temporary dummy
integer :: nlunits ! temporary dummy
integer :: ncols ! temporary dummy
integer :: npfts ! temporary dummy
integer :: nveg ! number of pfts in naturally vegetated landunit
real(r8):: wtveg ! weight (relative to gridcell) of naturally vegetated landunit
integer :: ncrop ! number of crop pfts in crop landunit
real(r8):: wtcrop ! weight (relative to gridcell) of crop landunit
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
integer :: ier ! error status
integer :: ilunits, icols, ipfts ! temporaries
!New variables -- comment for now, probably not needed
! integer :: nlake ! number of pfts (columns) in lake landunit
! real(r8):: wtlake ! weight (gridcell) of lake landunit
! integer :: nwetland ! number of pfts (columns) in wetland landunit
! real(r8):: wtwetland ! weight (gridcell) of wetland landunit
! integer :: nglacier ! number of pfts (columns) in glacier landunit
! real(r8):: wtglacier ! weight (gridcell) of glacier landunit
!!!!!!!!!!!!!
!------------------------------------------------------------------------
! Set pointers into derived types for this module
gptr => clm3%g
lptr => clm3%g%l
cptr => clm3%g%l%c
pptr => clm3%g%l%c%p
! Determine necessary indices
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
call get_gcell_xyind(begg, endg)
! Determine number of land gridcells on this processor
clm3%ngridcells = endg - begg + 1
! Determine gridcell properties.
! Set area, weight, and type information for this gridcell.
! For now there is only one type of gridcell, value = 1
! Still need to resolve the calculation of area for the gridcell
ngcells = begg-1
nlunits = begl-1
ncols = begc-1
npfts = begp-1
do gi = begg, endg
! Get 2d grid indices
!
gptr%area(gi) = area(gi)
call CLMDebug('mark0')
! gptr%itype(gi) = 1
!gptr%wtglob(g) = gptr%area(g)/clm3%area
gptr%lat(gi) = latixy(gi) * pie/180.
gptr%lon(gi) = longxy(gi) * pie/180.
gptr%latdeg(gi) = latixy(gi)
gptr%londeg(gi) = longxy(gi)
! gptr%landfrac(gi) = landfrac(i,j)
!
gptr%luni(gi) = nlunits + 1
gptr%coli(gi) = ncols + 1
gptr%pfti(gi) = npfts + 1
call get_gcell_info(gi, nlunits=ilunits, ncols=icols, npfts=ipfts)
ngcells = ngcells + 1
nlunits = nlunits + ilunits
ncols = ncols + icols
npfts = npfts + ipfts
gptr%lunf(gi) = nlunits
gptr%colf(gi) = ncols
gptr%pftf(gi) = npfts
gptr%nlandunits(gi) = gptr%lunf(gi) - gptr%luni(gi) + 1
gptr%ncolumns(gi) = gptr%colf(gi) - gptr%coli(gi) + 1
gptr%npfts(gi) = gptr%pftf(gi) - gptr%pfti(gi) + 1
end do
call CLMDebug('mark1')
! For each land gridcell determine landunit, column and pft properties.
ngcells = 0
nlunits = 0
ncols = 0
npfts = 0
li = begl - 1
ci = begc - 1
pi = begp - 1
do gi = begg,endg
! Determine 2d lat and lon indices
! Obtain gridcell properties
call get_gcell_info(gi, nveg=nveg, wtveg=wtveg, ncrop=ncrop, wtcrop=wtcrop)
! Determine naturally vegetated landunit
#if (defined NOCOMPETE)
if (nveg > 0) call landunit_veg_noncompete(nveg, wtveg, i, j, gi, li, ci, pi)
#else
if (nveg > 0) call landunit_veg_compete(nveg, wtveg, i, j, gi, li, ci, pi)
#endif
! Determine crop landunit.
if (ncrop > 0) call landunit_crop_noncompete(ncrop, wtcrop, i, j, gi, li, ci, pi)
! Determine special landunits (urban, lake, wetland, glacier).
do m = npatch_urban, npatch_glacier
if (wtxy(gi,m) > 0.) call landunit_special(i, j, m, gi, li, ci, pi)
end do
end do
end subroutine initGridcells
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: landunit_veg_compete
!
! !INTERFACE:
subroutine landunit_veg_compete (nveg, wtveg, i, j, & 1,1
gi, li, ci, pi)
!
! !DESCRIPTION:
! Initialize vegetated landunit with competition
!
! !USES:
use clm_varcon, only : istsoil
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: nveg ! number of vegetated patches in gridcell
real(r8), intent(in) :: wtveg ! weight relative to gridcell of veg
! landunit
integer , intent(in) :: i ! 2d longitude index
integer , intent(in) :: j ! 2d latitude index
integer , intent(in) :: gi ! gridcell index
integer , intent(inout) :: li ! landunit index
integer , intent(inout) :: ci ! column index
integer , intent(inout) :: pi ! pft index
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!
! !LOCAL VARIABLES:
integer :: m ! indices
!------------------------------------------------------------------------
! Set landunit properties
! Increment landunits and set indices into lower levels in hierarchy and higher levels
! in hierarchy and topological mapping functionality
li = li + 1
lptr%ncolumns(li) = 1
lptr%coli(li) = ci + 1
lptr%colf(li) = ci + 1
lptr%npfts(li) = nveg
lptr%pfti(li) = pi + 1
lptr%pftf(li) = pi + nveg
!
lptr%area(li) = gptr%area(gi) * wtveg
!
lptr%gridcell(li) = gi
lptr%wtgcell(li) = wtveg
!
! lptr%latdeg(li) = latixy(i,j)
! lptr%londeg(li) = longxy(i,j)
!
lptr%ifspecial(li) = .false.
lptr%lakpoi(li) = .false.
lptr%urbpoi(li) = .false.
lptr%itype(li) = istsoil
! Set column properties for this landunit
! Increment column - set only one column on compete landunit - and set indices into
! lower levels in hierarchy, higher levels in hierarchy and topological mapping
! functionality (currently all columns have type 1)
ci = ci + 1
cptr%npfts(ci) = nveg
cptr%pfti(ci) = pi + 1
cptr%pftf(ci) = pi + nveg
!
cptr%area(ci) = lptr%area(li)
!
cptr%landunit(ci) = li
cptr%gridcell(ci) = gi
cptr%wtlunit(ci) = 1.0
cptr%wtgcell(ci) = wtveg
!
! cptr%latdeg(ci) = latixy(i,j)
! cptr%londeg(ci) = longxy(i,j)
!
cptr%itype(ci) = 1
! Set pft properties for this landunit
! Topological mapping functionality
!dir$ concurrent
!cdir nodep
do m = 1,maxpatch_pft
if (wtxy(gi,m) > 0.) then
pi = pi+1
pptr%column(pi) = ci
pptr%landunit(pi) = li
pptr%gridcell(pi) = gi
pptr%wtcol(pi) = wtxy(gi,m) / wtveg
pptr%wtlunit(pi) = wtxy(gi,m) / wtveg
pptr%wtgcell(pi) = wtxy(gi,m)
!
pptr%area(pi) = cptr%area(ci) * pptr%wtcol(pi)
!
pptr%mxy(pi) = m
!
! pptr%latdeg(pi) = latixy(i,j)
! pptr%londeg(pi) = longxy(i,j)
!
pptr%itype(pi) = vegxy(gi,m)
end if ! non-zero weight for this pft
end do ! loop through maxpatch_pft
end subroutine landunit_veg_compete
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: landunit_veg_noncompete
!
! !INTERFACE:
subroutine landunit_veg_noncompete (nveg, wtveg, i, j, & 1,1
gi, li, ci, pi)
!
! !DESCRIPTION:
! Initialize vegetated landunit without competition
!
! !USES:
use clm_varcon, only : istsoil
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: nveg ! number of vegetated patches in gridcell
real(r8), intent(in) :: wtveg ! weight relative to gridcell of veg landunit
integer , intent(in) :: i ! 2d longitude index
integer , intent(in) :: j ! 2d latitude index
integer , intent(in) :: gi ! gridcell index
integer , intent(inout) :: li ! landunit index
integer , intent(inout) :: ci ! column index
integer , intent(inout) :: pi ! pft index
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!
! !LOCAL VARIABLES:
integer :: m ! indices
real(r8) :: wtlunit ! weight relative to landunit
!------------------------------------------------------------------------
! Set landunit properties
! Increment landunits and set indices into lower levels in hierarchy and higher levels
! in hierarchy and topological mapping functionality
li = li + 1
lptr%ncolumns(li) = nveg
lptr%coli(li) = ci + 1
lptr%colf(li) = ci + nveg
lptr%npfts(li) = nveg
lptr%pfti(li) = pi + 1
lptr%pftf(li) = pi + nveg
!
lptr%area(li) = gptr%area(gi) * wtveg
!
lptr%gridcell(li) = gi
lptr%wtgcell(li) = wtveg
!
! lptr%latdeg(li) = latixy(i,j)
! lptr%londeg(li) = longxy(i,j)
!
lptr%ifspecial(li) = .false.
lptr%lakpoi(li) = .false.
lptr%itype(li) = istsoil
! Set column properties for this landunit
! Increment column - each column has its own pft - and set indices into
! lower levels in hierarchy, higher levels in hierarchy and topological mapping
! functionality (currently all columns have type 1)
! Set column and pft properties
! Loop through regular (vegetated) patches, assign one column for each
! vegetated patch with non-zero weight. The weights for each column on
! the vegetated landunit must add to one when summed over the landunit,
! so the wtxy(i,j,m) values are taken relative to the total wtveg.
!dir$ concurrent
!cdir nodep
do m = 1, maxpatch_pft
if (wtxy(gi,m) > 0.) then
! Determine weight relative to landunit of pft/column
wtlunit = wtxy(gi,m) / wtveg
! Increment number of columns on landunit
ci = ci + 1
cptr%npfts(ci) = 1
cptr%pfti(ci) = ci
cptr%pftf(ci) = ci
!
cptr%area(ci) = lptr%area(li) * wtlunit
!
cptr%landunit(ci) = li
cptr%gridcell(ci) = gi
cptr%wtlunit(ci) = wtlunit
!
cptr%wtgcell(ci) = cptr%area(ci) / gptr%area(gi)
!
!
! cptr%latdeg(ci) = latixy(i,j)
! cptr%londeg(ci) = longxy(i,j)
!
cptr%itype(ci) = 1
! Increment number of pfts on this landunit
! Set area, weight (relative to column) and type information for this pft
! For now, a single pft per column, so weight = 1
! pft type comes from the m dimension of wtxy()
! Set grid index, weight (relative to grid cell)
! and m index (needed for laixy, etc. reference)
pi = pi + 1
pptr%column(pi) = ci
pptr%landunit(pi) = li
pptr%gridcell(pi) = gi
pptr%wtcol(pi) = 1.0
pptr%wtlunit(pi) = cptr%wtlunit(ci)
!
pptr%area(pi) = cptr%area(ci)
pptr%wtgcell(pi) = pptr%area(pi) / gptr%area(gi)
!
pptr%mxy(pi) = m
!
! pptr%latdeg(pi) = latixy(i,j)
! pptr%londeg(pi) = longxy(i,j)
!
pptr%itype(pi) = vegxy(gi,m)
end if ! end if non-zero weight
end do ! end loop through the possible vegetated patch indices
end subroutine landunit_veg_noncompete
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: landunit_special
!
! !INTERFACE:
subroutine landunit_special ( i, j, m, gi, li, ci, pi) 1,4
!
! !DESCRIPTION:
! Initialize special landunits (urban, lake, wetland, glacier)
!
! !USES:
use pftvarcon, only : noveg
use clm_varcon, only : istice, istwet, istdlak, isturb
use clm_varpar, only : npatch_lake, npatch_wet
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: i !2-dim longitude index
integer, intent(in) :: j !2-dim latitude index
integer, intent(in) :: m !2-dim PFT patch index
integer, intent(in) :: gi !gridcell index
integer, intent(inout) :: li !landunit index
integer, intent(inout) :: ci !column index
integer, intent(inout) :: pi !pft index
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!
! !LOCAL VARIABLES:
integer :: c !column loop index
integer :: ncols !number of columns
integer :: npfts !number of pfts
integer :: ier !error status
real(r8) :: weight !temporary weight
integer :: itype !landunit type
!------------------------------------------------------------------------
! Define landunit type
if (m == npatch_lake) then !deep lake (from pctlak)
itype = istdlak
else if (m == npatch_wet) then !wetland (from pctwet)
itype = istwet
else if (m == npatch_glacier) then !glacier (from pctgla)
itype = istice
else if (m == npatch_urban) then !urban (from pcturb)
itype = isturb
else !error
write(6,*)'special landunit are currently only:', &
' deep lake, wetland, glacier or urban)'
call endrun()
endif
! Determine landunit index and landunit properties
li = li + 1
lptr%ncolumns(li) = 1
lptr%coli(li) = ci + 1
lptr%colf(li) = ci + 1
lptr%npfts(li) = 1
lptr%pfti(li) = pi + 1
lptr%pftf(li) = pi + 1
!
lptr%area(li) = gptr%area(gi) * wtxy(gi,m)
lptr%gridcell(li) = gi
lptr%wtgcell(li) = lptr%area(li) / gptr%area(gi)
!
!
! lptr%latdeg(li) = latixy(i,j)
! lptr%londeg(li) = longxy(i,j)
!
lptr%ifspecial(li) = .true.
if (itype == istdlak) then
lptr%lakpoi(li) = .true.
else
lptr%lakpoi(li) = .false.
end if
lptr%itype(li) = itype
! For the special landunits there currently is only one column
! Later, the age classes will be implemented on different columns within
! the same landunit, so the column type will correspond to an age class
ncols = 1
! Loop through columns for this landunit and set the column properties
! We know that there is only one column for the special landunit - but
! the loop is included for future consistency.
do c = 1,ncols
! Determine column index and column properties
! For now all columns have the same type, value = 1
weight = 1.0/ncols
ci = ci + c
cptr%npfts(ci) = 1
cptr%pfti(ci) = pi + 1
cptr%pftf(ci) = pi + 1
!
cptr%area(ci) = lptr%area(li) * weight
!
cptr%landunit(ci) = li
cptr%gridcell(ci) = gi
cptr%wtlunit(ci) = weight
!
cptr%wtgcell(ci) = cptr%area(ci) / gptr%area(gi)
!
!
! cptr%latdeg(ci) = latixy(i,j)
! cptr%londeg(ci) = longxy(i,j)
!
cptr%itype(ci) = 1
! Determine pft index and pft properties
! Each column has one non-vegetated pft
! Set area, weight (relative to column), and type information
! for this non-vegetated pft
! Set grid index, weight (relative to grid cell) and
! m index (needed for laixy, etc. reference)
npfts = 1
weight = 1.0/npfts
pi = pi + 1
pptr%column(pi) = ci
pptr%landunit(pi) = li
pptr%gridcell(pi) = gi
!
pptr%area(pi) = lptr%area(li) * weight
!
pptr%wtcol(pi) = weight
pptr%wtlunit(pi) = cptr%wtlunit(ci)
!
pptr%wtgcell(pi) = pptr%area(pi) / gptr%area(gi)
!
pptr%mxy(pi) = m
!
! pptr%latdeg(pi) = latixy(i,j)
! pptr%londeg(pi) = longxy(i,j)
!
pptr%itype(pi) = noveg
end do ! end loop through ncolumns
end subroutine landunit_special
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: landunit_crop_noncompete
!
! !INTERFACE:
subroutine landunit_crop_noncompete (ncrop, wtcrop, i, j, & 1,3
gi, li, ci, pi)
!
! !DESCRIPTION:
! Initialize crop landunit without competition
!
! !USES:
use clm_varcon, only : istsoil
#ifdef CN
use clm_varcon, only : istsoil,istcrop
#endif
use clm_varpar, only : npatch_crop
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: ncrop ! number of vegetated patches in gridcell
real(r8), intent(in) :: wtcrop ! weight relative to gridcell of veg landunit
integer , intent(in) :: i ! 2d longitude index
integer , intent(in) :: j ! 2d latitude index
integer , intent(in) :: gi ! gridcell index
integer , intent(inout) :: li ! landunit index
integer , intent(inout) :: ci ! column index
integer , intent(inout) :: pi ! pft index
!
! !REVISION HISTORY:
! Created by Sam Levis
!
!EOP
!
! !LOCAL VARIABLES:
integer :: m ! indices
real(r8) :: wtlunit ! weight relative to landunit
!------------------------------------------------------------------------
! Set landunit properties
! Increment landunits and set indices into lower levels in hierarchy and higher levels
! in hierarchy and topological mapping functionality
li = li + 1
lptr%ncolumns(li) = ncrop
lptr%coli(li) = ci + 1
lptr%colf(li) = ci + ncrop
lptr%npfts(li) = ncrop
lptr%pfti(li) = pi + 1
lptr%pftf(li) = pi + ncrop
!
lptr%area(li) = gptr%area(gi) * wtcrop
lptr%gridcell(li) = gi
lptr%wtgcell(li) = wtcrop
!
!
! lptr%latdeg(li) = latixy(i,j)
! lptr%londeg(li) = longxy(i,j)
!
lptr%ifspecial(li) = .false.
lptr%lakpoi(li) = .false.
lptr%urbpoi(li) = .false.
#ifdef CROP
lptr%itype(li) = istcrop
#else
lptr%itype(li) = istsoil
#endif
! Set column properties for this landunit
! Increment column - each column has its own pft - and set indices into
! lower levels in hierarchy, higher levels in hierarchy and topological mapping
! functionality (currently all columns have type 1)
! Set column and pft properties
! Loop through regular (vegetated) patches, assign one column for each
! vegetated patch with non-zero weight. The weights for each column on
! the vegetated landunit must add to one when summed over the landunit,
! so the wtxy(i,j,m) values are taken relative to the total wtcrop.
!dir$ concurrent
!cdir nodep
do m = npatch_glacier+1, npatch_crop
if (wtxy(gi,m) > 0.) then
! Determine weight of crop pft/column relative to crop landunit
wtlunit = wtxy(gi,m) / wtcrop
! Increment number of columns on landunit
ci = ci + 1
cptr%npfts(ci) = 1
!
cptr%area(ci) = lptr%area(li) * wtlunit
cptr%landunit(ci) = li
cptr%gridcell(ci) = gi
cptr%wtlunit(ci) = wtlunit
cptr%wtgcell(ci) = cptr%area(ci) / gptr%area(gi)
!
!
! cptr%latdeg(ci) = latixy(i,j)
! cptr%londeg(ci) = longxy(i,j)
!
cptr%itype(ci) = 1
! Increment number of pfts on this landunit
! Set area, weight (relative to column) and type information for this pft
! For now, a single pft per column, so weight relative to column is 1
! pft type comes from the m dimension of wtxy()
! Set grid index, weight relative to grid cell and m index (needed for laixy, etc.)
pi = pi + 1
pptr%column(pi) = ci
pptr%landunit(pi) = li
pptr%gridcell(pi) = gi
!
pptr%wtcol(pi) = 1.0
pptr%wtlunit(pi) = cptr%wtlunit(ci)
pptr%area(pi) = cptr%area(ci)
pptr%wtgcell(pi) = pptr%area(pi) / gptr%area(gi)
!
pptr%mxy(pi) = m
!
! pptr%latdeg(pi) = latixy(i,j)
! pptr%londeg(pi) = longxy(i,j)
!
pptr%itype(pi) = vegxy(gi,m)
! Set pft indices for column
cptr%pfti(ci) = pi
cptr%pftf(ci) = pi
end if ! end if non-zero weight
end do ! end loop through the possible vegetated patch indices
end subroutine landunit_crop_noncompete
end module initGridcellsMod
module FracWetMod 2
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: FracWetMod
!
! !DESCRIPTION:
! Determine fraction of vegetated surfaces which are wet and
! fraction of elai which is dry.
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: FracWet
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: FracWet
!
! !INTERFACE:
subroutine FracWet(numf, filter) 2,2
!
! !DESCRIPTION:
! Determine fraction of vegetated surfaces which are wet and
! fraction of elai which is dry. The variable ``fwet'' is the
! fraction of all vegetation surfaces which are wet including
! stem area which contribute to evaporation. The variable ``fdry''
! is the fraction of elai which is dry because only leaves
! can transpire. Adjusted for stem area which does not transpire.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: numf ! number of filter non-lake points
integer, intent(in) :: filter(numf) ! pft filter for non-lake points
!
! !CALLED FROM:
! subroutine Hydrology1 in module Hydrology1Mod
!
! !REVISION HISTORY:
! Created by Keith Oleson and M. Vertenstein
! 03/08/29 Mariana Vertenstein : Migrated to vectorized code
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: frac_veg_nosno(:) ! fraction of veg not covered by snow (0/1 now) [-]
real(r8), pointer :: dewmx(:) ! Maximum allowed dew [mm]
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) ! one-sided stem area index with burying by snow
real(r8), pointer :: h2ocan(:) ! total canopy water (mm H2O)
!
! local pointers to implicit out arguments
!
real(r8), pointer :: fwet(:) ! fraction of canopy that is wet (0 to 1)
real(r8), pointer :: fdry(:) ! fraction of foliage that is green and dry [-] (new)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: fp,p ! indices
real(r8) :: vegt ! frac_veg_nosno*lsai
real(r8) :: dewmxi ! inverse of maximum allowed dew [1/mm]
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (pft-level)
frac_veg_nosno => clm3%g%l%c%p%pps%frac_veg_nosno
dewmx => clm3%g%l%c%p%pps%dewmx
elai => clm3%g%l%c%p%pps%elai
esai => clm3%g%l%c%p%pps%esai
h2ocan => clm3%g%l%c%p%pws%h2ocan
fwet => clm3%g%l%c%p%pps%fwet
fdry => clm3%g%l%c%p%pps%fdry
! Compute fraction of canopy that is wet and dry
!dir$ concurrent
!cdir nodep
do fp = 1,numf
p = filter(fp)
if (frac_veg_nosno(p) == 1) then
if (h2ocan(p) > 0._r8) then
vegt = frac_veg_nosno(p)*(elai(p) + esai(p))
dewmxi = 1.0_r8/dewmx(p)
fwet(p) = ((dewmxi/vegt)*h2ocan(p))**0.666666666666_r8
fwet(p) = min (fwet(p),1.0_r8) ! Check for maximum limit of fwet
else
fwet(p) = 0._r8
end if
fdry(p) = (1._r8-fwet(p))*elai(p)/(elai(p)+esai(p))
#if (defined PERGRO)
fwet(p) = 0._r8
fdry(p) = elai(p)/(elai(p)+esai(p))
#endif
else
fwet(p) = 0._r8
fdry(p) = 0._r8
end if
end do
end subroutine FracWet
end module FracWetMod
module FrictionVelocityMod 3,1
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: FrictionVelocityMod
!
! !DESCRIPTION:
! Calculation of the friction velocity, relation for potential
! temperature and humidity profiles of surface boundary layer.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: FrictionVelocity ! Calculate friction velocity
public :: MoninObukIni ! Initialization of the Monin-Obukhov length
!
! !PRIVATE MEMBER FUNCTIONS:
private :: StabilityFunc1 ! Stability function for rib < 0.
private :: StabilityFunc2 ! Stability function for rib < 0.
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------------
contains
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: FrictionVelocity
!
! !INTERFACE:
subroutine FrictionVelocity(lbn, ubn, fn, filtern, & 3,2
displa, z0m, z0h, z0q, &
obu, iter, ur, um, ustar, &
temp1, temp2, temp12m, temp22m, fm, landunit_index)
!
! !DESCRIPTION:
! Calculation of the friction velocity, relation for potential
! temperature and humidity profiles of surface boundary layer.
! The scheme is based on the work of Zeng et al. (1998):
! Intercomparison of bulk aerodynamic algorithms for the computation
! of sea surface fluxes using TOGA CORE and TAO data. J. Climate,
! Vol. 11, 2628-2644.
!
! !USES:
use clmtype
use clm_varcon, only : vkc
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbn, ubn ! pft/landunit array bounds
integer , intent(in) :: fn ! number of filtered pft/landunit elements
integer , intent(in) :: filtern(fn) ! pft/landunit filter
real(r8), intent(in) :: displa(lbn:ubn) ! displacement height (m)
real(r8), intent(in) :: z0m(lbn:ubn) ! roughness length over vegetation, momentum [m]
real(r8), intent(in) :: z0h(lbn:ubn) ! roughness length over vegetation, sensible heat [m]
real(r8), intent(in) :: z0q(lbn:ubn) ! roughness length over vegetation, latent heat [m]
real(r8), intent(in) :: obu(lbn:ubn) ! monin-obukhov length (m)
integer, intent(in) :: iter ! iteration number
real(r8), intent(in) :: ur(lbn:ubn) ! wind speed at reference height [m/s]
real(r8), intent(in) :: um(lbn:ubn) ! wind speed including the stablity effect [m/s]
logical, optional, intent(in) :: landunit_index ! optional argument that defines landunit or pft level
real(r8), intent(out) :: ustar(lbn:ubn) ! friction velocity [m/s]
real(r8), intent(out) :: temp1(lbn:ubn) ! relation for potential temperature profile
real(r8), intent(out) :: temp12m(lbn:ubn) ! relation for potential temperature profile applied at 2-m
real(r8), intent(out) :: temp2(lbn:ubn) ! relation for specific humidity profile
real(r8), intent(out) :: temp22m(lbn:ubn) ! relation for specific humidity profile applied at 2-m
real(r8), intent(inout) :: fm(lbn:ubn) ! diagnose 10m wind (DUST only)
!
! !CALLED FROM:
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 12/19/01, Peter Thornton
! Added arguments to eliminate passing clm derived type into this function.
! Created by Mariana Vertenstein
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: ngridcell(:) !pft/landunit gridcell index
real(r8), pointer :: forc_hgt_u_pft(:) !observational height of wind at pft level [m]
real(r8), pointer :: forc_hgt_t_pft(:) !observational height of temperature at pft level [m]
real(r8), pointer :: forc_hgt_q_pft(:) !observational height of specific humidity at pft level [m]
integer , pointer :: pfti(:) !beginning pfti index for landunit
integer , pointer :: pftf(:) !final pft index for landunit
!
! local pointers to implicit out arguments
!
real(r8), pointer :: u10(:) ! 10-m wind (m/s) (for dust model)
real(r8), pointer :: fv(:) ! friction velocity (m/s) (for dust model)
real(r8), pointer :: vds(:) ! dry deposition velocity term (m/s) (for SO4 NH4NO3)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
real(r8), parameter :: zetam = 1.574_r8 ! transition point of flux-gradient relation (wind profile)
real(r8), parameter :: zetat = 0.465_r8 ! transition point of flux-gradient relation (temp. profile)
integer :: f ! pft/landunit filter index
integer :: n ! pft/landunit index
integer :: g ! gridcell index
integer :: pp ! pfti,pftf index
real(r8):: zldis(lbn:ubn) ! reference height "minus" zero displacement heght [m]
real(r8):: zeta(lbn:ubn) ! dimensionless height used in Monin-Obukhov theory
#if (defined DUST)
real(r8) :: tmp1,tmp2,tmp3,tmp4 ! Used to diagnose the 10 meter wind
real(r8) :: fmnew ! Used to diagnose the 10 meter wind
real(r8) :: fm10 ! Used to diagnose the 10 meter wind
real(r8) :: zeta10 ! Used to diagnose the 10 meter wind
#endif
real(r8) :: vds_tmp ! Temporary for dry deposition velocity
!------------------------------------------------------------------------------
! Assign local pointers to derived type members (gridcell-level)
if (present(landunit_index)) then
ngridcell => clm3%g%l%gridcell
else
ngridcell => clm3%g%l%c%p%gridcell
end if
vds => clm3%g%l%c%p%pps%vds
u10 => clm3%g%l%c%p%pps%u10
fv => clm3%g%l%c%p%pps%fv
! Assign local pointers to derived type members (pft or landunit-level)
pfti => clm3%g%l%pfti
pftf => clm3%g%l%pftf
! Assign local pointers to derived type members (pft-level)
forc_hgt_u_pft => clm3%g%l%c%p%pps%forc_hgt_u_pft
forc_hgt_t_pft => clm3%g%l%c%p%pps%forc_hgt_t_pft
forc_hgt_q_pft => clm3%g%l%c%p%pps%forc_hgt_q_pft
! Adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions.
#if (!defined PERGRO)
!dir$ concurrent
!cdir nodep
do f = 1, fn
n = filtern(f)
g = ngridcell(n)
! Wind profile
if (present(landunit_index)) then
zldis(n) = forc_hgt_u_pft(pfti(n))-displa(n)
else
zldis(n) = forc_hgt_u_pft(n)-displa(n)
end if
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetam) then
ustar(n) = vkc*um(n)/(log(-zetam*obu(n)/z0m(n))&
- StabilityFunc1(-zetam) &
+ StabilityFunc1(z0m(n)/obu(n)) &
+ 1.14_r8*((-zeta(n))**0.333_r8-(zetam)**0.333_r8))
else if (zeta(n) < 0._r8) then
ustar(n) = vkc*um(n)/(log(zldis(n)/z0m(n))&
- StabilityFunc1(zeta(n))&
+ StabilityFunc1(z0m(n)/obu(n)))
else if (zeta(n) <= 1._r8) then
ustar(n) = vkc*um(n)/(log(zldis(n)/z0m(n)) + 5._r8*zeta(n) -5._r8*z0m(n)/obu(n))
else
ustar(n) = vkc*um(n)/(log(obu(n)/z0m(n))+5._r8-5._r8*z0m(n)/obu(n) &
+(5._r8*log(zeta(n))+zeta(n)-1._r8))
end if
if (zeta(n) < 0._r8) then
vds_tmp = 2.e-3_r8*ustar(n) * ( 1._r8 + (300._r8/(-obu(n)))**0.666_r8)
else
vds_tmp = 2.e-3_r8*ustar(n)
endif
if (present(landunit_index)) then
do pp = pfti(n),pftf(n)
vds(pp) = vds_tmp
end do
else
vds(n) = vds_tmp
end if
! Temperature profile
if (present(landunit_index)) then
zldis(n) = forc_hgt_t_pft(pfti(n))-displa(n)
else
zldis(n) = forc_hgt_t_pft(n)-displa(n)
end if
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetat) then
temp1(n) = vkc/(log(-zetat*obu(n)/z0h(n))&
- StabilityFunc2(-zetat) &
+ StabilityFunc2(z0h(n)/obu(n)) &
+ 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8)))
else if (zeta(n) < 0._r8) then
temp1(n) = vkc/(log(zldis(n)/z0h(n)) &
- StabilityFunc2(zeta(n)) &
+ StabilityFunc2(z0h(n)/obu(n)))
else if (zeta(n) <= 1._r8) then
temp1(n) = vkc/(log(zldis(n)/z0h(n)) + 5._r8*zeta(n) - 5._r8*z0h(n)/obu(n))
else
temp1(n) = vkc/(log(obu(n)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(n) &
+ (5._r8*log(zeta(n))+zeta(n)-1._r8))
end if
! Humidity profile
if (present(landunit_index)) then
if (forc_hgt_q_pft(pfti(n)) == forc_hgt_t_pft(pfti(n)) .and. z0q(n) == z0h(n)) then
temp2(n) = temp1(n)
else
zldis(n) = forc_hgt_q_pft(pfti(n))-displa(n)
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetat) then
temp2(n) = vkc/(log(-zetat*obu(n)/z0q(n)) &
- StabilityFunc2(-zetat) &
+ StabilityFunc2(z0q(n)/obu(n)) &
+ 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8)))
else if (zeta(n) < 0._r8) then
temp2(n) = vkc/(log(zldis(n)/z0q(n)) &
- StabilityFunc2(zeta(n)) &
+ StabilityFunc2(z0q(n)/obu(n)))
else if (zeta(n) <= 1._r8) then
temp2(n) = vkc/(log(zldis(n)/z0q(n)) + 5._r8*zeta(n)-5._r8*z0q(n)/obu(n))
else
temp2(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) &
+ (5._r8*log(zeta(n))+zeta(n)-1._r8))
end if
end if
else
if (forc_hgt_q_pft(n) == forc_hgt_t_pft(n) .and. z0q(n) == z0h(n)) then
temp2(n) = temp1(n)
else
zldis(n) = forc_hgt_q_pft(n)-displa(n)
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetat) then
temp2(n) = vkc/(log(-zetat*obu(n)/z0q(n)) &
- StabilityFunc2(-zetat) &
+ StabilityFunc2(z0q(n)/obu(n)) &
+ 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8)))
else if (zeta(n) < 0._r8) then
temp2(n) = vkc/(log(zldis(n)/z0q(n)) &
- StabilityFunc2(zeta(n)) &
+ StabilityFunc2(z0q(n)/obu(n)))
else if (zeta(n) <= 1._r8) then
temp2(n) = vkc/(log(zldis(n)/z0q(n)) + 5._r8*zeta(n)-5._r8*z0q(n)/obu(n))
else
temp2(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) &
+ (5._r8*log(zeta(n))+zeta(n)-1._r8))
end if
endif
endif
! Temperature profile applied at 2-m
zldis(n) = 2.0_r8 + z0h(n)
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetat) then
temp12m(n) = vkc/(log(-zetat*obu(n)/z0h(n))&
- StabilityFunc2(-zetat) &
+ StabilityFunc2(z0h(n)/obu(n)) &
+ 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8)))
else if (zeta(n) < 0._r8) then
temp12m(n) = vkc/(log(zldis(n)/z0h(n)) &
- StabilityFunc2(zeta(n)) &
+ StabilityFunc2(z0h(n)/obu(n)))
else if (zeta(n) <= 1._r8) then
temp12m(n) = vkc/(log(zldis(n)/z0h(n)) + 5._r8*zeta(n) - 5._r8*z0h(n)/obu(n))
else
temp12m(n) = vkc/(log(obu(n)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(n) &
+ (5._r8*log(zeta(n))+zeta(n)-1._r8))
end if
! Humidity profile applied at 2-m
if (z0q(n) == z0h(n)) then
temp22m(n) = temp12m(n)
else
zldis(n) = 2.0_r8 + z0q(n)
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetat) then
temp22m(n) = vkc/(log(-zetat*obu(n)/z0q(n)) - &
StabilityFunc2(-zetat) + StabilityFunc2(z0q(n)/obu(n)) &
+ 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(n))**(-0.333_r8)))
else if (zeta(n) < 0._r8) then
temp22m(n) = vkc/(log(zldis(n)/z0q(n)) - &
StabilityFunc2(zeta(n))+StabilityFunc2(z0q(n)/obu(n)))
else if (zeta(n) <= 1._r8) then
temp22m(n) = vkc/(log(zldis(n)/z0q(n)) + 5._r8*zeta(n)-5._r8*z0q(n)/obu(n))
else
temp22m(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) &
+ (5._r8*log(zeta(n))+zeta(n)-1._r8))
end if
end if
#if (defined DUST)
! diagnose 10-m wind for dust model (dstmbl.F)
! Notes from C. Zender's dst.F:
! According to Bon96 p. 62, the displacement height d (here displa) is
! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees).
! Therefore d <= 0.034*z1 and may safely be neglected.
! Code from LSM routine SurfaceTemperature was used to obtain u10
if (present(landunit_index)) then
zldis(n) = forc_hgt_u_pft(pfti(n))-displa(n)
else
zldis(n) = forc_hgt_u_pft(n)-displa(n)
end if
zeta(n) = zldis(n)/obu(n)
if (min(zeta(n), 1._r8) < 0._r8) then
tmp1 = (1._r8 - 16._r8*min(zeta(n),1._r8))**0.25_r8
tmp2 = log((1._r8+tmp1*tmp1)/2._r8)
tmp3 = log((1._r8+tmp1)/2._r8)
fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8
else
fmnew = -5._r8*min(zeta(n),1._r8)
endif
if (iter == 1) then
fm(n) = fmnew
else
fm(n) = 0.5_r8 * (fm(n)+fmnew)
end if
zeta10 = min(10._r8/obu(n), 1._r8)
if (zeta(n) == 0._r8) zeta10 = 0._r8
if (zeta10 < 0._r8) then
tmp1 = (1.0_r8 - 16.0_r8 * zeta10)**0.25_r8
tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8)
tmp3 = log((1.0_r8 + tmp1)/2.0_r8)
fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8
else ! not stable
fm10 = -5.0_r8 * zeta10
end if
if (present(landunit_index)) then
tmp4 = log( max( 1.0_8, forc_hgt_u_pft(pfti(n)) / 10._r8) )
else
tmp4 = log( max( 1.0_8, forc_hgt_u_pft(n) / 10._r8) )
end if
if (present(landunit_index)) then
do pp = pfti(n),pftf(n)
u10(pp) = ur(n) - ustar(n)/vkc * (tmp4 - fm(n) + fm10)
fv(pp) = ustar(n)
end do
else
u10(n) = ur(n) - ustar(n)/vkc * (tmp4 - fm(n) + fm10)
fv(n) = ustar(n)
end if
#endif
end do
#endif
#if (defined PERGRO)
!===============================================================================
! The following only applies when PERGRO is defined
!===============================================================================
!dir$ concurrent
!cdir nodep
do f = 1, fn
n = filtern(f)
g = ngridcell(n)
if (present(landunit_index)) then
zldis(n) = forc_hgt_u_pft(pfti(n))-displa(n)
else
zldis(n) = forc_hgt_u_pft(n)-displa(n)
end if
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetam) then ! zeta < -1
ustar(n) = vkc * um(n) / log(-zetam*obu(n)/z0m(n))
else if (zeta(n) < 0._r8) then ! -1 <= zeta < 0
ustar(n) = vkc * um(n) / log(zldis(n)/z0m(n))
else if (zeta(n) <= 1._r8) then ! 0 <= ztea <= 1
ustar(n)=vkc * um(n)/log(zldis(n)/z0m(n))
else ! 1 < zeta, phi=5+zeta
ustar(n)=vkc * um(n)/log(obu(n)/z0m(n))
endif
if (present(landunit_index)) then
zldis(n) = forc_hgt_t_pft(pfti(n))-displa(n)
else
zldis(n) = forc_hgt_t_pft(n)-displa(n)
end if
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetat) then
temp1(n)=vkc/log(-zetat*obu(n)/z0h(n))
else if (zeta(n) < 0._r8) then
temp1(n)=vkc/log(zldis(n)/z0h(n))
else if (zeta(n) <= 1._r8) then
temp1(n)=vkc/log(zldis(n)/z0h(n))
else
temp1(n)=vkc/log(obu(n)/z0h(n))
end if
if (present(landunit_index)) then
zldis(n) = forc_hgt_q_pft(pfti(n))-displa(n)
else
zldis(n) = forc_hgt_q_pft(n)-displa(n)
end if
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetat) then
temp2(n)=vkc/log(-zetat*obu(n)/z0q(n))
else if (zeta(n) < 0._r8) then
temp2(n)=vkc/log(zldis(n)/z0q(n))
else if (zeta(n) <= 1._r8) then
temp2(n)=vkc/log(zldis(n)/z0q(n))
else
temp2(n)=vkc/log(obu(n)/z0q(n))
end if
zldis(n) = 2.0_r8 + z0h(n)
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetat) then
temp12m(n)=vkc/log(-zetat*obu(n)/z0h(n))
else if (zeta(n) < 0._r8) then
temp12m(n)=vkc/log(zldis(n)/z0h(n))
else if (zeta(n) <= 1._r8) then
temp12m(n)=vkc/log(zldis(n)/z0h(n))
else
temp12m(n)=vkc/log(obu(n)/z0h(n))
end if
zldis(n) = 2.0_r8 + z0q(n)
zeta(n) = zldis(n)/obu(n)
if (zeta(n) < -zetat) then
temp22m(n)=vkc/log(-zetat*obu(n)/z0q(n))
else if (zeta(n) < 0._r8) then
temp22m(n)=vkc/log(zldis(n)/z0q(n))
else if (zeta(n) <= 1._r8) then
temp22m(n)=vkc/log(zldis(n)/z0q(n))
else
temp22m(n)=vkc/log(obu(n)/z0q(n))
end if
#if (defined DUST)
! diagnose 10-m wind for dust model (dstmbl.F)
! Notes from C. Zender's dst.F:
! According to Bon96 p. 62, the displacement height d (here displa) is
! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees).
! Therefore d <= 0.034*z1 and may safely be neglected.
! Code from LSM routine SurfaceTemperature was used to obtain u10
if (present(landunit_index)) then
zldis(n) = forc_hgt_u_pft(pfti(n))-displa(n)
else
zldis(n) = forc_hgt_u_pft(n)-displa(n)
end if
zeta(n) = zldis(n)/obu(n)
if (min(zeta(n), 1._r8) < 0._r8) then
tmp1 = (1._r8 - 16._r8*min(zeta(n),1._r8))**0.25_r8
tmp2 = log((1._r8+tmp1*tmp1)/2._r8)
tmp3 = log((1._r8+tmp1)/2._r8)
fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8
else
fmnew = -5._r8*min(zeta(n),1._r8)
endif
if (iter == 1) then
fm(n) = fmnew
else
fm(n) = 0.5_r8 * (fm(n)+fmnew)
end if
zeta10 = min(10._r8/obu(n), 1._r8)
if (zeta(n) == 0._r8) zeta10 = 0._r8
if (zeta10 < 0._r8) then
tmp1 = (1.0_r8 - 16.0 * zeta10)**0.25_r8
tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8)
tmp3 = log((1.0_r8 + tmp1)/2.0_r8)
fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8
else ! not stable
fm10 = -5.0_r8 * zeta10
end if
if (present(landunit_index)) then
tmp4 = log( max( 1.0_r8, forc_hgt_u_pft(pfti(n)) / 10._r8 ) )
else
tmp4 = log( max( 1.0_r8, forc_hgt_u_pft(n) / 10._r8 ) )
end if
if (present(landunit_index)) then
do pp = pfti(n),pftf(n)
u10(pp) = ur(n) - ustar(n)/vkc * (tmp4 - fm(n) + fm10)
fv(pp) = ustar(n)
end do
else
u10(n) = ur(n) - ustar(n)/vkc * (tmp4 - fm(n) + fm10)
fv(n) = ustar(n)
end if
#endif
end do
#endif
end subroutine FrictionVelocity
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: StabilityFunc
!
! !INTERFACE:
real(r8) function StabilityFunc1(zeta),1
!
! !DESCRIPTION:
! Stability function for rib < 0.
!
! !USES:
use shr_const_mod, only: SHR_CONST_PI
!
! !ARGUMENTS:
implicit none
real(r8), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory
!
! !CALLED FROM:
! subroutine FrictionVelocity in this module
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
!
!
! !LOCAL VARIABLES:
!EOP
real(r8) :: chik, chik2
!------------------------------------------------------------------------------
chik2 = sqrt(1._r8-16._r8*zeta)
chik = sqrt(chik2)
StabilityFunc1 = 2._r8*log((1._r8+chik)*0.5_r8) &
+ log((1._r8+chik2)*0.5_r8)-2._r8*atan(chik)+SHR_CONST_PI*0.5_r8
end function StabilityFunc1
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: StabilityFunc2
!
! !INTERFACE:
real(r8) function StabilityFunc2(zeta),1
!
! !DESCRIPTION:
! Stability function for rib < 0.
!
! !USES:
use shr_const_mod, only: SHR_CONST_PI
!
! !ARGUMENTS:
implicit none
real(r8), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory
!
! !CALLED FROM:
! subroutine FrictionVelocity in this module
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
!
!
! !LOCAL VARIABLES:
!EOP
real(r8) :: chik2
!------------------------------------------------------------------------------
chik2 = sqrt(1._r8-16._r8*zeta)
StabilityFunc2 = 2._r8*log((1._r8+chik2)*0.5_r8)
end function StabilityFunc2
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: MoninObukIni
!
! !INTERFACE:
subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu) 3,1
!
! !DESCRIPTION:
! Initialization of the Monin-Obukhov length.
! The scheme is based on the work of Zeng et al. (1998):
! Intercomparison of bulk aerodynamic algorithms for the computation
! of sea surface fluxes using TOGA CORE and TAO data. J. Climate,
! Vol. 11, 2628-2644.
!
! !USES:
use clm_varcon, only : grav
!
! !ARGUMENTS:
implicit none
real(r8), intent(in) :: ur ! wind speed at reference height [m/s]
real(r8), intent(in) :: thv ! virtual potential temperature (kelvin)
real(r8), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface
real(r8), intent(in) :: zldis ! reference height "minus" zero displacement heght [m]
real(r8), intent(in) :: z0m ! roughness length, momentum [m]
real(r8), intent(out) :: um ! wind speed including the stability effect [m/s]
real(r8), intent(out) :: obu ! monin-obukhov length (m)
!
! !CALLED FROM:
! subroutine BareGroundFluxes in module BareGroundFluxesMod.F90
! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod.F90
! subroutine CanopyFluxes in module CanopyFluxesMod.F90
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
!
!
! !LOCAL VARIABLES:
!EOP
!
real(r8) :: wc ! convective velocity [m/s]
real(r8) :: rib ! bulk Richardson number
real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory
real(r8) :: ustar ! friction velocity [m/s]
!-----------------------------------------------------------------------
! Initial values of u* and convective velocity
ustar=0.06_r8
wc=0.5_r8
if (dthv >= 0._r8) then
um=max(ur,0.1_r8)
else
um=sqrt(ur*ur+wc*wc)
endif
rib=grav*zldis*dthv/(thv*um*um)
#if (defined PERGRO)
rib = 0._r8
#endif
if (rib >= 0._r8) then ! neutral or stable
zeta = rib*log(zldis/z0m)/(1._r8-5._r8*min(rib,0.19_r8))
zeta = min(2._r8,max(zeta,0.01_r8 ))
else ! unstable
zeta=rib*log(zldis/z0m)
zeta = max(-100._r8,min(zeta,-0.01_r8 ))
endif
obu=zldis/zeta
end subroutine MoninObukIni
end module FrictionVelocityMod
module VOCEmissionMod 1,1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: VOCEmissionMod
!
! !DESCRIPTION:
! Volatile organic compound emission
!
! !USES:
use module_cam_support, only: endrun
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: VOCEmission
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: VOCEmission
!
! !INTERFACE:
subroutine VOCEmission (lbp, ubp, num_soilp, filter_soilp ) 1,10
!
! ! NEW DESCRIPTION
! Volatile organic compound emission
! This code simulates volatile organic compound emissions following:
! 1. Isoprene: Guenther et al., 2006 description of MEGAN emissions
! following equations 2-9, 16-17, 20
! 2. Monoterpenes/OVOCs/ORVOCs/CO: algorithm presented in Guenther, A.,
! 1999: Modeling Biogenic Volatile Organic Compound Emissions to the
! Atmosphere. In Reactive Hydrocarbons in the Atmosphere, Ch. 3
! With updates from MEGAN online user's guide
! ( http://acd.ucar.edu/~guenther/MEGAN/MEGANusersguide.pdf)
! This model relies on the assumption that 90% of isoprene and monoterpene
! emissions originate from canopy foliage:
! E= epsilon * gamma * rho
! VOC flux (E) [ugC m-2 h-1] is calculated from baseline emission
! factors (epsilon) [ugC m-2 h-1] which are mapped for each PFT (isoprene)
! or constant for each PFT (others). Note that for constant EFs the units
! of [ugC g-1 h-1] must be multiplied by the source density factor.
! The emission activity factor (gamma) [unitless] for isoprene includes
! dependence on PPFT, temperature, LAI, leaf age and soil moisture.
! The canopy environment constant was calculated offline for CLM+CAM at
! standard conditions.
! The emission activity factor for the other emissions depends on temperature.
! We assume that the escape efficiency (rho) here is unity following
! Guenther et al., 2006.
! Subroutine written to operate at the patch level.
! IN FINAL IMPLEMENTATION, REMEMBER:
! 1. may wish to call this routine only as freq. as rad. calculations
! 2. may wish to place epsilon values directly in pft-physiology file
! Output: vocflx(nvoc) !VOC flux [ug C m-2 h-1]
!
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use clm_varpar , only : nvoc, numpft
use shr_const_mod, only : SHR_CONST_RGAS
use clm_varcon , only : denice
use clm_varpar , only : nlevsoi
use pftvarcon , only : ndllf_evr_tmp_tree, ndllf_evr_brl_tree, &
ndllf_dcd_brl_tree, nbrdlf_evr_trp_tree, &
nbrdlf_evr_tmp_tree, nbrdlf_dcd_brl_shrub, &
nbrdlf_dcd_trp_tree, nbrdlf_dcd_tmp_tree, &
nbrdlf_dcd_brl_tree, nbrdlf_evr_shrub, &
nc3_arctic_grass, nc4_grass, noveg
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbp, ubp ! pft bounds
integer, intent(in) :: num_soilp ! number of columns in soil pft filter
integer, intent(in) :: filter_soilp(num_soilp) ! pft filter for soil
!
! !CALLED FROM:
!
! !REVISION HISTORY:
! Author: Sam Levis
! 2/1/02, Peter Thornton: migration to new data structure
! 4/15/06, Colette L. Heald: modify for updated MEGAN model (Guenther et al., 2006)
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: pgridcell(:) ! gridcell index of corresponding pft
integer , pointer :: pcolumn(:) ! column index of corresponding pft
integer , pointer :: ivt(:) ! pft vegetation type for current
real(r8), pointer :: t_veg(:) ! pft vegetation temperature (Kelvin)
real(r8), pointer :: fsun(:) ! sunlit fraction of canopy
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
real(r8), pointer :: clayfrac(:) ! fraction of soil that is clay
real(r8), pointer :: sandfrac(:) ! fraction of soil that is sand
real(r8), pointer :: forc_solad(:,:) ! direct beam radiation (visible only)
real(r8), pointer :: forc_solai(:,:) ! diffuse radiation (visible only)
real(r8), pointer :: sla(:) ! specific leaf area [m2 leaf g-1 C]
real(r8), pointer :: h2osoi_vol(:,:) ! volumetric soil water (m3/m3)
real(r8), pointer :: h2osoi_ice(:,:) ! ice soil content (kg/m3)
real(r8), pointer :: dz(:,:) ! depth of layer (m)
real(r8), pointer :: coszen(:) ! cosine of solar zenith angle
real(r8), pointer :: efisop(:,:) ! emission factors for isoprene for each pft [ug C m-2 h-1]
real(r8), pointer :: elai_p(:) ! one-sided leaf area index from previous timestep
real(r8), pointer :: t_veg24(:) ! avg pft vegetation temperature for last 24 hrs
real(r8), pointer :: t_veg240(:) ! avg pft vegetation temperature for last 240 hrs
real(r8), pointer :: fsun24(:) ! sunlit fraction of canopy last 24 hrs
real(r8), pointer :: fsun240(:) ! sunlit fraction of canopy last 240 hrs
real(r8), pointer :: forc_solad24(:) ! direct beam radiation last 24hrs (visible only)
real(r8), pointer :: forc_solai24(:) ! diffuse radiation last 24hrs (visible only)
real(r8), pointer :: forc_solad240(:) ! direct beam radiation last 240hrs (visible only)
real(r8), pointer :: forc_solai240(:) ! diffuse radiation last 240hrs (visible only)
real(r8), pointer :: bsw(:,:) ! Clapp and Hornberger "b" (nlevgrnd)
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity) (nlevgrnd)
real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm) (nlevgrnd)
real(r8), parameter :: smpmax = 2.57e5_r8 ! maximum soil matrix potential
!
! local pointers to original implicit out arrays
!
real(r8), pointer :: vocflx(:,:) ! VOC flux [ug C m-2 h-1]
real(r8), pointer :: vocflx_tot(:) ! VOC flux [ug C m-2 h-1]
real(r8), pointer :: vocflx_1(:) ! VOC flux(1) [ug C m-2 h-1]
real(r8), pointer :: vocflx_2(:) ! VOC flux(2) [ug C m-2 h-1]
real(r8), pointer :: vocflx_3(:) ! VOC flux(3) [ug C m-2 h-1]
real(r8), pointer :: vocflx_4(:) ! VOC flux(4) [ug C m-2 h-1]
real(r8), pointer :: vocflx_5(:) ! VOC flux(5) [ug C m-2 h-1]
real(r8), pointer :: Eopt_out(:)
real(r8), pointer :: topt_out(:)
real(r8), pointer :: alpha_out(:)
real(r8), pointer :: cp_out(:)
real(r8), pointer :: paru_out(:)
real(r8), pointer :: par24u_out(:)
real(r8), pointer :: par240u_out(:)
real(r8), pointer :: para_out(:)
real(r8), pointer :: par24a_out(:)
real(r8), pointer :: par240a_out(:)
real(r8), pointer :: gamma_out(:)
real(r8), pointer :: gammaT_out(:)
real(r8), pointer :: gammaP_out(:)
real(r8), pointer :: gammaL_out(:)
real(r8), pointer :: gammaA_out(:)
real(r8), pointer :: gammaS_out(:)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: fp,p,g,c,n,j ! indices
integer :: ct_bad
real(r8) :: epsilon(lbp:ubp) ! emission factor [ugC m-2 h-1]
real(r8) :: par ! temporary
real(r8) :: par24 ! temporary
real(r8) :: par240 ! temporary
real(r8) :: density ! source density factor [g dry wgt foliar mass/m2 ground]
real(r8) :: gamma(lbp:ubp) ! activity factor (accounting for light, T, age, LAI conditions)
real(r8) :: gamma_p ! activity factor for PPFD
real(r8) :: gamma_l ! activity factor for PPFD & LAI
real(r8) :: gamma_t ! activity factor for temperature
real(r8) :: gamma_a ! activity factor for leaf age
real(r8) :: gamma_sm ! activity factor for soil moisture
real(r8) :: x ! temporary
real(r8) :: Eopt ! temporary
real(r8) :: topt ! temporary
real(r8) :: cp ! temporary
real(r8) :: alpha ! temporary
real(r8) :: elai_prev ! lai for previous timestep
real(r8) :: fnew, fgro, fmat, fsen ! fractions of leaves at different phenological stages
real(r8) :: nl ! temporary number of soil levels
real(r8) :: theta_ice ! water content in ice in m3/m3
real(r8) :: wilt ! wilting point in m3/m3
real(r8) :: theta1 ! temporary
!
! Constants
!
real(r8), parameter :: R = SHR_CONST_RGAS*0.001_r8 ! univ. gas constant [J K-1 mol-1]
real(r8), parameter :: scale_mw =0.882_r8 ! conversion factor for isoprene -> carbon
real(r8), parameter :: alpha_fix = 0.001_r8 ! empirical coefficient
real(r8), parameter :: cp_fix = 1.21_r8 ! empirical coefficient
real(r8), parameter :: ct1 = 95.0_r8 ! empirical coefficient (70 in User's Guide)
real(r8), parameter :: ct2 = 230.0_r8 ! empirical coefficient (200 in User's Guide)
real(r8), parameter :: ct3 = 0.00831_r8 ! empirical coefficient (0.0083 in User's Guide)
real(r8), parameter :: topt_fix = 317._r8 ! std temperature [K]
real(r8), parameter :: Eopt_fix = 2.26_r8 ! empirical coefficient
real(r8), parameter :: tstd = 303.15_r8 ! std temperature [K]
real(r8), parameter :: bet = 0.09_r8 ! beta empirical coefficient [K-1]
real(r8), parameter :: clai1 = 0.49_r8 ! empirical coefficient
real(r8), parameter :: clai2 = 0.2_r8 ! empirical coefficient
real(r8), parameter :: clai3 = 5.0_r8 ! empirical coefficient
real(r8), parameter :: Anew = 0.01_r8 ! relative emission factor for new plants
real(r8), parameter :: Agro = 0.5_r8 ! relative emission factor for new plants
real(r8), parameter :: Amat = 1.0_r8 ! relative emission factor for new plants
real(r8), parameter :: Asen = 0.33_r8 ! relative emission factor for new plants
real(r8), parameter :: cce = 0.40_r8 ! factor to set emissions to unity @ std
real(r8), parameter :: cce1 = 0.47_r8 ! same as Cce but for non-accumulated vars
real(r8), parameter :: ca1 = 0.004_r8 ! empirical coefficent for alpha
real(r8), parameter :: ca2 = 0.0005_r8 ! empirical coefficent for alpha
real(r8), parameter :: ca3 = 0.0468_r8 ! empirical coefficent for cp
real(r8), parameter :: par0_sun = 200._r8 ! std conditions for past 24 hrs [umol/m2/s]
real(r8), parameter :: par0_shade = 50._r8 ! std conditions for past 24 hrs [umol/m2/s]
real(r8), parameter :: co1 = 313._r8 ! empirical coefficient
real(r8), parameter :: co2 = 0.6_r8 ! empirical coefficient
real(r8), parameter :: co3 = 2.034_r8 ! empirical coefficient
real(r8), parameter :: co4 = 0.05_r8 ! empirical coefficient
real(r8), parameter :: tstd0 = 297_r8 ! std temperature [K]
real(r8), parameter :: deltheta1=0.06_r8 ! empirical coefficient
!
! These are the values from version of genesis-ibis / 1000.
! CN calculates its own sla [m2 leaf g-1 C]
! Divide by 2 in the equation to get dry weight foliar mass from grams carbon
!
real(r8) :: hardwire_sla(0:numpft)
real(r8) :: slarea(lbp:ubp) ! Specific leaf areas [m2 leaf g-1 C]
real(r8) :: hardwire_droot(0:numpft) ! Root depth [m]
!-----------------------------------------------------------------------
! Assign local pointers to derived type members (gridcell-level)
forc_solad => clm_a2l%forc_solad
forc_solai => clm_a2l%forc_solai
efisop => clm3%g%gve%efisop
! Assign local pointers to derived subtypes components (column-level)
h2osoi_vol => clm3%g%l%c%cws%h2osoi_vol
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
dz => clm3%g%l%c%cps%dz
bsw => clm3%g%l%c%cps%bsw
watsat => clm3%g%l%c%cps%watsat
sucsat => clm3%g%l%c%cps%sucsat
! Assign local pointers to derived subtypes components (pft-level)
pgridcell => clm3%g%l%c%p%gridcell
pcolumn => clm3%g%l%c%p%column
ivt => clm3%g%l%c%p%itype
t_veg => clm3%g%l%c%p%pes%t_veg
fsun => clm3%g%l%c%p%pps%fsun
elai => clm3%g%l%c%p%pps%elai
clayfrac => clm3%g%l%c%p%pps%clayfrac
sandfrac => clm3%g%l%c%p%pps%sandfrac
vocflx => clm3%g%l%c%p%pvf%vocflx
vocflx_tot => clm3%g%l%c%p%pvf%vocflx_tot
vocflx_1 => clm3%g%l%c%p%pvf%vocflx_1
vocflx_2 => clm3%g%l%c%p%pvf%vocflx_2
vocflx_3 => clm3%g%l%c%p%pvf%vocflx_3
vocflx_4 => clm3%g%l%c%p%pvf%vocflx_4
vocflx_5 => clm3%g%l%c%p%pvf%vocflx_5
Eopt_out => clm3%g%l%c%p%pvf%Eopt_out
topt_out => clm3%g%l%c%p%pvf%topt_out
alpha_out => clm3%g%l%c%p%pvf%alpha_out
cp_out => clm3%g%l%c%p%pvf%cp_out
paru_out => clm3%g%l%c%p%pvf%paru_out
par24u_out => clm3%g%l%c%p%pvf%par24u_out
par240u_out => clm3%g%l%c%p%pvf%par240u_out
para_out => clm3%g%l%c%p%pvf%para_out
par24a_out => clm3%g%l%c%p%pvf%par24a_out
par240a_out => clm3%g%l%c%p%pvf%par240a_out
gammaL_out => clm3%g%l%c%p%pvf%gammaL_out
gammaT_out => clm3%g%l%c%p%pvf%gammaT_out
gammaP_out => clm3%g%l%c%p%pvf%gammaP_out
gammaA_out => clm3%g%l%c%p%pvf%gammaA_out
gammaS_out => clm3%g%l%c%p%pvf%gammaS_out
gamma_out => clm3%g%l%c%p%pvf%gamma_out
sla => clm3%g%l%c%p%pps%slasha
t_veg24 => clm3%g%l%c%p%pvs%t_veg24
t_veg240 => clm3%g%l%c%p%pvs%t_veg240
forc_solad24 => clm3%g%l%c%p%pvs%fsd24
forc_solad240 => clm3%g%l%c%p%pvs%fsd240
forc_solai24 => clm3%g%l%c%p%pvs%fsi24
forc_solai240 => clm3%g%l%c%p%pvs%fsi240
fsun24 => clm3%g%l%c%p%pvs%fsun24
fsun240 => clm3%g%l%c%p%pvs%fsun240
elai_p => clm3%g%l%c%p%pvs%elai_p
hardwire_sla(noveg) = 0._r8 ! bare-soil
hardwire_sla(ndllf_evr_tmp_tree) = 0.0125_r8 !needleleaf
hardwire_sla(ndllf_evr_brl_tree) = 0.0125_r8 !Gordon Bonan suggests NET = 0.0076
hardwire_sla(ndllf_dcd_brl_tree) = 0.0125_r8 !Gordon Bonan suggests NDT = 0.0200
hardwire_sla(nbrdlf_evr_trp_tree) = 0.0250_r8 !broadleaf
hardwire_sla(nbrdlf_evr_tmp_tree) = 0.0250_r8 !Gordon Bonan suggests BET = 0.0178
hardwire_sla(nbrdlf_dcd_trp_tree) = 0.0250_r8 !Gordon Bonan suggests BDT = 0.0274
hardwire_sla(nbrdlf_dcd_tmp_tree:nbrdlf_dcd_brl_shrub) = 0.0250_r8
hardwire_sla(nc3_arctic_grass:numpft) = 0.0200_r8 !grass/crop
! root depth (m) (defined based on Zeng et al., 2001, cf Guenther 2006)
hardwire_droot(noveg) = 0._r8 ! bare-soil
hardwire_droot(ndllf_evr_tmp_tree:ndllf_evr_brl_tree) = 1.8_r8 ! evergreen tree
hardwire_droot(ndllf_dcd_brl_tree) = 2.0_r8 ! needleleaf deciduous boreal tree
hardwire_droot(nbrdlf_evr_trp_tree:nbrdlf_evr_tmp_tree) = 3.0_r8 ! broadleaf evergreen tree
hardwire_droot(nbrdlf_dcd_trp_tree:nbrdlf_dcd_brl_tree) = 2.0_r8 ! broadleaf deciduous tree
hardwire_droot(nbrdlf_evr_shrub:nbrdlf_dcd_brl_shrub) = 2.5_r8 ! shrub
hardwire_droot(nc3_arctic_grass:numpft) = 1.5_r8 ! grass/crop
! initialize variables which get passed to the atmosphere
vocflx(lbp:ubp, :)=0._r8
! Determine specific leaf array
do fp = 1,num_soilp
p = filter_soilp(fp)
slarea(p) = hardwire_sla(ivt(p))
end do
! Begin loop through voc species
!_______________________________________________________________________________
do n = 1, nvoc
select case (n)
case(1)
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
! epsilon: use gridded values for 6 PFTs specified by MEGAN following
! ------- Guenther et al. (2006). Map the numpft CLM PFTs to these 6.
! Units: [ug C m-2 h-1] (convert input files from units of
! [ug isop m-2 h-1])
epsilon(p) = 0._r8
! isoprenes:
if ( ivt(p) == ndllf_evr_tmp_tree &
.or. ivt(p) == ndllf_evr_brl_tree) then !fineleaf evergreen
epsilon(p) = efisop(2,g)*scale_mw
else if (ivt(p) == ndllf_dcd_brl_tree) then !fineleaf deciduous
epsilon(p) = efisop(3,g)*scale_mw
else if (ivt(p) >= nbrdlf_evr_trp_tree &
.and. ivt(p) <= nbrdlf_dcd_brl_tree) then !broadleaf trees
epsilon(p) = efisop(1,g)*scale_mw
else if (ivt(p) >= nbrdlf_evr_shrub &
.and. ivt(p) <= nbrdlf_dcd_brl_shrub) then !shrubs
epsilon(p) = efisop(4,g)*scale_mw
else if (ivt(p) >= nc3_arctic_grass &
.and. ivt(p) <= nc4_grass) then !grass
epsilon(p) = efisop(5,g)*scale_mw
else if (ivt(p) > nc4_grass) then !crops
epsilon(p) =efisop(6,g)*scale_mw
end if
end do
case(2)
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
! epsilon: use values from table 3 in Guenther (1997) which originate in
! ------- Guenther et al. (1995). In the comments below, I mention the pft
! category as described in table 3. Some values were taken directly
! from Guenther et al. (1995). Units: [ugC g-1 h-1]
! Values were updated on 1/2002 (Guenther, personal communication)
! monoterpenes:
epsilon(p) = 0._r8
! monoterpenes:
if ( ivt(p) >= ndllf_evr_tmp_tree &
.and. ivt(p) <= ndllf_evr_brl_tree) then !needleleaf evergreen
epsilon(p) = 2.0_r8
else if (ivt(p) == ndllf_dcd_brl_tree) then !needleleaf deciduous
epsilon(p) = 1.6_r8
else if (ivt(p) >= nbrdlf_evr_trp_tree &
.and. ivt(p) <= nbrdlf_dcd_brl_tree) then !broadleaf everg trop
epsilon(p) = 0.4_r8
else if (ivt(p) >= nbrdlf_evr_shrub &
.and. ivt(p) <= nbrdlf_dcd_brl_shrub) then !other woody veg
epsilon(p) = 0.8_r8
else if (ivt(p) >= nc3_arctic_grass &
.and. ivt(p) <= numpft) then !grass & crop
epsilon(p) = 0.1_r8
end if
end do
case (3)
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
! other VOCs (OVOCs)
epsilon(p) = 1.0_r8 !Guenther (personal communication)
end do
case (4)
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
! other reactive VOCs (ORVOCs)
epsilon(p) = 1.0_r8 !Guenther (personal communication)
end do
case (5)
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
! CO
epsilon(p) = 0.3_r8 !Guenther (personal communication)
end do
case default
write(6,*)'only nvocs up to index 5 are currently supported'
call endrun()
end select
ct_bad=0
select case (n)
case (1)
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
c = pcolumn(p)
! gamma: Activity factor. Units [dimensionless]
! ===== For isoprene include activity factors for LAI,PPFD, T, leaf age, and soil moisture
! Activity factor for LAI (Guenther et al., 2006)
!------------------------
! Guenther et al., 2006 eq 3
if ( (fsun240(p) > 0.0_r8) .and. (fsun240(p) < 1.e30_r8) ) then
gamma_l = cce * elai(p)
else
gamma_l = cce1 * elai(p)
end if
gammaL_out(p)=gamma_l
! Activity factor for PPFD (Guenther et al., 2006)
!-------------------------
! With distinction between sunlit and shaded leafs, weight scalings by
! fsun and fshade
! Scale total incident par by fraction of sunlit leaves (added on 1/2002)
! multiply w/m2 by 4.6 to get umol/m2/s for par (added 8/14/02)
! fvitt -- forc_solad240, forc_solai240 can be zero when CLM finidat is specified
! which will cause par240 to be zero and produce NaNs via log(par240)
! dml -- fsun240 can be equal to or greater than one before 10 day averages are
! set on startup or if a new pft comes online during land cover change.
! Avoid this problem by only doing calculations with fsun240 when fsun240 is
! between 0 and 1
if ( (fsun240(p) > 0._r8) .and. (fsun240(p) < 1._r8) .and. (forc_solad240(p) > 0._r8) &
.and. (forc_solai240(p) > 0._r8)) then
! With alpha and cp calculated based on eq 6 and 7:
! Note indexing for accumulated variables is all at pft level
! SUN:
par = (forc_solad(g,1) + fsun(p) * forc_solai(g,1)) * 4.6_r8
par24 = (forc_solad24(p) + fsun24(p) * forc_solai24(p)) * 4.6_r8
par240 = (forc_solad240(p) + fsun240(p) * forc_solai240(p)) * 4.6_r8
alpha = ca1 - ca2 * log(par240)
cp = ca3 * exp(ca2 * (par24-par0_sun))*par240**(0.6_r8)
gamma_p = fsun(p) * ( cp * alpha*par * (1._r8 + alpha*alpha*par*par)**(-0.5_r8) )
paru_out(p)=par
par24u_out(p)=par24
par240u_out(p)=par240
! SHADE:
par = ((1._r8 - fsun(p)) * forc_solai(g,1)) * 4.6_r8
par24 = ((1._r8 - fsun24(p)) * forc_solai24(p)) * 4.6_r8
par240 = ((1._r8 - fsun240(p)) * forc_solai240(p)) * 4.6_r8
alpha = ca1 - ca2 * log(par240)
cp = ca3 * exp(ca2 * (par24-par0_shade))*par240**(0.6_r8)
par = ((1._r8 - fsun(p)) * forc_solai(g,1)) * 4.6_r8
gamma_p = gamma_p + (1-fsun(p)) * (cp*alpha*par*(1._r8 + alpha*alpha*par*par)**(-0.5_r8))
para_out(p)=par
par24a_out(p)=par24
par240a_out(p)=par240
else
! With fixed alpha and cp (from MEGAN User's Guide):
! SUN: direct + diffuse
par = (forc_solad(g,1) + fsun(p) * forc_solai(g,1)) * 4.6_r8
alpha = alpha_fix
cp = cp_fix
gamma_p = fsun(p) * ( cp * alpha*par * (1._r8 + alpha*alpha*par*par)**(-0.5_r8) )
paru_out(p)=par
par24u_out(p)=-999
par240u_out(p)=-999
! SHADE: diffuse
par = ((1._r8 - fsun(p)) * forc_solai(g,1)) * 4.6_r8
gamma_p = gamma_p + (1-fsun(p)) * (cp*alpha*par*(1._r8 + alpha*alpha*par*par)**(-0.5_r8))
para_out(p)=par
par24a_out(p)=-999
par240a_out(p)=-999
end if
alpha_out(p)=alpha
cp_out(p)=cp
gammaP_out(p)=gamma_p
! Activity factor for temperature (Guenther et al., 2006)
!--------------------------------
if ( (t_veg240(p) > 0.0_r8) .and. (t_veg240(p) < 1.e30_r8) ) then
! topt and Eopt from eq 8 and 9:
topt = co1 + (co2 * (t_veg240(p)-tstd0))
Eopt = co3 * exp (co4 * (t_veg24(p)-tstd0)) * exp(co4 * (t_veg240(p) -tstd0))
else
topt = topt_fix
Eopt = Eopt_fix
endif
x = ( (1._r8/topt) - (1._r8/(t_veg(p))) ) / ct3
gamma_t = Eopt * ( ct2 * exp(ct1 * x)/(ct2 - ct1 * (1._r8 - exp(ct2 * x))) )
topt_out(p)=topt
Eopt_out(p)=Eopt
gammaT_out(p)=gamma_t
! Activity factor for leaf age (Guenther et al., 2006)
!-----------------------------
! If not CNDV elai is constant therefore gamma_a=1.0
! gamma_a set to unity for evergreens (PFTs 1, 2, 4, 5)
! Note that we assume here that the time step is shorter than the number of
!days after budbreak required to induce isoprene emissions (ti=12 days) and
! the number of days after budbreak to reach peak emission (tm=28 days)
if ( (ivt(p) == ndllf_dcd_brl_tree) .or. (ivt(p) >= nbrdlf_dcd_trp_tree) ) then ! non-evergreen
if ( (elai_p(p) > 0.0_r8) .and. (elai_p(p) < 1.e30_r8) )then
elai_prev = 2._r8*elai_p(p)-elai(p) ! have accumulated average lai over last timestep
if (elai_prev == elai(p)) then
fnew = 0.0_r8
fgro = 0.0_r8
fmat = 1.0_r8
fsen = 0.0_r8
else if (elai_prev > elai(p)) then
fnew = 0.0_r8
fgro = 0.0_r8
fmat = 1.0_r8 - (elai_prev - elai(p))/elai_prev
fsen = (elai_prev - elai(p))/elai_prev
else if (elai_prev < elai(p)) then
fnew = 1 - (elai_prev / elai(p))
fgro = 0.0_r8
fmat = (elai_prev / elai(p))
fsen = 0.0_r8
end if
gamma_a = fnew * Anew + fgro * Agro + fmat * Amat + fsen * Asen
else
gamma_a = 1.0_r8
end if
else
gamma_a = 1.0_r8
end if
gammaA_out(p)=gamma_a
! Activity factor for soil moisture (Guenther et al., 2006)
!----------------------------------
! Calculate the mean scaling factor throughout the root depth.
! wilting point potential is in units of matric potential (mm)
! (1 J/Kg = 0.001 MPa, approx = 0.1 m)
! convert to volumetric soil water using equation 7.118 of the CLM4 Technical Note
if ((clayfrac(p) > 0) .and. (sandfrac(p) > 0)) then
gamma_sm = 0._r8
nl=0._r8
do j = 1,nlevsoi
if (sum(dz(c,1:j)) < hardwire_droot(ivt(p))) then
theta_ice = h2osoi_ice(c,j)/(dz(c,j)*denice)
wilt = ((smpmax/sucsat(c,j))**(-1._r8/bsw(c,j))) * (watsat(c,j) - theta_ice)
theta1 = wilt + deltheta1
if (h2osoi_vol(c,j) >= theta1) then
gamma_sm = gamma_sm + 1._r8
else if ( (h2osoi_vol(c,j) > wilt) .and. (h2osoi_vol(c,j) < theta1) ) then
gamma_sm = gamma_sm + ( h2osoi_vol(c,j) - wilt ) / deltheta1
else
gamma_sm = gamma_sm + 0._r8
end if
nl=nl+1._r8
end if
end do
if (nl > 0) then
gamma_sm = gamma_sm/nl
endif
else
gamma_sm = 1.0_r8
end if
gammaS_out(p)=gamma_sm
! Calculate total scaling factor
!--------------------------------
gamma(p) = gamma_l * gamma_p * gamma_t * gamma_a * gamma_sm
if ( (gamma(p) >=0.0_r8) .and. (gamma(p)< 100._r8) ) then
gamma_out(p)=gamma(p)
else
gamma_out(p)=gamma(p)
write(6,*) 'clh GAMMA: ',gamma(p),gamma_l,gamma_p,gamma_t,gamma_a,gamma_sm
end if
end do
case (2,3,4,5)
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
! gamma: Activity factor. Units [dimensionless]
! ----- For monoterpenes, OVOCs, ORVOCs, CO include simple activity factors
! for LAI and T only (Guenther et al., 1995)
gamma_t = exp(bet * (t_veg(p) - tstd))
gamma(p)=gamma_t
end do
end select
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
! density: Source density factor [g dry weight foliar mass m-2 ground]
! ------- Other than isoprene, need to convert EF units from
! [ug g-1 h-1] to [ug m-2 h-1]
if (ivt(p) > noveg) then
density = elai(p) / (slarea(p) * 0.5_r8)
else
density = 0._r8
end if
! calculate the voc flux
! ----------------------
select case (n)
case(1)
vocflx(p,n) = epsilon(p) * gamma(p)
case(2,3,4,5)
vocflx(p,n) = epsilon(p) * gamma(p) * density
end select
end do ! end pft loop
end do ! end voc species loop
!_______________________________________________________________________________
! Calculate total voc flux and individual components for history output
do fp = 1,num_soilp
p = filter_soilp(fp)
vocflx_tot(p) = 0._r8
end do
do n = 1, nvoc
do fp = 1,num_soilp
p = filter_soilp(fp)
vocflx_tot(p) = vocflx_tot(p) + vocflx(p,n)
end do
end do
do fp = 1,num_soilp
p = filter_soilp(fp)
g = pgridcell(p)
vocflx_1(p) = vocflx(p,1)
vocflx_2(p) = vocflx(p,2)
vocflx_3(p) = vocflx(p,3)
vocflx_4(p) = vocflx(p,4)
vocflx_5(p) = vocflx(p,5)
end do
end subroutine VOCEmission
end module VOCEmissionMod
module dynlandMod 1,3
!---------------------------------------------------------------------------
!BOP
!
! !MODULE: dynlandMod
!
! !USES:
use clmtype
use decompMod , only : get_proc_bounds
use shr_kind_mod, only : r8 => shr_kind_r8
!
! !DESCRIPTION:
! Compute heat and water content to track conservation wrt dynamic land use
!
! !PUBLIC TYPES:
implicit none
private
save
public :: dynland_hwcontent
!
! !REVISION HISTORY:
! 2009-feb-20 B. Kauffman, created by
!
!EOP
!
! ! PRIVATE TYPES
!===============================================================================
contains
!===============================================================================
!BOP
!
! !ROUTINE: dynland_hwcontent
!
! !INTERFACE:
subroutine dynland_hwcontent(begg,endg,gcell_liq,gcell_ice,gcell_heat) 1,6
! !DESCRIPTION:
! Compute grid-level heat and water content
!
! !REVISION HISTORY:
! 2009-feb-20 B. Kauffman, created by
!
! !USES:
use clm_varcon, only : istsoil,istice,istwet, istdlak,istslak,isturb
#ifdef CROP
use clm_varcon, only : istcrop
#endif
use clm_varcon, only : icol_road_perv,icol_road_imperv,icol_roof
use clm_varcon, only : icol_sunwall,icol_shadewall
use clm_varcon, only : cpice, cpliq
use clm_varpar, only : nlevsno, nlevgrnd
implicit none
! !ARGUMENTS:
integer , intent(in) :: begg, endg ! proc beg & end gridcell indices
real(r8), intent(out) :: gcell_liq(begg:endg)
real(r8), intent(out) :: gcell_ice (begg:endg)
real(r8), intent(out) :: gcell_heat (begg:endg)
! !LOCAL VARIABLES:
!EOP
integer :: li,lf ! loop initial/final indicies
integer :: ci,cf ! loop initial/final indicies
integer :: pi,pf ! loop initial/final indicies
integer :: g,l,c,p,k ! loop indicies (grid,lunit,column,pft,vertical level)
real(r8) :: wtgcell ! weight relative to grid cell
real(r8) :: wtcol ! weight relative to column
real(r8) :: liq ! sum of liquid water at column level
real(r8) :: ice ! sum of frozen water at column level
real(r8) :: heat ! sum of heat content at column level
real(r8) :: cv ! heat capacity [J/(m^2 K)]
integer ,pointer :: ltype(:) ! landunit type index
integer ,pointer :: ctype(:) ! column type index
integer ,pointer :: ptype(:) ! pft type index
integer, pointer :: nlev_improad(:) ! number of impervious road layers
real(r8), pointer :: cv_wall(:,:) ! thermal conductivity of urban wall
real(r8), pointer :: cv_roof(:,:) ! thermal conductivity of urban roof
real(r8), pointer :: cv_improad(:,:) ! thermal conductivity of urban impervious road
integer , pointer :: snl(:) ! number of snow layers
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin)
real(r8), pointer :: h2osno(:) ! snow water (mm H2O)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
real(r8), pointer :: h2osoi_ice(:,:) ! frozen water (kg/m2)
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity)
real(r8), pointer :: csol(:,:) ! heat capacity, soil solids (J/m**3/Kelvin)
real(r8), pointer :: dz(:,:) ! layer depth (m)
real(r8), pointer :: wa(:,:) ! h2o in underground aquifer
type(gridcell_type), pointer :: gptr ! pointer to gridcell derived subtype
type(landunit_type), pointer :: lptr ! pointer to landunit derived subtype
type(column_type) , pointer :: cptr ! pointer to column derived subtype
type(pft_type) , pointer :: pptr ! pointer to pft derived subtype
!-------------------------------------------------------------------------------
! Note: this routine does not compute heat or water content of lakes.
!
!-------------------------------------------------------------------------------
! Set pointers into derived type
gptr => clm3%g
lptr => clm3%g%l
cptr => clm3%g%l%c
pptr => clm3%g%l%c%p
ltype => clm3%g%l%itype
ctype => clm3%g%l%c%itype
ptype => clm3%g%l%c%p%itype
nlev_improad => clm3%g%l%lps%nlev_improad
cv_wall => clm3%g%l%lps%cv_wall
cv_roof => clm3%g%l%lps%cv_roof
cv_improad => clm3%g%l%lps%cv_improad
snl => clm3%g%l%c%cps%snl
watsat => clm3%g%l%c%cps%watsat
csol => clm3%g%l%c%cps%csol
dz => clm3%g%l%c%cps%dz
t_soisno => clm3%g%l%c%ces%t_soisno
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osno => clm3%g%l%c%cws%h2osno
! Get relevant sizes
do g = begg,endg ! loop over grid cells
gcell_liq (g) = 0.0_r8 ! sum for one grid cell
gcell_ice (g) = 0.0_r8 ! sum for one grid cell
gcell_heat (g) = 0.0_r8 ! sum for one grid cell
li = gptr%luni(g)
lf = gptr%lunf(g)
do l = li,lf ! loop over land units
ci = lptr%coli(l)
cf = lptr%colf(l)
do c = ci,cf ! loop over columns
liq = 0.0_r8 ! sum for one column
ice = 0.0_r8
heat = 0.0_r8
!--- water & ice, above ground only ---
#ifndef CROP
if ( (ltype(l) == istsoil ) &
#else
if ( (ltype(l) == istsoil .or. ltype(l) == istcrop ) &
#endif
.or. (ltype(l) == istwet ) &
.or. (ltype(l) == istice ) &
.or. (ltype(l) == isturb .and. ctype(c) == icol_roof ) &
.or. (ltype(l) == isturb .and. ctype(c) == icol_road_imperv) &
.or. (ltype(l) == isturb .and. ctype(c) == icol_road_perv )) then
if ( snl(c) < 0 ) then
do k = snl(c)+1,0 ! loop over snow layers
liq = liq + clm3%g%l%c%cws%h2osoi_liq(c,k)
ice = ice + clm3%g%l%c%cws%h2osoi_ice(c,k)
end do
else ! no snow layers exist
ice = ice + cptr%cws%h2osno(c)
end if
end if
!--- water & ice, below ground only ---
#ifndef CROP
if ( (ltype(l) == istsoil ) &
#else
if ( (ltype(l) == istsoil .or. ltype(l) == istcrop ) &
#endif
.or. (ltype(l) == istwet ) &
.or. (ltype(l) == istice ) &
.or. (ltype(l) == isturb .and. ctype(c) == icol_road_perv )) then
do k = 1,nlevgrnd
liq = liq + cptr%cws%h2osoi_liq(c,k)
ice = ice + cptr%cws%h2osoi_ice(c,k)
end do
end if
!--- water in aquifer ---
#ifndef CROP
if ( (ltype(l) == istsoil ) &
#else
if ( (ltype(l) == istsoil .or. ltype(l) == istcrop ) &
#endif
.or. (ltype(l) == istwet ) &
.or. (ltype(l) == istice ) &
.or. (ltype(l) == isturb .and. ctype(c) == icol_road_perv )) then
liq = liq + cptr%cws%wa(c)
end if
!--- water in canopy (at pft level) ---
#ifndef CROP
if (ltype(l) == istsoil ) then
#else
if (ltype(l) == istsoil .or. ltype(l) == istcrop) then ! note: soil specified at LU level
#endif
pi = cptr%pfti(c)
pf = cptr%pftf(c)
do p = pi,pf ! loop over pfts
wtcol = pptr%wtcol(p)
liq = liq + pptr%pws%h2ocan(p) * wtcol
end do
end if
if ( (ltype(l) /= istslak) .and. ltype(l) /= istdlak) then
!--- heat content, below ground only ---
do k = 1,nlevgrnd
if (ctype(c)==icol_sunwall .OR. ctype(c)==icol_shadewall) then
cv = cv_wall(l,k) * dz(c,k)
else if (ctype(c) == icol_roof) then
cv = cv_roof(l,k) * dz(c,k)
else if (ctype(c) == icol_road_imperv .and. k >= 1 .and. k <= nlev_improad(l)) then
cv = cv_improad(l,k) * dz(c,k)
else if (ltype(l) /= istwet .AND. ltype(l) /= istice) then
cv = csol(c,k)*(1-watsat(c,k))*dz(c,k) + (h2osoi_ice(c,k)*cpice + h2osoi_liq(c,k)*cpliq)
else
cv = (h2osoi_ice(c,k)*cpice + h2osoi_liq(c,k)*cpliq)
endif
heat = heat + cv*t_soisno(c,k) / 1.e6_r8
end do
!--- heat content, above ground only ---
if ( snl(c) < 0 ) then
do k = snl(c)+1,0 ! loop over snow layers
cv = cpliq*h2osoi_liq(c,k) + cpice*h2osoi_ice(c,k)
heat = heat + cv*t_soisno(c,k) / 1.e6_r8
end do
else if ( h2osno(c) > 0.0_r8) then
k = 1
cv = cpice*h2osno(c)
heat = heat + cv*t_soisno(c,k) / 1.e6_r8
end if
end if
!--- scale x/m^2 column-level values into x/m^2 gridcell-level values ---
wtgcell = cptr%wtgcell(c)
gcell_liq (g) = gcell_liq (g) + liq * wtgcell
gcell_ice (g) = gcell_ice (g) + ice * wtgcell
gcell_heat (g) = gcell_heat (g) + heat * wtgcell
end do ! column loop
end do ! landunit loop
end do ! grid cell loop
end subroutine dynland_hwcontent
!===============================================================================
end module dynlandMod
module subgridAveMod 8,18
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: subgridAveMod
!
! !DESCRIPTION:
! Utilities to perfrom subgrid averaging
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype , only : clm3
use clm_varcon, only : spval, isturb, icol_roof, icol_sunwall, icol_shadewall, &
icol_road_perv, icol_road_imperv
use module_cam_support, only: endrun
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: p2c ! Perfrom an average from pfts to columns
public :: p2l ! Perfrom an average from pfts to landunits
public :: p2g ! Perfrom an average from pfts to gridcells
public :: c2l ! Perfrom an average from columns to landunits
public :: c2g ! Perfrom an average from columns to gridcells
public :: l2g ! Perfrom an average from landunits to gridcells
interface p2c 36,2
module procedure p2c_1d
module procedure p2c_2d
module procedure p2c_1d_filter
module procedure p2c_2d_filter
end interface
interface p2l
module procedure p2l_1d
module procedure p2l_2d
end interface
interface p2g 1
module procedure p2g_1d
module procedure p2g_2d
end interface
interface c2l
module procedure c2l_1d
module procedure c2l_2d
end interface
interface c2g 2
module procedure c2g_1d
module procedure c2g_2d
end interface
interface l2g
module procedure l2g_1d
module procedure l2g_2d
end interface
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: p2c_1d
!
! !INTERFACE:
subroutine p2c_1d (lbp, ubp, lbc, ubc, parr, carr, p2c_scale_type) 1,3
!
! !DESCRIPTION:
! Perfrom subgrid-average from pfts to columns.
! Averaging is only done for points that are not equal to "spval".
!
! !USES:
use clm_varpar, only : max_pft_per_col
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbp, ubp ! beginning and ending pft
integer , intent(in) :: lbc, ubc ! beginning and ending column
real(r8), intent(in) :: parr(lbp:ubp) ! pft array
real(r8), intent(out) :: carr(lbc:ubc) ! column array
character(len=*), intent(in) :: p2c_scale_type ! scale type
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: pi,p,c,index ! indices
real(r8) :: scale_p2c(lbp:ubp) ! scale factor for column->landunit mapping
logical :: found ! temporary for error check
real(r8) :: sumwt(lbc:ubc) ! sum of weights
real(r8), pointer :: wtcol(:) ! weight of pft relative to column
integer , pointer :: pcolumn(:) ! column index of corresponding pft
integer , pointer :: npfts(:) ! number of pfts in column
integer , pointer :: pfti(:) ! initial pft index in column
!------------------------------------------------------------------------
wtcol => clm3%g%l%c%p%wtcol
pcolumn => clm3%g%l%c%p%column
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
if (p2c_scale_type == 'unity') then
do p = lbp,ubp
scale_p2c(p) = 1.0_r8
end do
else
write(6,*)'p2c_1d error: scale type ',p2c_scale_type,' not supported'
call endrun()
end if
carr(lbc:ubc) = spval
sumwt(lbc:ubc) = 0._r8
#if (defined CPP_VECTOR)
!dir$ nointerchange
do pi = 1,max_pft_per_col
!dir$ concurrent
!cdir nodep
do c = lbc,ubc
if (pi <= npfts(c)) then
p = pfti(c) + pi - 1
if (wtcol(p) /= 0._r8) then
if (parr(p) /= spval) then
carr(c) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do pi = 1,max_pft_per_col
!dir$ concurrent
!cdir nodep
do c = lbc,ubc
if (pi <= npfts(c)) then
p = pfti(c) + pi - 1
if (wtcol(p) /= 0._r8) then
if (parr(p) /= spval) then
carr(c) = carr(c) + parr(p) * scale_p2c(p) * wtcol(p)
sumwt(c) = sumwt(c) + wtcol(p)
end if
end if
end if
end do
end do
#else
do p = lbp,ubp
if (wtcol(p) /= 0._r8) then
if (parr(p) /= spval) then
c = pcolumn(p)
if (sumwt(c) == 0._r8) carr(c) = 0._r8
carr(c) = carr(c) + parr(p) * scale_p2c(p) * wtcol(p)
sumwt(c) = sumwt(c) + wtcol(p)
end if
end if
end do
#endif
found = .false.
do c = lbc,ubc
if (sumwt(c) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = c
else if (sumwt(c) /= 0._r8) then
carr(c) = carr(c)/sumwt(c)
end if
end do
if (found) then
write(6,*)'p2c error: sumwt is greater than 1.0 at c= ',index
call endrun()
end if
end subroutine p2c_1d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: p2c_2d
!
! !INTERFACE:
subroutine p2c_2d (lbp, ubp, lbc, ubc, num2d, parr, carr, p2c_scale_type) 1,3
!
! !DESCRIPTION:
! Perfrom subgrid-average from landunits to gridcells.
! Averaging is only done for points that are not equal to "spval".
!
! !USES:
use clm_varpar, only : max_pft_per_col
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbp, ubp ! beginning and ending pft
integer , intent(in) :: lbc, ubc ! beginning and ending column
integer , intent(in) :: num2d ! size of second dimension
real(r8), intent(in) :: parr(lbp:ubp,num2d) ! pft array
real(r8), intent(out) :: carr(lbc:ubc,num2d) ! column array
character(len=*), intent(in) :: p2c_scale_type ! scale type
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: j,pi,p,c,index ! indices
real(r8) :: scale_p2c(lbp:ubp) ! scale factor for column->landunit mapping
logical :: found ! temporary for error check
real(r8) :: sumwt(lbc:ubc) ! sum of weights
real(r8), pointer :: wtcol(:) ! weight of pft relative to column
integer , pointer :: pcolumn(:) ! column index of corresponding pft
integer , pointer :: npfts(:) ! number of pfts in column
integer , pointer :: pfti(:) ! initial pft index in column
!------------------------------------------------------------------------
wtcol => clm3%g%l%c%p%wtcol
pcolumn => clm3%g%l%c%p%column
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
if (p2c_scale_type == 'unity') then
do p = lbp,ubp
scale_p2c(p) = 1.0_r8
end do
else
write(6,*)'p2c_2d error: scale type ',p2c_scale_type,' not supported'
call endrun()
end if
carr(:,:) = spval
do j = 1,num2d
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
!dir$ nointerchange
do pi = 1,max_pft_per_col
!dir$ concurrent
!cdir nodep
do c = lbc,ubc
if (pi <= npfts(c)) then
p = pfti(c) + pi - 1
if (wtcol(p) /= 0._r8) then
if (parr(p,j) /= spval) then
carr(c,j) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do pi = 1,max_pft_per_col
!dir$ concurrent
!cdir nodep
do c = lbc,ubc
if (pi <= npfts(c)) then
p = pfti(c) + pi - 1
if (wtcol(p) /= 0._r8) then
if (parr(p,j) /= spval) then
carr(c,j) = carr(c,j) + parr(p,j) * scale_p2c(p) * wtcol(p)
sumwt(c) = sumwt(c) + wtcol(p)
end if
end if
end if
end do
end do
#else
do p = lbp,ubp
if (wtcol(p) /= 0._r8) then
if (parr(p,j) /= spval) then
c = pcolumn(p)
if (sumwt(c) == 0._r8) carr(c,j) = 0._r8
carr(c,j) = carr(c,j) + parr(p,j) * scale_p2c(p) * wtcol(p)
sumwt(c) = sumwt(c) + wtcol(p)
end if
end if
end do
#endif
found = .false.
do c = lbc,ubc
if (sumwt(c) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = c
else if (sumwt(c) /= 0._r8) then
carr(c,j) = carr(c,j)/sumwt(c)
end if
end do
if (found) then
write(6,*)'p2c_2d error: sumwt is greater than 1.0 at c= ',index,' lev= ',j
call endrun()
end if
end do
end subroutine p2c_2d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: p2c_1d_filter
!
! !INTERFACE:
subroutine p2c_1d_filter (numfc, filterc, pftarr, colarr) 1,1
!
! !DESCRIPTION:
! perform pft to column averaging for single level pft arrays
!
! !USES:
use clm_varpar, only : max_pft_per_col
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: numfc
integer , intent(in) :: filterc(numfc)
real(r8), pointer :: pftarr(:)
real(r8), pointer :: colarr(:)
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: fc,c,pi,p ! indices
integer , pointer :: npfts(:)
integer , pointer :: pfti(:)
integer , pointer :: pftf(:)
real(r8), pointer :: wtcol(:)
real(r8), pointer :: wtgcell(:)
!-----------------------------------------------------------------------
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
pftf => clm3%g%l%c%pftf
wtcol => clm3%g%l%c%p%wtcol
wtgcell => clm3%g%l%c%p%wtgcell
#if (defined CPP_VECTOR)
!dir$ concurrent
!cdir nodep
do fc = 1,numfc
c = filterc(fc)
colarr(c) = 0._r8
end do
!dir$ nointerchange
do pi = 1,max_pft_per_col
!dir$ concurrent
!cdir nodep
do fc = 1,numfc
c = filterc(fc)
if ( pi <= npfts(c) ) then
p = pfti(c) + pi - 1
if (wtgcell(p) > 0._r8) colarr(c) = colarr(c) + pftarr(p) * wtcol(p)
end if
end do
end do
#else
do fc = 1,numfc
c = filterc(fc)
colarr(c) = 0._r8
do p = pfti(c), pftf(c)
if (wtgcell(p) > 0._r8) colarr(c) = colarr(c) + pftarr(p) * wtcol(p)
end do
end do
#endif
end subroutine p2c_1d_filter
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: p2c_2d_filter
!
! !INTERFACE:
subroutine p2c_2d_filter (lev, numfc, filterc, pftarr, colarr) 1,1
!
! !DESCRIPTION:
! perform pft to column averaging for multi level pft arrays
!
! !USES:
use clm_varpar, only : max_pft_per_col
! !ARGUMENTS:
implicit none
integer , intent(in) :: lev
integer , intent(in) :: numfc
integer , intent(in) :: filterc(numfc)
real(r8), pointer :: pftarr(:,:)
real(r8), pointer :: colarr(:,:)
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: fc,c,pi,p,j ! indices
integer , pointer :: npfts(:)
integer , pointer :: pfti(:)
integer , pointer :: pftf(:)
real(r8), pointer :: wtcol(:)
!-----------------------------------------------------------------------
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
pftf => clm3%g%l%c%pftf
wtcol => clm3%g%l%c%p%wtcol
#if (defined CPP_VECTOR)
do j = 1,lev
!dir$ concurrent
!cdir nodep
do fc = 1,numfc
c = filterc(fc)
colarr(c,j) = 0._r8
end do
!dir$ nointerchange
do pi = 1,max_pft_per_col
!dir$ concurrent
!cdir nodep
do fc = 1,numfc
c = filterc(fc)
if ( pi <= npfts(c) ) then
p = pfti(c) + pi - 1
colarr(c,j) = colarr(c,j) + pftarr(p,j) * wtcol(p)
end if
end do
end do
end do
#else
do j = 1,lev
do fc = 1,numfc
c = filterc(fc)
colarr(c,j) = 0._r8
do p = pfti(c), pftf(c)
colarr(c,j) = colarr(c,j) + pftarr(p,j) * wtcol(p)
end do
end do
end do
#endif
end subroutine p2c_2d_filter
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: p2l_1d
!
! !INTERFACE:
subroutine p2l_1d (lbp, ubp, lbc, ubc, lbl, ubl, parr, larr, & 1,4
p2c_scale_type, c2l_scale_type)
!
! !DESCRIPTION:
! Perfrom subgrid-average from pfts to landunits
! Averaging is only done for points that are not equal to "spval".
!
! !USES:
use clm_varpar, only : max_pft_per_lu
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbp, ubp ! beginning and ending pft indices
integer , intent(in) :: lbc, ubc ! beginning and ending column indices
integer , intent(in) :: lbl, ubl ! beginning and ending landunit indices
real(r8), intent(in) :: parr(lbp:ubp) ! input column array
real(r8), intent(out) :: larr(lbl:ubl) ! output landunit array
character(len=*), intent(in) :: p2c_scale_type ! scale factor type for averaging
character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: pi,p,c,l,index ! indices
logical :: found ! temporary for error check
real(r8) :: sumwt(lbl:ubl) ! sum of weights
real(r8) :: scale_p2c(lbc:ubc) ! scale factor for pft->column mapping
real(r8) :: scale_c2l(lbc:ubc) ! scale factor for column->landunit mapping
real(r8), pointer :: wtlunit(:) ! weight of pft relative to landunit
integer , pointer :: pcolumn(:) ! column of corresponding pft
integer , pointer :: plandunit(:) ! landunit of corresponding pft
integer , pointer :: npfts(:) ! number of pfts in landunit
integer , pointer :: pfti(:) ! initial pft index in landunit
integer , pointer :: clandunit(:) ! landunit of corresponding column
integer , pointer :: ctype(:) ! column type
integer , pointer :: ltype(:) ! landunit type
real(r8), pointer :: canyon_hwr(:) ! urban canyon height to width ratio
!------------------------------------------------------------------------
canyon_hwr => clm3%g%l%canyon_hwr
ltype => clm3%g%l%itype
ctype => clm3%g%l%c%itype
clandunit => clm3%g%l%c%landunit
wtlunit => clm3%g%l%c%p%wtlunit
pcolumn => clm3%g%l%c%p%column
plandunit => clm3%g%l%c%p%landunit
npfts => clm3%g%l%npfts
pfti => clm3%g%l%pfti
if (c2l_scale_type == 'unity') then
do c = lbc,ubc
scale_c2l(c) = 1.0_r8
end do
else if (c2l_scale_type == 'urbanf') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0_r8
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbans') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0 / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbanh') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = spval
else if (ctype(c) == icol_roof) then
scale_c2l(c) = spval
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else
write(6,*)'p2l_1d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
if (p2c_scale_type == 'unity') then
do p = lbp,ubp
scale_p2c(p) = 1.0_r8
end do
else
write(6,*)'p2l_1d error: scale type ',p2c_scale_type,' not supported'
call endrun()
end if
larr(:) = spval
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
!dir$ nointerchange
do pi = 1,max_pft_per_lu
!dir$ concurrent
!cdir nodep
do l = lbl,ubl
if (pi <= npfts(l)) then
p = pfti(l) + pi - 1
if (wtlunit(p) /= 0._r8) then
if (parr(p) /= spval) then
larr(l) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do pi = 1,max_pft_per_lu
!dir$ concurrent
!cdir nodep
do l = lbl,ubl
if (pi <= npfts(l)) then
p = pfti(l) + pi - 1
if (wtlunit(p) /= 0._r8) then
c = pcolumn(p)
if (parr(p) /= spval .and. scale_c2l(c) /= spval) then
larr(l) = larr(l) + parr(p) * scale_p2c(p) * scale_c2l(c) * wtlunit(p)
sumwt(l) = sumwt(l) + wtlunit(p)
end if
end if
end if
end do
end do
#else
do p = lbp,ubp
if (wtlunit(p) /= 0._r8) then
c = pcolumn(p)
if (parr(p) /= spval .and. scale_c2l(c) /= spval) then
l = plandunit(p)
if (sumwt(l) == 0._r8) larr(l) = 0._r8
larr(l) = larr(l) + parr(p) * scale_p2c(p) * scale_c2l(c) * wtlunit(p)
sumwt(l) = sumwt(l) + wtlunit(p)
end if
end if
end do
#endif
found = .false.
do l = lbl,ubl
if (sumwt(l) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = l
else if (sumwt(l) /= 0._r8) then
larr(l) = larr(l)/sumwt(l)
end if
end do
if (found) then
write(6,*)'p2l_1d error: sumwt is greater than 1.0 at l= ',index
call endrun()
end if
end subroutine p2l_1d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: p2l_2d
!
! !INTERFACE:
subroutine p2l_2d(lbp, ubp, lbc, ubc, lbl, ubl, num2d, parr, larr, & 1,4
p2c_scale_type, c2l_scale_type)
!
! !DESCRIPTION:
! Perfrom subgrid-average from pfts to landunits
! Averaging is only done for points that are not equal to "spval".
!
! !USES:
use clm_varpar, only : max_pft_per_lu
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbp, ubp ! beginning and ending pft indices
integer , intent(in) :: lbc, ubc ! beginning and ending column indices
integer , intent(in) :: lbl, ubl ! beginning and ending landunit indices
integer , intent(in) :: num2d ! size of second dimension
real(r8), intent(in) :: parr(lbp:ubp,num2d) ! input pft array
real(r8), intent(out) :: larr(lbl:ubl,num2d) ! output gridcell array
character(len=*), intent(in) :: p2c_scale_type ! scale factor type for averaging
character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: j,pi,p,c,l,index ! indices
logical :: found ! temporary for error check
real(r8) :: sumwt(lbl:ubl) ! sum of weights
real(r8) :: scale_p2c(lbc:ubc) ! scale factor for pft->column mapping
real(r8) :: scale_c2l(lbc:ubc) ! scale factor for column->landunit mapping
real(r8), pointer :: wtlunit(:) ! weight of pft relative to landunit
integer , pointer :: pcolumn(:) ! column of corresponding pft
integer , pointer :: plandunit(:) ! landunit of corresponding pft
integer , pointer :: npfts(:) ! number of pfts in landunit
integer , pointer :: pfti(:) ! initial pft index in landunit
integer , pointer :: clandunit(:) ! landunit of corresponding column
integer , pointer :: ctype(:) ! column type
integer , pointer :: ltype(:) ! landunit type
real(r8), pointer :: canyon_hwr(:) ! urban canyon height to width ratio
!------------------------------------------------------------------------
canyon_hwr => clm3%g%l%canyon_hwr
ltype => clm3%g%l%itype
clandunit => clm3%g%l%c%landunit
ctype => clm3%g%l%c%itype
wtlunit => clm3%g%l%c%p%wtlunit
pcolumn => clm3%g%l%c%p%column
plandunit => clm3%g%l%c%p%landunit
npfts => clm3%g%l%npfts
pfti => clm3%g%l%pfti
if (c2l_scale_type == 'unity') then
do c = lbc,ubc
scale_c2l(c) = 1.0_r8
end do
else if (c2l_scale_type == 'urbanf') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0_r8
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbans') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0 / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbanh') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = spval
else if (ctype(c) == icol_roof) then
scale_c2l(c) = spval
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else
write(6,*)'p2l_2d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
if (p2c_scale_type == 'unity') then
do p = lbp,ubp
scale_p2c(p) = 1.0_r8
end do
else
write(6,*)'p2l_2d error: scale type ',p2c_scale_type,' not supported'
call endrun()
end if
larr(:,:) = spval
do j = 1,num2d
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
!dir$ nointerchange
do pi = 1,max_pft_per_lu
!dir$ concurrent
!cdir nodep
do l = lbl,ubl
if (pi <= npfts(l)) then
p = pfti(l) + pi - 1
if (wtlunit(p) /= 0._r8) then
if (parr(p,j) /= spval) then
larr(l,j) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do pi = 1,max_pft_per_lu
!dir$ concurrent
!cdir nodep
do l = lbl,ubl
if (pi <= npfts(l)) then
p = pfti(l) + pi - 1
if (wtlunit(p) /= 0._r8) then
c = pcolumn(p)
if (parr(p,j) /= spval .and. scale_c2l(c) /= spval) then
larr(l,j) = larr(l,j) + parr(p,j) * scale_p2c(p) * scale_c2l(c) * wtlunit(p)
sumwt(l) = sumwt(l) + wtlunit(p)
end if
end if
end if
end do
end do
#else
do p = lbp,ubp
if (wtlunit(p) /= 0._r8) then
c = pcolumn(p)
if (parr(p,j) /= spval .and. scale_c2l(c) /= spval) then
l = plandunit(p)
if (sumwt(l) == 0._r8) larr(l,j) = 0._r8
larr(l,j) = larr(l,j) + parr(p,j) * scale_p2c(p) * scale_c2l(c) * wtlunit(p)
sumwt(l) = sumwt(l) + wtlunit(p)
end if
end if
end do
#endif
found = .false.
do l = lbl,ubl
if (sumwt(l) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = l
else if (sumwt(l) /= 0._r8) then
larr(l,j) = larr(l,j)/sumwt(l)
end if
end do
if (found) then
write(6,*)'p2l_2d error: sumwt is greater than 1.0 at l= ',index,' j= ',j
call endrun()
end if
end do
end subroutine p2l_2d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: p2g_1d
!
! !INTERFACE:
subroutine p2g_1d(lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg, parr, garr, & 1,5
p2c_scale_type, c2l_scale_type, l2g_scale_type)
!
! !DESCRIPTION:
! Perfrom subgrid-average from pfts to gridcells.
! Averaging is only done for points that are not equal to "spval".
!
! !USES:
use clm_varpar, only : max_pft_per_gcell
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbp, ubp ! beginning and ending pft indices
integer , intent(in) :: lbc, ubc ! beginning and ending column indices
integer , intent(in) :: lbl, ubl ! beginning and ending landunit indices
integer , intent(in) :: lbg, ubg ! beginning and ending gridcell indices
real(r8), intent(in) :: parr(lbp:ubp) ! input pft array
real(r8), intent(out) :: garr(lbg:ubg) ! output gridcell array
character(len=*), intent(in) :: p2c_scale_type ! scale factor type for averaging
character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging
character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
! !LOCAL VARIABLES:
!EOP
integer :: pi,p,c,l,g,index ! indices
logical :: found ! temporary for error check
real(r8) :: scale_p2c(lbp:ubp) ! scale factor
real(r8) :: scale_c2l(lbc:ubc) ! scale factor
real(r8) :: scale_l2g(lbl:ubl) ! scale factor
real(r8) :: sumwt(lbg:ubg) ! sum of weights
real(r8), pointer :: wtgcell(:) ! weight of pfts relative to gridcells
integer , pointer :: pcolumn(:) ! column of corresponding pft
integer , pointer :: plandunit(:) ! landunit of corresponding pft
integer , pointer :: pgridcell(:) ! gridcell of corresponding pft
integer , pointer :: npfts(:) ! number of pfts in gridcell
integer , pointer :: pfti(:) ! initial pft index in gridcell
integer , pointer :: ctype(:) ! column type
integer , pointer :: clandunit(:) ! landunit of corresponding column
integer , pointer :: ltype(:) ! landunit type
real(r8), pointer :: canyon_hwr(:) ! urban canyon height to width ratio
!------------------------------------------------------------------------
canyon_hwr => clm3%g%l%canyon_hwr
ltype => clm3%g%l%itype
clandunit => clm3%g%l%c%landunit
ctype => clm3%g%l%c%itype
wtgcell => clm3%g%l%c%p%wtgcell
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
plandunit => clm3%g%l%c%p%landunit
npfts => clm3%g%npfts
pfti => clm3%g%pfti
if (l2g_scale_type == 'unity') then
do l = lbl,ubl
scale_l2g(l) = 1.0_r8
end do
else
write(6,*)'p2g_1d error: scale type ',l2g_scale_type,' not supported'
call endrun()
end if
if (c2l_scale_type == 'unity') then
do c = lbc,ubc
scale_c2l(c) = 1.0_r8
end do
else if (c2l_scale_type == 'urbanf') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0_r8
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbans') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0 / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbanh') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = spval
else if (ctype(c) == icol_roof) then
scale_c2l(c) = spval
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else
write(6,*)'p2g_1d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
if (p2c_scale_type == 'unity') then
do p = lbp,ubp
scale_p2c(p) = 1.0_r8
end do
else
write(6,*)'p2g_1d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
garr(:) = spval
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
!dir$ nointerchange
do pi = 1,max_pft_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (pi <= npfts(g)) then
p = pfti(g) + pi - 1
if (wtgcell(p) /= 0._r8) then
if (parr(p) /= spval) then
garr(g) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do pi = 1,max_pft_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (pi <= npfts(g)) then
p = pfti(g) + pi - 1
if (wtgcell(p) /= 0._r8) then
c = pcolumn(p)
if (parr(p) /= spval .and. scale_c2l(c) /= spval) then
l = plandunit(p)
garr(g) = garr(g) + parr(p) * scale_p2c(p) * scale_c2l(c) * scale_l2g(l) * wtgcell(p)
sumwt(g) = sumwt(g) + wtgcell(p)
end if
end if
end if
end do
end do
#else
do p = lbp,ubp
if (wtgcell(p) /= 0._r8) then
c = pcolumn(p)
if (parr(p) /= spval .and. scale_c2l(c) /= spval) then
l = plandunit(p)
g = pgridcell(p)
if (sumwt(g) == 0._r8) garr(g) = 0._r8
garr(g) = garr(g) + parr(p) * scale_p2c(p) * scale_c2l(c) * scale_l2g(l) * wtgcell(p)
sumwt(g) = sumwt(g) + wtgcell(p)
end if
end if
end do
#endif
found = .false.
do g = lbg, ubg
if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = g
else if (sumwt(g) /= 0._r8) then
garr(g) = garr(g)/sumwt(g)
end if
end do
if (found) then
write(6,*)'p2g_1d error: sumwt is greater than 1.0 at g= ',index
call endrun()
end if
end subroutine p2g_1d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: p2g_2d
!
! !INTERFACE:
subroutine p2g_2d(lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg, num2d, & 1,5
parr, garr, p2c_scale_type, c2l_scale_type, l2g_scale_type)
!
! !DESCRIPTION:
! Perfrom subgrid-average from pfts to gridcells.
! Averaging is only done for points that are not equal to "spval".
!
! !USES:
use clm_varpar, only : max_pft_per_gcell
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbp, ubp ! beginning and ending pft indices
integer , intent(in) :: lbc, ubc ! beginning and ending column indices
integer , intent(in) :: lbl, ubl ! beginning and ending landunit indices
integer , intent(in) :: lbg, ubg ! beginning and ending gridcell indices
integer , intent(in) :: num2d ! size of second dimension
real(r8), intent(in) :: parr(lbp:ubp,num2d) ! input pft array
real(r8), intent(out) :: garr(lbg:ubg,num2d) ! output gridcell array
character(len=*), intent(in) :: p2c_scale_type ! scale factor type for averaging
character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging
character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: j,pi,p,c,l,g,index ! indices
logical :: found ! temporary for error check
real(r8) :: scale_p2c(lbp:ubp) ! scale factor
real(r8) :: scale_c2l(lbc:ubc) ! scale factor
real(r8) :: scale_l2g(lbl:ubl) ! scale factor
real(r8) :: sumwt(lbg:ubg) ! sum of weights
real(r8), pointer :: wtgcell(:) ! weight of pfts relative to gridcells
integer , pointer :: pcolumn(:) ! column of corresponding pft
integer , pointer :: plandunit(:) ! landunit of corresponding pft
integer , pointer :: pgridcell(:) ! gridcell of corresponding pft
integer , pointer :: npfts(:) ! number of pfts in gridcell
integer , pointer :: pfti(:) ! initial pft index in gridcell
integer , pointer :: clandunit(:) ! landunit of corresponding column
integer , pointer :: ctype(:) ! column type
integer , pointer :: ltype(:) ! landunit type
real(r8), pointer :: canyon_hwr(:) ! urban canyon height to width ratio
!------------------------------------------------------------------------
canyon_hwr => clm3%g%l%canyon_hwr
ltype => clm3%g%l%itype
clandunit => clm3%g%l%c%landunit
ctype => clm3%g%l%c%itype
wtgcell => clm3%g%l%c%p%wtgcell
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
plandunit => clm3%g%l%c%p%landunit
npfts => clm3%g%npfts
pfti => clm3%g%pfti
if (l2g_scale_type == 'unity') then
do l = lbl,ubl
scale_l2g(l) = 1.0_r8
end do
else
write(6,*)'p2g_2d error: scale type ',l2g_scale_type,' not supported'
call endrun()
end if
if (c2l_scale_type == 'unity') then
do c = lbc,ubc
scale_c2l(c) = 1.0_r8
end do
else if (c2l_scale_type == 'urbanf') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0_r8
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbans') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0 / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbanh') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = spval
else if (ctype(c) == icol_roof) then
scale_c2l(c) = spval
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else
write(6,*)'p2g_2d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
if (p2c_scale_type == 'unity') then
do p = lbp,ubp
scale_p2c(p) = 1.0_r8
end do
else
write(6,*)'p2g_2d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
garr(:,:) = spval
do j = 1,num2d
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
!dir$ nointerchange
do pi = 1,max_pft_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (pi <= npfts(g)) then
p = pfti(g) + pi - 1
if (wtgcell(p) /= 0._r8) then
if (parr(p,j) /= spval) then
garr(g,j) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do pi = 1,max_pft_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (pi <= npfts(g)) then
p = pfti(g) + pi - 1
if (wtgcell(p) /= 0._r8) then
c = pcolumn(p)
if (parr(p,j) /= spval .and. scale_c2l(c) /= spval) then
l = plandunit(p)
garr(g,j) = garr(g,j) + parr(p,j) * scale_p2c(p) * scale_c2l(c) * scale_l2g(l) * wtgcell(p)
sumwt(g) = sumwt(g) + wtgcell(p)
end if
end if
end if
end do
end do
#else
do p = lbp,ubp
if (wtgcell(p) /= 0._r8) then
c = pcolumn(p)
if (parr(p,j) /= spval .and. scale_c2l(c) /= spval) then
l = plandunit(p)
g = pgridcell(p)
if (sumwt(g) == 0._r8) garr(g,j) = 0._r8
garr(g,j) = garr(g,j) + parr(p,j) * scale_p2c(p) * scale_c2l(c) * scale_l2g(l) * wtgcell(p)
sumwt(g) = sumwt(g) + wtgcell(p)
end if
end if
end do
#endif
found = .false.
do g = lbg, ubg
if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = g
else if (sumwt(g) /= 0._r8) then
garr(g,j) = garr(g,j)/sumwt(g)
end if
end do
if (found) then
write(6,*)'p2g_2d error: sumwt gt 1.0 at g/sumwt = ',index,sumwt(index)
call endrun()
end if
end do
end subroutine p2g_2d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: c2l_1d
!
! !INTERFACE:
subroutine c2l_1d (lbc, ubc, lbl, ubl, carr, larr, c2l_scale_type) 1,2
!
! !DESCRIPTION:
! Perfrom subgrid-average from columns to landunits
! Averaging is only done for points that are not equal to "spval".
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! beginning and ending column indices
integer , intent(in) :: lbl, ubl ! beginning and ending landunit indices
real(r8), intent(in) :: carr(lbc:ubc) ! input column array
real(r8), intent(out) :: larr(lbl:ubl) ! output landunit array
character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: ci,c,l,index ! indices
integer :: max_col_per_lu ! max columns per landunit; on the fly
logical :: found ! temporary for error check
real(r8) :: scale_c2l(lbc:ubc) ! scale factor for column->landunit mapping
real(r8) :: sumwt(lbl:ubl) ! sum of weights
real(r8), pointer :: wtlunit(:) ! weight of landunits relative to gridcells
integer , pointer :: clandunit(:) ! gridcell of corresponding column
integer , pointer :: ncolumns(:) ! number of columns in landunit
integer , pointer :: coli(:) ! initial column index in landunit
integer , pointer :: ctype(:) ! column type
integer , pointer :: ltype(:) ! landunit type
real(r8), pointer :: canyon_hwr(:) ! urban canyon height to width ratio
!------------------------------------------------------------------------
ctype => clm3%g%l%c%itype
ltype => clm3%g%l%itype
canyon_hwr => clm3%g%l%canyon_hwr
wtlunit => clm3%g%l%c%wtlunit
clandunit => clm3%g%l%c%landunit
ncolumns => clm3%g%l%ncolumns
coli => clm3%g%l%coli
if (c2l_scale_type == 'unity') then
do c = lbc,ubc
scale_c2l(c) = 1.0_r8
end do
else if (c2l_scale_type == 'urbanf') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0_r8
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbans') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0 / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbanh') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = spval
else if (ctype(c) == icol_roof) then
scale_c2l(c) = spval
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else
write(6,*)'c2l_1d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
larr(:) = spval
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
max_col_per_lu = 0
do l = lbl,ubl
max_col_per_lu = max(ncolumns(l), max_col_per_lu)
end do
!dir$ nointerchange
do ci = 1,max_col_per_lu
!dir$ concurrent
!cdir nodep
do l = lbl,ubl
if (ci <= ncolumns(l)) then
c = coli(l) + ci - 1
if (wtlunit(c) /= 0._r8) then
if (carr(c) /= spval) then
larr(l) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do ci = 1,max_col_per_lu
!dir$ concurrent
!cdir nodep
do l = lbl,ubl
if (ci <= ncolumns(l)) then
c = coli(l) + ci - 1
if (wtlunit(c) /= 0._r8) then
if (carr(c) /= spval .and. scale_c2l(c) /= spval) then
larr(l) = larr(l) + carr(c) * scale_c2l(c) * wtlunit(c)
sumwt(l) = sumwt(l) + wtlunit(c)
end if
end if
end if
end do
end do
#else
do c = lbc,ubc
if (wtlunit(c) /= 0._r8) then
if (carr(c) /= spval .and. scale_c2l(c) /= spval) then
l = clandunit(c)
if (sumwt(l) == 0._r8) larr(l) = 0._r8
larr(l) = larr(l) + carr(c) * scale_c2l(c) * wtlunit(c)
sumwt(l) = sumwt(l) + wtlunit(c)
end if
end if
end do
#endif
found = .false.
do l = lbl,ubl
if (sumwt(l) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = l
else if (sumwt(l) /= 0._r8) then
larr(l) = larr(l)/sumwt(l)
end if
end do
if (found) then
write(6,*)'c2l_1d error: sumwt is greater than 1.0 at l= ',index
call endrun()
end if
end subroutine c2l_1d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: c2l_2d
!
! !INTERFACE:
subroutine c2l_2d (lbc, ubc, lbl, ubl, num2d, carr, larr, c2l_scale_type) 1,2
!
! !DESCRIPTION:
! Perfrom subgrid-average from columns to landunits
! Averaging is only done for points that are not equal to "spval".
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! beginning and ending column indices
integer , intent(in) :: lbl, ubl ! beginning and ending landunit indices
integer , intent(in) :: num2d ! size of second dimension
real(r8), intent(in) :: carr(lbc:ubc,num2d) ! input column array
real(r8), intent(out) :: larr(lbl:ubl,num2d) ! output landunit array
character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: j,l,ci,c,index ! indices
integer :: max_col_per_lu ! max columns per landunit; on the fly
logical :: found ! temporary for error check
real(r8) :: scale_c2l(lbc:ubc) ! scale factor for column->landunit mapping
real(r8) :: sumwt(lbl:ubl) ! sum of weights
real(r8), pointer :: wtlunit(:) ! weight of column relative to landunit
integer , pointer :: clandunit(:) ! landunit of corresponding column
integer , pointer :: ncolumns(:) ! number of columns in landunit
integer , pointer :: coli(:) ! initial column index in landunit
integer , pointer :: ctype(:) ! column type
integer , pointer :: ltype(:) ! landunit type
real(r8), pointer :: canyon_hwr(:) ! urban canyon height to width ratio
!------------------------------------------------------------------------
ctype => clm3%g%l%c%itype
ltype => clm3%g%l%itype
canyon_hwr => clm3%g%l%canyon_hwr
wtlunit => clm3%g%l%c%wtlunit
clandunit => clm3%g%l%c%landunit
ncolumns => clm3%g%l%ncolumns
coli => clm3%g%l%coli
if (c2l_scale_type == 'unity') then
do c = lbc,ubc
scale_c2l(c) = 1.0_r8
end do
else if (c2l_scale_type == 'urbanf') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0_r8
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbans') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0 / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbanh') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = spval
else if (ctype(c) == icol_roof) then
scale_c2l(c) = spval
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else
write(6,*)'c2l_2d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
#if (defined CPP_VECTOR)
max_col_per_lu = 0
do l = lbl,ubl
max_col_per_lu = max(ncolumns(l), max_col_per_lu)
end do
#endif
larr(:,:) = spval
do j = 1,num2d
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
!dir$ nointerchange
do ci = 1,max_col_per_lu
!dir$ concurrent
!cdir nodep
do l = lbl,ubl
if (ci <= ncolumns(l)) then
c = coli(l) + ci - 1
if (wtlunit(c) /= 0._r8) then
if (carr(c,j) /= spval) then
larr(l,j) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do ci = 1,max_col_per_lu
!dir$ concurrent
!cdir nodep
do l = lbl,ubl
if (ci <= ncolumns(l)) then
c = coli(l) + ci - 1
if (wtlunit(c) /= 0._r8) then
if (carr(c,j) /= spval .and. scale_c2l(c) /= spval) then
larr(l,j) = larr(l,j) + carr(c,j) * scale_c2l(c) * wtlunit(c)
sumwt(l) = sumwt(l) + wtlunit(c)
end if
end if
end if
end do
end do
#else
do c = lbc,ubc
if (wtlunit(c) /= 0._r8) then
if (carr(c,j) /= spval .and. scale_c2l(c) /= spval) then
l = clandunit(c)
if (sumwt(l) == 0._r8) larr(l,j) = 0._r8
larr(l,j) = larr(l,j) + carr(c,j) * scale_c2l(c) * wtlunit(c)
sumwt(l) = sumwt(l) + wtlunit(c)
end if
end if
end do
#endif
found = .false.
do l = lbl,ubl
if (sumwt(l) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = l
else if (sumwt(l) /= 0._r8) then
larr(l,j) = larr(l,j)/sumwt(l)
end if
end do
if (found) then
write(6,*)'c2l_2d error: sumwt is greater than 1.0 at l= ',index,' lev= ',j
call endrun()
end if
end do
end subroutine c2l_2d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: c2g_1d
!
! !INTERFACE:
subroutine c2g_1d(lbc, ubc, lbl, ubl, lbg, ubg, carr, garr, & 1,3
c2l_scale_type, l2g_scale_type)
!
! !DESCRIPTION:
! Perfrom subgrid-average from columns to gridcells.
! Averaging is only done for points that are not equal to "spval".
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! beginning and ending column indices
integer , intent(in) :: lbl, ubl ! beginning and ending landunit indices
integer , intent(in) :: lbg, ubg ! beginning and ending landunit indices
real(r8), intent(in) :: carr(lbc:ubc) ! input column array
real(r8), intent(out) :: garr(lbg:ubg) ! output gridcell array
character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging
character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: ci,c,l,g,index ! indices
integer :: max_col_per_gcell ! max columns per gridcell; on the fly
logical :: found ! temporary for error check
real(r8) :: scale_c2l(lbc:ubc) ! scale factor
real(r8) :: scale_l2g(lbl:ubl) ! scale factor
real(r8) :: sumwt(lbg:ubg) ! sum of weights
real(r8), pointer :: wtgcell(:) ! weight of columns relative to gridcells
integer , pointer :: clandunit(:) ! landunit of corresponding column
integer , pointer :: cgridcell(:) ! gridcell of corresponding column
integer , pointer :: ncolumns(:) ! number of columns in gridcell
integer , pointer :: coli(:) ! initial column index in gridcell
integer , pointer :: ctype(:) ! column type
integer , pointer :: ltype(:) ! landunit type
real(r8), pointer :: canyon_hwr(:) ! urban canyon height to width ratio
!------------------------------------------------------------------------
ctype => clm3%g%l%c%itype
ltype => clm3%g%l%itype
canyon_hwr => clm3%g%l%canyon_hwr
wtgcell => clm3%g%l%c%wtgcell
clandunit => clm3%g%l%c%landunit
cgridcell => clm3%g%l%c%gridcell
ncolumns => clm3%g%ncolumns
coli => clm3%g%coli
if (l2g_scale_type == 'unity') then
do l = lbl,ubl
scale_l2g(l) = 1.0_r8
end do
else
write(6,*)'c2l_1d error: scale type ',l2g_scale_type,' not supported'
call endrun()
end if
if (c2l_scale_type == 'unity') then
do c = lbc,ubc
scale_c2l(c) = 1.0_r8
end do
else if (c2l_scale_type == 'urbanf') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0_r8
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbans') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0 / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbanh') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = spval
else if (ctype(c) == icol_roof) then
scale_c2l(c) = spval
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else
write(6,*)'c2l_1d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
garr(:) = spval
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
max_col_per_gcell = 0
do g = lbg,ubg
max_col_per_gcell = max(ncolumns(g), max_col_per_gcell)
end do
!dir$ nointerchange
do ci = 1,max_col_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (ci <= ncolumns(g)) then
c = coli(g) + ci - 1
if (wtgcell(c) /= 0._r8) then
if (carr(c) /= spval) then
garr(g) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do ci = 1,max_col_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (ci <= ncolumns(g)) then
c = coli(g) + ci - 1
if (wtgcell(c) /= 0._r8) then
if (carr(c) /= spval .and. scale_c2l(c) /= spval) then
l = clandunit(c)
garr(g) = garr(g) + carr(c) * scale_c2l(c) * scale_l2g(l) * wtgcell(c)
sumwt(g) = sumwt(g) + wtgcell(c)
end if
end if
end if
end do
end do
#else
do c = lbc,ubc
if ( wtgcell(c) /= 0._r8) then
if (carr(c) /= spval .and. scale_c2l(c) /= spval) then
l = clandunit(c)
g = cgridcell(c)
if (sumwt(g) == 0._r8) garr(g) = 0._r8
garr(g) = garr(g) + carr(c) * scale_c2l(c) * scale_l2g(l) * wtgcell(c)
sumwt(g) = sumwt(g) + wtgcell(c)
end if
end if
end do
#endif
found = .false.
do g = lbg, ubg
if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = g
else if (sumwt(g) /= 0._r8) then
garr(g) = garr(g)/sumwt(g)
end if
end do
if (found) then
write(6,*)'c2g_1d error: sumwt is greater than 1.0 at g= ',index
call endrun()
end if
end subroutine c2g_1d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: c2g_2d
!
! !INTERFACE:
subroutine c2g_2d(lbc, ubc, lbl, ubl, lbg, ubg, num2d, carr, garr, & 1,3
c2l_scale_type, l2g_scale_type)
!
! !DESCRIPTION:
! Perfrom subgrid-average from columns to gridcells.
! Averaging is only done for points that are not equal to "spval".
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! beginning and ending column indices
integer , intent(in) :: lbl, ubl ! beginning and ending landunit indices
integer , intent(in) :: lbg, ubg ! beginning and ending gridcell indices
integer , intent(in) :: num2d ! size of second dimension
real(r8), intent(in) :: carr(lbc:ubc,num2d) ! input column array
real(r8), intent(out) :: garr(lbg:ubg,num2d) ! output gridcell array
character(len=*), intent(in) :: c2l_scale_type ! scale factor type for averaging
character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: j,ci,c,g,l,index ! indices
integer :: max_col_per_gcell ! max columns per gridcell; on the fly
logical :: found ! temporary for error check
real(r8) :: scale_c2l(lbc:ubc) ! scale factor
real(r8) :: scale_l2g(lbl:ubl) ! scale factor
real(r8) :: sumwt(lbg:ubg) ! sum of weights
real(r8), pointer :: wtgcell(:) ! weight of columns relative to gridcells
integer , pointer :: clandunit(:) ! landunit of corresponding column
integer , pointer :: cgridcell(:) ! gridcell of corresponding column
integer , pointer :: ncolumns(:) ! number of columns in gridcell
integer , pointer :: coli(:) ! initial column index in gridcell
integer , pointer :: ctype(:) ! column type
integer , pointer :: ltype(:) ! landunit type
real(r8), pointer :: canyon_hwr(:) ! urban canyon height to width ratio
!------------------------------------------------------------------------
ctype => clm3%g%l%c%itype
ltype => clm3%g%l%itype
canyon_hwr => clm3%g%l%canyon_hwr
wtgcell => clm3%g%l%c%wtgcell
clandunit => clm3%g%l%c%landunit
cgridcell => clm3%g%l%c%gridcell
ncolumns => clm3%g%ncolumns
coli => clm3%g%coli
if (l2g_scale_type == 'unity') then
do l = lbl,ubl
scale_l2g(l) = 1.0_r8
end do
else
write(6,*)'c2g_2d error: scale type ',l2g_scale_type,' not supported'
call endrun()
end if
if (c2l_scale_type == 'unity') then
do c = lbc,ubc
scale_c2l(c) = 1.0_r8
end do
else if (c2l_scale_type == 'urbanf') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = 3.0 * canyon_hwr(l)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0_r8
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbans') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = (3.0 * canyon_hwr(l)) / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = 3.0 / (2.*canyon_hwr(l) + 1.)
else if (ctype(c) == icol_roof) then
scale_c2l(c) = 1.0_r8
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else if (c2l_scale_type == 'urbanh') then
do c = lbc,ubc
l = clandunit(c)
if (ltype(l) == isturb) then
if (ctype(c) == icol_sunwall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_shadewall) then
scale_c2l(c) = spval
else if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
scale_c2l(c) = spval
else if (ctype(c) == icol_roof) then
scale_c2l(c) = spval
end if
else
scale_c2l(c) = 1.0_r8
end if
end do
else
write(6,*)'c2g_2d error: scale type ',c2l_scale_type,' not supported'
call endrun()
end if
#if (defined CPP_VECTOR)
max_col_per_gcell = 0
do g = lbg,ubg
max_col_per_gcell = max(ncolumns(g), max_col_per_gcell)
end do
#endif
garr(:,:) = spval
do j = 1,num2d
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
!dir$ nointerchange
do ci = 1,max_col_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (ci <= ncolumns(g)) then
c = coli(g) + ci - 1
if (wtgcell(c) /= 0._r8) then
if (carr(c,j) /= spval) then
garr(g,j) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do ci = 1,max_col_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (ci <= ncolumns(g)) then
c = coli(g) + ci - 1
if (wtgcell(c) /= 0._r8) then
if (carr(c,j) /= spval .and. scale_c2l(c) /= spval) then
l = clandunit(c)
garr(g,j) = garr(g,j) + carr(c,j) * scale_c2l(c) * scale_l2g(l) * wtgcell(c)
sumwt(g) = sumwt(g) + wtgcell(c)
end if
end if
end if
end do
end do
#else
do c = lbc,ubc
if (wtgcell(c) /= 0._r8) then
if (carr(c,j) /= spval .and. scale_c2l(c) /= spval) then
l = clandunit(c)
g = cgridcell(c)
if (sumwt(g) == 0._r8) garr(g,j) = 0._r8
garr(g,j) = garr(g,j) + carr(c,j) * scale_c2l(c) * scale_l2g(l) * wtgcell(c)
sumwt(g) = sumwt(g) + wtgcell(c)
end if
end if
end do
#endif
found = .false.
do g = lbg, ubg
if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = g
else if (sumwt(g) /= 0._r8) then
garr(g,j) = garr(g,j)/sumwt(g)
end if
end do
if (found) then
write(6,*)'c2g_2d error: sumwt is greater than 1.0 at g= ',index
call endrun()
end if
end do
end subroutine c2g_2d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: l2g_1d
!
! !INTERFACE:
subroutine l2g_1d(lbl, ubl, lbg, ubg, larr, garr, l2g_scale_type) 1,2
!
! !DESCRIPTION:
! Perfrom subgrid-average from landunits to gridcells.
! Averaging is only done for points that are not equal to "spval".
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbl, ubl ! beginning and ending sub landunit indices
integer , intent(in) :: lbg, ubg ! beginning and ending gridcell indices
real(r8), intent(in) :: larr(lbl:ubl) ! input landunit array
real(r8), intent(out) :: garr(lbg:ubg) ! output gridcell array
character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: li,l,g,index ! indices
integer :: max_lu_per_gcell ! max landunits per gridcell; on the fly
logical :: found ! temporary for error check
real(r8) :: scale_l2g(lbl:ubl) ! scale factor
real(r8) :: sumwt(lbg:ubg) ! sum of weights
real(r8), pointer :: wtgcell(:) ! weight of landunits relative to gridcells
integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit
integer , pointer :: nlandunits(:) ! number of landunits in gridcell
integer , pointer :: luni(:) ! initial landunit index in gridcell
!------------------------------------------------------------------------
wtgcell => clm3%g%l%wtgcell
lgridcell => clm3%g%l%gridcell
nlandunits => clm3%g%nlandunits
luni => clm3%g%luni
if (l2g_scale_type == 'unity') then
do l = lbl,ubl
scale_l2g(l) = 1.0_r8
end do
else
write(6,*)'l2g_1d error: scale type ',l2g_scale_type,' not supported'
call endrun()
end if
garr(:) = spval
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
max_lu_per_gcell = 0
do g = lbg,ubg
max_lu_per_gcell = max(nlandunits(g), max_lu_per_gcell)
end do
!dir$ nointerchange
do li = 1,max_lu_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (li <= nlandunits(g)) then
l = luni(g) + li - 1
if (wtgcell(l) /= 0._r8) then
if (larr(l) /= spval) then
garr(g) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do li = 1,max_lu_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (li <= nlandunits(g)) then
l = luni(g) + li - 1
if (wtgcell(l) /= 0._r8) then
if (larr(l) /= spval) then
garr(g) = garr(g) + larr(l) * scale_l2g(l) * wtgcell(l)
sumwt(g) = sumwt(g) + wtgcell(l)
end if
end if
end if
end do
end do
#else
do l = lbl,ubl
if (wtgcell(l) /= 0._r8) then
if (larr(l) /= spval) then
g = lgridcell(l)
if (sumwt(g) == 0._r8) garr(g) = 0._r8
garr(g) = garr(g) + larr(l) * scale_l2g(l) * wtgcell(l)
sumwt(g) = sumwt(g) + wtgcell(l)
end if
end if
end do
#endif
found = .false.
do g = lbg, ubg
if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index = g
else if (sumwt(g) /= 0._r8) then
garr(g) = garr(g)/sumwt(g)
end if
end do
if (found) then
write(6,*)'l2g_1d error: sumwt is greater than 1.0 at g= ',index
call endrun()
end if
end subroutine l2g_1d
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: l2g_2d
!
! !INTERFACE:
subroutine l2g_2d(lbl, ubl, lbg, ubg, num2d, larr, garr, l2g_scale_type) 1,2
!
! !DESCRIPTION:
! Perfrom subgrid-average from landunits to gridcells.
! Averaging is only done for points that are not equal to "spval".
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbl, ubl ! beginning and ending column indices
integer , intent(in) :: lbg, ubg ! beginning and ending gridcell indices
integer , intent(in) :: num2d ! size of second dimension
real(r8), intent(in) :: larr(lbl:ubl,num2d) ! input landunit array
real(r8), intent(out) :: garr(lbg:ubg,num2d) ! output gridcell array
character(len=*), intent(in) :: l2g_scale_type ! scale factor type for averaging
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 12/03
!
!
! !LOCAL VARIABLES:
!EOP
integer :: j,g,li,l,index ! indices
integer :: max_lu_per_gcell ! max landunits per gridcell; on the fly
logical :: found ! temporary for error check
real(r8) :: scale_l2g(lbl:ubl) ! scale factor
real(r8) :: sumwt(lbg:ubg) ! sum of weights
real(r8), pointer :: wtgcell(:) ! weight of landunits relative to gridcells
integer , pointer :: lgridcell(:) ! gridcell of corresponding landunit
integer , pointer :: nlandunits(:) ! number of landunits in gridcell
integer , pointer :: luni(:) ! initial landunit index in gridcell
!------------------------------------------------------------------------
wtgcell => clm3%g%l%wtgcell
lgridcell => clm3%g%l%gridcell
nlandunits => clm3%g%nlandunits
luni => clm3%g%luni
if (l2g_scale_type == 'unity') then
do l = lbl,ubl
scale_l2g(l) = 1.0_r8
end do
else
write(6,*)'l2g_2d error: scale type ',l2g_scale_type,' not supported'
call endrun()
end if
#if (defined CPP_VECTOR)
max_lu_per_gcell = 0
do g = lbg,ubg
max_lu_per_gcell = max(nlandunits(g), max_lu_per_gcell)
end do
#endif
garr(:,:) = spval
do j = 1,num2d
sumwt(:) = 0._r8
#if (defined CPP_VECTOR)
!dir$ nointerchange
do li = 1,max_lu_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (li <= nlandunits(g)) then
l = luni(g) + li - 1
if (wtgcell(l) /= 0._r8) then
if (larr(l,j) /= spval) then
garr(g,j) = 0._r8
end if
end if
end if
end do
end do
!dir$ nointerchange
do li = 1,max_lu_per_gcell
!dir$ concurrent
!cdir nodep
do g = lbg,ubg
if (li <= nlandunits(g)) then
l = luni(g) + li - 1
if (wtgcell(l) /= 0._r8) then
if (larr(l,j) /= spval) then
garr(g,j) = garr(g,j) + larr(l,j) * scale_l2g(l) * wtgcell(l)
sumwt(g) = sumwt(g) + wtgcell(l)
end if
end if
end if
end do
end do
#else
do l = lbl,ubl
if (wtgcell(l) /= 0._r8) then
if (larr(l,j) /= spval) then
g = lgridcell(l)
if (sumwt(g) == 0._r8) garr(g,j) = 0._r8
garr(g,j) = garr(g,j) + larr(l,j) * scale_l2g(l) * wtgcell(l)
sumwt(g) = sumwt(g) + wtgcell(l)
end if
end if
end do
#endif
found = .false.
do g = lbg,ubg
if (sumwt(g) > 1.0_r8 + 1.e-6_r8) then
found = .true.
index= g
else if (sumwt(g) /= 0._r8) then
garr(g,j) = garr(g,j)/sumwt(g)
end if
end do
if (found) then
write(6,*)'l2g_2d error: sumwt is greater than 1.0 at g= ',index,' lev= ',j
call endrun()
end if
end do
end subroutine l2g_2d
end module subgridAveMod
module pft2colMod 5,3
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: pft2colMod
!
! !DESCRIPTION:
! Contains calls to methods to perfom averages over from pfts to columns
! for model variables.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use subgridAveMod
use clmtype
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: p2c ! obtain column properties from average over column pfts
!
! !REVISION HISTORY:
! 03/09/08: Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: pft2col
!
! !INTERFACE:
subroutine pft2col (lbc, ubc, num_nolakec, filter_nolakec) 1,11
!
! !DESCRIPTION:
! Averages over all pfts for variables defined over both soil and lake
! to provide the column-level averages of state and flux variables
! defined at the pft level.
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
!
! !REVISION HISTORY:
! 03/09/08: Created by Mariana Vertenstein
!
!EOP
!
! !OTHER LOCAL VARIABLES:
integer :: c,fc ! indices
integer :: num_allc ! number of total column points
integer :: filter_allc(ubc-lbc+1) ! filter for all column points
real(r8), pointer :: ptrp(:) ! pointer to input pft array
real(r8), pointer :: ptrc(:) ! pointer to output column array
! -----------------------------------------------------------------
! Set up a filter for all column points
num_allc = ubc-lbc+1
fc = 0
do c = lbc,ubc
fc = fc + 1
filter_allc(fc) = c
end do
! Averaging for pft water state variables
ptrp => clm3%g%l%c%p%pws%h2ocan
ptrc => clm3%g%l%c%cws%pws_a%h2ocan
call p2c (num_nolakec, filter_nolakec, ptrp, ptrc)
! Averaging for pft water flux variables
ptrp => clm3%g%l%c%p%pwf%qflx_evap_tot
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_evap_tot
call p2c (num_allc, filter_allc, ptrp, ptrc)
ptrp => clm3%g%l%c%p%pwf%qflx_rain_grnd
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_rain_grnd
call p2c (num_nolakec, filter_nolakec, ptrp, ptrc)
ptrp => clm3%g%l%c%p%pwf%qflx_snow_grnd
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_snow_grnd
call p2c (num_nolakec, filter_nolakec, ptrp, ptrc)
! ptrp => clm3%g%l%c%p%pwf%qflx_snowcap
! ptrc => clm3%g%l%c%cwf%pwf_a%qflx_snowcap
! call p2c (num_nolakec, filter_nolakec, ptrp, ptrc)
!CLM4
ptrp => clm3%g%l%c%p%pwf%qflx_snwcp_liq
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_snwcp_liq
call p2c (num_allc, filter_allc, ptrp, ptrc)
ptrp => clm3%g%l%c%p%pwf%qflx_snwcp_ice
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_snwcp_ice
call p2c (num_allc, filter_allc, ptrp, ptrc)
!!!
ptrp => clm3%g%l%c%p%pwf%qflx_tran_veg
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_tran_veg
call p2c (num_nolakec, filter_nolakec, ptrp, ptrc)
ptrp => clm3%g%l%c%p%pwf%qflx_evap_grnd
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_evap_grnd
call p2c (num_nolakec, filter_nolakec, ptrp, ptrc)
ptrp => clm3%g%l%c%p%pwf%qflx_dew_grnd
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_dew_grnd
call p2c (num_nolakec, filter_nolakec, ptrp, ptrc)
ptrp => clm3%g%l%c%p%pwf%qflx_sub_snow
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_sub_snow
call p2c (num_nolakec, filter_nolakec, ptrp, ptrc)
ptrp => clm3%g%l%c%p%pwf%qflx_dew_snow
ptrc => clm3%g%l%c%cwf%pwf_a%qflx_dew_snow
call p2c (num_nolakec, filter_nolakec, ptrp, ptrc)
end subroutine pft2col
end module pft2colMod
!===============================================================================
! SVN $Id: shr_orb_mod.F90 6752 2007-10-04 21:02:15Z jwolfe $
! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_090706b/shr/shr_orb_mod.F90 $
!===============================================================================
MODULE shr_orb_mod 2,3
use shr_kind_mod
use shr_const_mod
use module_cam_support, only: endrun
IMPLICIT none
!----------------------------------------------------------------------------
! PUBLIC: Interfaces and global data
!----------------------------------------------------------------------------
public :: shr_orb_cosz
public :: shr_orb_params
public :: shr_orb_decl
! public :: shr_orb_print
real (SHR_KIND_R8),public,parameter :: SHR_ORB_UNDEF_REAL = 1.e36_SHR_KIND_R8 ! undefined real
integer,public,parameter :: SHR_ORB_UNDEF_INT = 2000000000 ! undefined int
!----------------------------------------------------------------------------
! PRIVATE: by default everything else is private to this module
!----------------------------------------------------------------------------
private
real (SHR_KIND_R8),parameter :: pi = SHR_CONST_PI
real (SHR_KIND_R8),parameter :: SHR_ORB_ECCEN_MIN = 0.0_SHR_KIND_R8 ! min value for eccen
real (SHR_KIND_R8),parameter :: SHR_ORB_ECCEN_MAX = 0.1_SHR_KIND_R8 ! max value for eccen
real (SHR_KIND_R8),parameter :: SHR_ORB_OBLIQ_MIN = -90.0_SHR_KIND_R8 ! min value for obliq
real (SHR_KIND_R8),parameter :: SHR_ORB_OBLIQ_MAX = +90.0_SHR_KIND_R8 ! max value for obliq
real (SHR_KIND_R8),parameter :: SHR_ORB_MVELP_MIN = 0.0_SHR_KIND_R8 ! min value for mvelp
real (SHR_KIND_R8),parameter :: SHR_ORB_MVELP_MAX = 360.0_SHR_KIND_R8 ! max value for mvelp
!===============================================================================
CONTAINS
!===============================================================================
real(SHR_KIND_R8) FUNCTION shr_orb_cosz(jday,lat,lon,declin)
!----------------------------------------------------------------------------
!
! FUNCTION to return the cosine of the solar zenith angle.
! Assumes 365.0 days/year.
!
!--------------- Code History -----------------------------------------------
!
! Original Author: Brian Kauffman
! Date: Jan/98
! History: adapted from statement FUNCTION in share/orb_cosz.h
!
!----------------------------------------------------------------------------
real (SHR_KIND_R8),intent(in) :: jday ! Julian cal day (1.xx to 365.xx)
real (SHR_KIND_R8),intent(in) :: lat ! Centered latitude (radians)
real (SHR_KIND_R8),intent(in) :: lon ! Centered longitude (radians)
real (SHR_KIND_R8),intent(in) :: declin ! Solar declination (radians)
!----------------------------------------------------------------------------
shr_orb_cosz = sin(lat)*sin(declin) - &
& cos(lat)*cos(declin)*cos(jday*2.0_SHR_KIND_R8*pi + lon)
END FUNCTION shr_orb_cosz
!===============================================================================
SUBROUTINE shr_orb_params( iyear_AD , eccen , obliq , mvelp , & 1,1
& obliqr , lambm0 , mvelpp)
!-------------------------------------------------------------------------------
!
! Calculate earths orbital parameters using Dave Threshers formula which
! came from Berger, Andre. 1978 "A Simple Algorithm to Compute Long-Term
! Variations of Daily Insolation". Contribution 18, Institute of Astronomy
! and Geophysics, Universite Catholique de Louvain, Louvain-la-Neuve, Belgium
!
!------------------------------Code history-------------------------------------
!
! Original Author: Erik Kluzek
! Date: Oct/97
!
!-------------------------------------------------------------------------------
!----------------------------- Arguments ------------------------------------
real (SHR_KIND_R8),intent(inout) :: eccen ! orbital eccentricity
real (SHR_KIND_R8),intent(inout) :: obliq ! obliquity in degrees
real (SHR_KIND_R8),intent(inout) :: mvelp ! moving vernal equinox long
integer,intent(in) :: iyear_AD ! Year to calculate orbit for
real (SHR_KIND_R8),intent(out) :: obliqr ! Earths obliquity in rad
real (SHR_KIND_R8),intent(out) :: lambm0 ! Mean long of perihelion at
! vernal equinox (radians)
real (SHR_KIND_R8),intent(out) :: mvelpp ! moving vernal equinox long
! of perihelion plus pi (rad)
!------------------------------ Parameters ----------------------------------
integer,parameter :: poblen =47 ! # of elements in series wrt obliquity
integer,parameter :: pecclen=19 ! # of elements in series wrt eccentricity
integer,parameter :: pmvelen=78 ! # of elements in series wrt vernal equinox
real (SHR_KIND_R8),parameter :: psecdeg = 1.0_SHR_KIND_R8/3600.0_SHR_KIND_R8 ! arc sec to deg conversion
real (SHR_KIND_R8) :: degrad = pi/180._SHR_KIND_R8 ! degree to radian conversion factor
real (SHR_KIND_R8) :: yb4_1950AD ! number of years before 1950 AD
! Cosine series data for computation of obliquity: amplitude (arc seconds),
! rate (arc seconds/year), phase (degrees).
real (SHR_KIND_R8), parameter :: obamp(poblen) = & ! amplitudes for obliquity cos series
& (/ -2462.2214466_SHR_KIND_R8, -857.3232075_SHR_KIND_R8, -629.3231835_SHR_KIND_R8, &
& -414.2804924_SHR_KIND_R8, -311.7632587_SHR_KIND_R8, 308.9408604_SHR_KIND_R8, &
& -162.5533601_SHR_KIND_R8, -116.1077911_SHR_KIND_R8, 101.1189923_SHR_KIND_R8, &
& -67.6856209_SHR_KIND_R8, 24.9079067_SHR_KIND_R8, 22.5811241_SHR_KIND_R8, &
& -21.1648355_SHR_KIND_R8, -15.6549876_SHR_KIND_R8, 15.3936813_SHR_KIND_R8, &
& 14.6660938_SHR_KIND_R8, -11.7273029_SHR_KIND_R8, 10.2742696_SHR_KIND_R8, &
& 6.4914588_SHR_KIND_R8, 5.8539148_SHR_KIND_R8, -5.4872205_SHR_KIND_R8, &
& -5.4290191_SHR_KIND_R8, 5.1609570_SHR_KIND_R8, 5.0786314_SHR_KIND_R8, &
& -4.0735782_SHR_KIND_R8, 3.7227167_SHR_KIND_R8, 3.3971932_SHR_KIND_R8, &
& -2.8347004_SHR_KIND_R8, -2.6550721_SHR_KIND_R8, -2.5717867_SHR_KIND_R8, &
& -2.4712188_SHR_KIND_R8, 2.4625410_SHR_KIND_R8, 2.2464112_SHR_KIND_R8, &
& -2.0755511_SHR_KIND_R8, -1.9713669_SHR_KIND_R8, -1.8813061_SHR_KIND_R8, &
& -1.8468785_SHR_KIND_R8, 1.8186742_SHR_KIND_R8, 1.7601888_SHR_KIND_R8, &
& -1.5428851_SHR_KIND_R8, 1.4738838_SHR_KIND_R8, -1.4593669_SHR_KIND_R8, &
& 1.4192259_SHR_KIND_R8, -1.1818980_SHR_KIND_R8, 1.1756474_SHR_KIND_R8, &
& -1.1316126_SHR_KIND_R8, 1.0896928_SHR_KIND_R8/)
real (SHR_KIND_R8), parameter :: obrate(poblen) = & ! rates for obliquity cosine series
& (/ 31.609974_SHR_KIND_R8, 32.620504_SHR_KIND_R8, 24.172203_SHR_KIND_R8, &
& 31.983787_SHR_KIND_R8, 44.828336_SHR_KIND_R8, 30.973257_SHR_KIND_R8, &
& 43.668246_SHR_KIND_R8, 32.246691_SHR_KIND_R8, 30.599444_SHR_KIND_R8, &
& 42.681324_SHR_KIND_R8, 43.836462_SHR_KIND_R8, 47.439436_SHR_KIND_R8, &
& 63.219948_SHR_KIND_R8, 64.230478_SHR_KIND_R8, 1.010530_SHR_KIND_R8, &
& 7.437771_SHR_KIND_R8, 55.782177_SHR_KIND_R8, 0.373813_SHR_KIND_R8, &
& 13.218362_SHR_KIND_R8, 62.583231_SHR_KIND_R8, 63.593761_SHR_KIND_R8, &
& 76.438310_SHR_KIND_R8, 45.815258_SHR_KIND_R8, 8.448301_SHR_KIND_R8, &
& 56.792707_SHR_KIND_R8, 49.747842_SHR_KIND_R8, 12.058272_SHR_KIND_R8, &
& 75.278220_SHR_KIND_R8, 65.241008_SHR_KIND_R8, 64.604291_SHR_KIND_R8, &
& 1.647247_SHR_KIND_R8, 7.811584_SHR_KIND_R8, 12.207832_SHR_KIND_R8, &
& 63.856665_SHR_KIND_R8, 56.155990_SHR_KIND_R8, 77.448840_SHR_KIND_R8, &
& 6.801054_SHR_KIND_R8, 62.209418_SHR_KIND_R8, 20.656133_SHR_KIND_R8, &
& 48.344406_SHR_KIND_R8, 55.145460_SHR_KIND_R8, 69.000539_SHR_KIND_R8, &
& 11.071350_SHR_KIND_R8, 74.291298_SHR_KIND_R8, 11.047742_SHR_KIND_R8, &
& 0.636717_SHR_KIND_R8, 12.844549_SHR_KIND_R8/)
real (SHR_KIND_R8), parameter :: obphas(poblen) = & ! phases for obliquity cosine series
& (/ 251.9025_SHR_KIND_R8, 280.8325_SHR_KIND_R8, 128.3057_SHR_KIND_R8, &
& 292.7252_SHR_KIND_R8, 15.3747_SHR_KIND_R8, 263.7951_SHR_KIND_R8, &
& 308.4258_SHR_KIND_R8, 240.0099_SHR_KIND_R8, 222.9725_SHR_KIND_R8, &
& 268.7809_SHR_KIND_R8, 316.7998_SHR_KIND_R8, 319.6024_SHR_KIND_R8, &
& 143.8050_SHR_KIND_R8, 172.7351_SHR_KIND_R8, 28.9300_SHR_KIND_R8, &
& 123.5968_SHR_KIND_R8, 20.2082_SHR_KIND_R8, 40.8226_SHR_KIND_R8, &
& 123.4722_SHR_KIND_R8, 155.6977_SHR_KIND_R8, 184.6277_SHR_KIND_R8, &
& 267.2772_SHR_KIND_R8, 55.0196_SHR_KIND_R8, 152.5268_SHR_KIND_R8, &
& 49.1382_SHR_KIND_R8, 204.6609_SHR_KIND_R8, 56.5233_SHR_KIND_R8, &
& 200.3284_SHR_KIND_R8, 201.6651_SHR_KIND_R8, 213.5577_SHR_KIND_R8, &
& 17.0374_SHR_KIND_R8, 164.4194_SHR_KIND_R8, 94.5422_SHR_KIND_R8, &
& 131.9124_SHR_KIND_R8, 61.0309_SHR_KIND_R8, 296.2073_SHR_KIND_R8, &
& 135.4894_SHR_KIND_R8, 114.8750_SHR_KIND_R8, 247.0691_SHR_KIND_R8, &
& 256.6114_SHR_KIND_R8, 32.1008_SHR_KIND_R8, 143.6804_SHR_KIND_R8, &
& 16.8784_SHR_KIND_R8, 160.6835_SHR_KIND_R8, 27.5932_SHR_KIND_R8, &
& 348.1074_SHR_KIND_R8, 82.6496_SHR_KIND_R8/)
! Cosine/sine series data for computation of eccentricity and fixed vernal
! equinox longitude of perihelion (fvelp): amplitude,
! rate (arc seconds/year), phase (degrees).
real (SHR_KIND_R8), parameter :: ecamp (pecclen) = & ! ampl for eccen/fvelp cos/sin series
& (/ 0.01860798_SHR_KIND_R8, 0.01627522_SHR_KIND_R8, -0.01300660_SHR_KIND_R8, &
& 0.00988829_SHR_KIND_R8, -0.00336700_SHR_KIND_R8, 0.00333077_SHR_KIND_R8, &
& -0.00235400_SHR_KIND_R8, 0.00140015_SHR_KIND_R8, 0.00100700_SHR_KIND_R8, &
& 0.00085700_SHR_KIND_R8, 0.00064990_SHR_KIND_R8, 0.00059900_SHR_KIND_R8, &
& 0.00037800_SHR_KIND_R8, -0.00033700_SHR_KIND_R8, 0.00027600_SHR_KIND_R8, &
& 0.00018200_SHR_KIND_R8, -0.00017400_SHR_KIND_R8, -0.00012400_SHR_KIND_R8, &
& 0.00001250_SHR_KIND_R8/)
real (SHR_KIND_R8), parameter :: ecrate(pecclen) = & ! rates for eccen/fvelp cos/sin series
& (/ 4.2072050_SHR_KIND_R8, 7.3460910_SHR_KIND_R8, 17.8572630_SHR_KIND_R8, &
& 17.2205460_SHR_KIND_R8, 16.8467330_SHR_KIND_R8, 5.1990790_SHR_KIND_R8, &
& 18.2310760_SHR_KIND_R8, 26.2167580_SHR_KIND_R8, 6.3591690_SHR_KIND_R8, &
& 16.2100160_SHR_KIND_R8, 3.0651810_SHR_KIND_R8, 16.5838290_SHR_KIND_R8, &
& 18.4939800_SHR_KIND_R8, 6.1909530_SHR_KIND_R8, 18.8677930_SHR_KIND_R8, &
& 17.4255670_SHR_KIND_R8, 6.1860010_SHR_KIND_R8, 18.4174410_SHR_KIND_R8, &
& 0.6678630_SHR_KIND_R8/)
real (SHR_KIND_R8), parameter :: ecphas(pecclen) = & ! phases for eccen/fvelp cos/sin series
& (/ 28.620089_SHR_KIND_R8, 193.788772_SHR_KIND_R8, 308.307024_SHR_KIND_R8, &
& 320.199637_SHR_KIND_R8, 279.376984_SHR_KIND_R8, 87.195000_SHR_KIND_R8, &
& 349.129677_SHR_KIND_R8, 128.443387_SHR_KIND_R8, 154.143880_SHR_KIND_R8, &
& 291.269597_SHR_KIND_R8, 114.860583_SHR_KIND_R8, 332.092251_SHR_KIND_R8, &
& 296.414411_SHR_KIND_R8, 145.769910_SHR_KIND_R8, 337.237063_SHR_KIND_R8, &
& 152.092288_SHR_KIND_R8, 126.839891_SHR_KIND_R8, 210.667199_SHR_KIND_R8, &
& 72.108838_SHR_KIND_R8/)
! Sine series data for computation of moving vernal equinox longitude of
! perihelion: amplitude (arc seconds), rate (arc sec/year), phase (degrees).
real (SHR_KIND_R8), parameter :: mvamp (pmvelen) = & ! amplitudes for mvelp sine series
& (/ 7391.0225890_SHR_KIND_R8, 2555.1526947_SHR_KIND_R8, 2022.7629188_SHR_KIND_R8, &
& -1973.6517951_SHR_KIND_R8, 1240.2321818_SHR_KIND_R8, 953.8679112_SHR_KIND_R8, &
& -931.7537108_SHR_KIND_R8, 872.3795383_SHR_KIND_R8, 606.3544732_SHR_KIND_R8, &
& -496.0274038_SHR_KIND_R8, 456.9608039_SHR_KIND_R8, 346.9462320_SHR_KIND_R8, &
& -305.8412902_SHR_KIND_R8, 249.6173246_SHR_KIND_R8, -199.1027200_SHR_KIND_R8, &
& 191.0560889_SHR_KIND_R8, -175.2936572_SHR_KIND_R8, 165.9068833_SHR_KIND_R8, &
& 161.1285917_SHR_KIND_R8, 139.7878093_SHR_KIND_R8, -133.5228399_SHR_KIND_R8, &
& 117.0673811_SHR_KIND_R8, 104.6907281_SHR_KIND_R8, 95.3227476_SHR_KIND_R8, &
& 86.7824524_SHR_KIND_R8, 86.0857729_SHR_KIND_R8, 70.5893698_SHR_KIND_R8, &
& -69.9719343_SHR_KIND_R8, -62.5817473_SHR_KIND_R8, 61.5450059_SHR_KIND_R8, &
& -57.9364011_SHR_KIND_R8, 57.1899832_SHR_KIND_R8, -57.0236109_SHR_KIND_R8, &
& -54.2119253_SHR_KIND_R8, 53.2834147_SHR_KIND_R8, 52.1223575_SHR_KIND_R8, &
& -49.0059908_SHR_KIND_R8, -48.3118757_SHR_KIND_R8, -45.4191685_SHR_KIND_R8, &
& -42.2357920_SHR_KIND_R8, -34.7971099_SHR_KIND_R8, 34.4623613_SHR_KIND_R8, &
& -33.8356643_SHR_KIND_R8, 33.6689362_SHR_KIND_R8, -31.2521586_SHR_KIND_R8, &
& -30.8798701_SHR_KIND_R8, 28.4640769_SHR_KIND_R8, -27.1960802_SHR_KIND_R8, &
& 27.0860736_SHR_KIND_R8, -26.3437456_SHR_KIND_R8, 24.7253740_SHR_KIND_R8, &
& 24.6732126_SHR_KIND_R8, 24.4272733_SHR_KIND_R8, 24.0127327_SHR_KIND_R8, &
& 21.7150294_SHR_KIND_R8, -21.5375347_SHR_KIND_R8, 18.1148363_SHR_KIND_R8, &
& -16.9603104_SHR_KIND_R8, -16.1765215_SHR_KIND_R8, 15.5567653_SHR_KIND_R8, &
& 15.4846529_SHR_KIND_R8, 15.2150632_SHR_KIND_R8, 14.5047426_SHR_KIND_R8, &
& -14.3873316_SHR_KIND_R8, 13.1351419_SHR_KIND_R8, 12.8776311_SHR_KIND_R8, &
& 11.9867234_SHR_KIND_R8, 11.9385578_SHR_KIND_R8, 11.7030822_SHR_KIND_R8, &
& 11.6018181_SHR_KIND_R8, -11.2617293_SHR_KIND_R8, -10.4664199_SHR_KIND_R8, &
& 10.4333970_SHR_KIND_R8, -10.2377466_SHR_KIND_R8, 10.1934446_SHR_KIND_R8, &
& -10.1280191_SHR_KIND_R8, 10.0289441_SHR_KIND_R8, -10.0034259_SHR_KIND_R8/)
real (SHR_KIND_R8), parameter :: mvrate(pmvelen) = & ! rates for mvelp sine series
& (/ 31.609974_SHR_KIND_R8, 32.620504_SHR_KIND_R8, 24.172203_SHR_KIND_R8, &
& 0.636717_SHR_KIND_R8, 31.983787_SHR_KIND_R8, 3.138886_SHR_KIND_R8, &
& 30.973257_SHR_KIND_R8, 44.828336_SHR_KIND_R8, 0.991874_SHR_KIND_R8, &
& 0.373813_SHR_KIND_R8, 43.668246_SHR_KIND_R8, 32.246691_SHR_KIND_R8, &
& 30.599444_SHR_KIND_R8, 2.147012_SHR_KIND_R8, 10.511172_SHR_KIND_R8, &
& 42.681324_SHR_KIND_R8, 13.650058_SHR_KIND_R8, 0.986922_SHR_KIND_R8, &
& 9.874455_SHR_KIND_R8, 13.013341_SHR_KIND_R8, 0.262904_SHR_KIND_R8, &
& 0.004952_SHR_KIND_R8, 1.142024_SHR_KIND_R8, 63.219948_SHR_KIND_R8, &
& 0.205021_SHR_KIND_R8, 2.151964_SHR_KIND_R8, 64.230478_SHR_KIND_R8, &
& 43.836462_SHR_KIND_R8, 47.439436_SHR_KIND_R8, 1.384343_SHR_KIND_R8, &
& 7.437771_SHR_KIND_R8, 18.829299_SHR_KIND_R8, 9.500642_SHR_KIND_R8, &
& 0.431696_SHR_KIND_R8, 1.160090_SHR_KIND_R8, 55.782177_SHR_KIND_R8, &
& 12.639528_SHR_KIND_R8, 1.155138_SHR_KIND_R8, 0.168216_SHR_KIND_R8, &
& 1.647247_SHR_KIND_R8, 10.884985_SHR_KIND_R8, 5.610937_SHR_KIND_R8, &
& 12.658184_SHR_KIND_R8, 1.010530_SHR_KIND_R8, 1.983748_SHR_KIND_R8, &
& 14.023871_SHR_KIND_R8, 0.560178_SHR_KIND_R8, 1.273434_SHR_KIND_R8, &
& 12.021467_SHR_KIND_R8, 62.583231_SHR_KIND_R8, 63.593761_SHR_KIND_R8, &
& 76.438310_SHR_KIND_R8, 4.280910_SHR_KIND_R8, 13.218362_SHR_KIND_R8, &
& 17.818769_SHR_KIND_R8, 8.359495_SHR_KIND_R8, 56.792707_SHR_KIND_R8, &
& 8.448301_SHR_KIND_R8, 1.978796_SHR_KIND_R8, 8.863925_SHR_KIND_R8, &
& 0.186365_SHR_KIND_R8, 8.996212_SHR_KIND_R8, 6.771027_SHR_KIND_R8, &
& 45.815258_SHR_KIND_R8, 12.002811_SHR_KIND_R8, 75.278220_SHR_KIND_R8, &
& 65.241008_SHR_KIND_R8, 18.870667_SHR_KIND_R8, 22.009553_SHR_KIND_R8, &
& 64.604291_SHR_KIND_R8, 11.498094_SHR_KIND_R8, 0.578834_SHR_KIND_R8, &
& 9.237738_SHR_KIND_R8, 49.747842_SHR_KIND_R8, 2.147012_SHR_KIND_R8, &
& 1.196895_SHR_KIND_R8, 2.133898_SHR_KIND_R8, 0.173168_SHR_KIND_R8/)
real (SHR_KIND_R8), parameter :: mvphas(pmvelen) = & ! phases for mvelp sine series
& (/ 251.9025_SHR_KIND_R8, 280.8325_SHR_KIND_R8, 128.3057_SHR_KIND_R8, &
& 348.1074_SHR_KIND_R8, 292.7252_SHR_KIND_R8, 165.1686_SHR_KIND_R8, &
& 263.7951_SHR_KIND_R8, 15.3747_SHR_KIND_R8, 58.5749_SHR_KIND_R8, &
& 40.8226_SHR_KIND_R8, 308.4258_SHR_KIND_R8, 240.0099_SHR_KIND_R8, &
& 222.9725_SHR_KIND_R8, 106.5937_SHR_KIND_R8, 114.5182_SHR_KIND_R8, &
& 268.7809_SHR_KIND_R8, 279.6869_SHR_KIND_R8, 39.6448_SHR_KIND_R8, &
& 126.4108_SHR_KIND_R8, 291.5795_SHR_KIND_R8, 307.2848_SHR_KIND_R8, &
& 18.9300_SHR_KIND_R8, 273.7596_SHR_KIND_R8, 143.8050_SHR_KIND_R8, &
& 191.8927_SHR_KIND_R8, 125.5237_SHR_KIND_R8, 172.7351_SHR_KIND_R8, &
& 316.7998_SHR_KIND_R8, 319.6024_SHR_KIND_R8, 69.7526_SHR_KIND_R8, &
& 123.5968_SHR_KIND_R8, 217.6432_SHR_KIND_R8, 85.5882_SHR_KIND_R8, &
& 156.2147_SHR_KIND_R8, 66.9489_SHR_KIND_R8, 20.2082_SHR_KIND_R8, &
& 250.7568_SHR_KIND_R8, 48.0188_SHR_KIND_R8, 8.3739_SHR_KIND_R8, &
& 17.0374_SHR_KIND_R8, 155.3409_SHR_KIND_R8, 94.1709_SHR_KIND_R8, &
& 221.1120_SHR_KIND_R8, 28.9300_SHR_KIND_R8, 117.1498_SHR_KIND_R8, &
& 320.5095_SHR_KIND_R8, 262.3602_SHR_KIND_R8, 336.2148_SHR_KIND_R8, &
& 233.0046_SHR_KIND_R8, 155.6977_SHR_KIND_R8, 184.6277_SHR_KIND_R8, &
& 267.2772_SHR_KIND_R8, 78.9281_SHR_KIND_R8, 123.4722_SHR_KIND_R8, &
& 188.7132_SHR_KIND_R8, 180.1364_SHR_KIND_R8, 49.1382_SHR_KIND_R8, &
& 152.5268_SHR_KIND_R8, 98.2198_SHR_KIND_R8, 97.4808_SHR_KIND_R8, &
& 221.5376_SHR_KIND_R8, 168.2438_SHR_KIND_R8, 161.1199_SHR_KIND_R8, &
& 55.0196_SHR_KIND_R8, 262.6495_SHR_KIND_R8, 200.3284_SHR_KIND_R8, &
& 201.6651_SHR_KIND_R8, 294.6547_SHR_KIND_R8, 99.8233_SHR_KIND_R8, &
& 213.5577_SHR_KIND_R8, 154.1631_SHR_KIND_R8, 232.7153_SHR_KIND_R8, &
& 138.3034_SHR_KIND_R8, 204.6609_SHR_KIND_R8, 106.5938_SHR_KIND_R8, &
& 250.4676_SHR_KIND_R8, 332.3345_SHR_KIND_R8, 27.3039_SHR_KIND_R8/)
!---------------------------Local variables----------------------------------
integer :: i ! Index for series summations
real (SHR_KIND_R8) :: obsum ! Obliquity series summation
real (SHR_KIND_R8) :: cossum ! Cos series summation for eccentricity/fvelp
real (SHR_KIND_R8) :: sinsum ! Sin series summation for eccentricity/fvelp
real (SHR_KIND_R8) :: fvelp ! Fixed vernal equinox long of perihelion
real (SHR_KIND_R8) :: mvsum ! mvelp series summation
real (SHR_KIND_R8) :: beta ! Intermediate argument for lambm0
real (SHR_KIND_R8) :: years ! Years to time of interest ( pos <=> future)
real (SHR_KIND_R8) :: eccen2 ! eccentricity squared
real (SHR_KIND_R8) :: eccen3 ! eccentricity cubed
!-------------------------- Formats -----------------------------------------
! character(*),parameter :: svnID = "SVN " // &
! "$Id: shr_orb_mod.F90 6752 2007-10-04 21:02:15Z jwolfe $"
! character(*),parameter :: svnURL = "SVN <unknown URL>"
! character(*),parameter :: svnURL = "SVN " // &
! "$URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_090706b/shr/shr_orb_mod.F90 $"
! character(len=*),parameter :: F00 = "('(shr_orb_params) ',4a)"
! character(len=*),parameter :: F01 = "('(shr_orb_params) ',a,i9)"
! character(len=*),parameter :: F02 = "('(shr_orb_params) ',a,f6.3)"
! character(len=*),parameter :: F03 = "('(shr_orb_params) ',a,es14.6)"
!----------------------------------------------------------------------------
! radinp and algorithms below will need a degree to radian conversion factor
! if ( log_print .and. s_loglev > 0 ) then
! write(s_logunit,F00) 'Calculate characteristics of the orbit:'
! write(s_logunit,F00) svnID
! write(s_logunit,F00) svnURL
! end if
! Check for flag to use input orbit parameters
! IF ( iyear_AD == SHR_ORB_UNDEF_INT ) THEN
! Check input obliq, eccen, and mvelp to ensure reasonable
! if( obliq == SHR_ORB_UNDEF_REAL )then
! write(s_logunit,F00) 'Have to specify orbital parameters:'
! write(s_logunit,F00) 'Either set: iyear_AD, OR [obliq, eccen, and mvelp]:'
! write(s_logunit,F00) 'iyear_AD is the year to simulate orbit for (ie. 1950): '
! write(s_logunit,F00) 'obliq, eccen, mvelp specify the orbit directly:'
! write(s_logunit,F00) 'The AMIP II settings (for a 1995 orbit) are: '
! write(s_logunit,F00) ' obliq = 23.4441'
! write(s_logunit,F00) ' eccen = 0.016715'
! write(s_logunit,F00) ' mvelp = 102.7'
! call shr_sys_abort()
! else if ( log_print ) then
! write(s_logunit,F00) 'Use input orbital parameters: '
! end if
! if( (obliq < SHR_ORB_OBLIQ_MIN).or.(obliq > SHR_ORB_OBLIQ_MAX) ) then
! write(s_logunit,F03) 'Input obliquity unreasonable: ', obliq
! call shr_sys_abort()
! end if
! if( (eccen < SHR_ORB_ECCEN_MIN).or.(eccen > SHR_ORB_ECCEN_MAX) ) then
! write(s_logunit,F03) 'Input eccentricity unreasonable: ', eccen
! call shr_sys_abort()
! end if
! if( (mvelp < SHR_ORB_MVELP_MIN).or.(mvelp > SHR_ORB_MVELP_MAX) ) then
! write(s_logunit,F03) 'Input mvelp unreasonable: ' , mvelp
! call shr_sys_abort()
! end if
! eccen2 = eccen*eccen
! eccen3 = eccen2*eccen
! ELSE ! Otherwise calculate based on years before present
! if ( log_print .and. s_loglev > 0) then
! write(s_logunit,F01) 'Calculate orbit for year: ' , iyear_AD
! end if
yb4_1950AD = 1950.0_SHR_KIND_R8 - real(iyear_AD,SHR_KIND_R8)
if ( abs(yb4_1950AD) .gt. 1000000.0_SHR_KIND_R8 )then
! write(s_logunit,F00) 'orbit only valid for years+-1000000'
! write(s_logunit,F00) 'Relative to 1950 AD'
! write(s_logunit,F03) '# of years before 1950: ',yb4_1950AD
! write(s_logunit,F01) 'Year to simulate was : ',iyear_AD
! call shr_sys_abort()
write(6,*) 'Error in shr_orb, abs(yb4_1950AD) .gt. 1000000.0_SHR_KIND_R8'
call endrun()
end if
! The following calculates the earths obliquity, orbital eccentricity
! (and various powers of it) and vernal equinox mean longitude of
! perihelion for years in the past (future = negative of years past),
! using constants (see parameter section) given in the program of:
!
! Berger, Andre. 1978 A Simple Algorithm to Compute Long-Term Variations
! of Daily Insolation. Contribution 18, Institute of Astronomy and
! Geophysics, Universite Catholique de Louvain, Louvain-la-Neuve, Belgium.
!
! and formulas given in the paper (where less precise constants are also
! given):
!
! Berger, Andre. 1978. Long-Term Variations of Daily Insolation and
! Quaternary Climatic Changes. J. of the Atmo. Sci. 35:2362-2367
!
! The algorithm is valid only to 1,000,000 years past or hence.
! For a solution valid to 5-10 million years past see the above author.
! Algorithm below is better for years closer to present than is the
! 5-10 million year solution.
!
! Years to time of interest must be negative of years before present
! (1950) in formulas that follow.
years = - yb4_1950AD
! In the summations below, cosine or sine arguments, which end up in
! degrees, must be converted to radians via multiplication by degrad.
!
! Summation of cosine series for obliquity (epsilon in Berger 1978) in
! degrees. Convert the amplitudes and rates, which are in arc secs, into
! degrees via multiplication by psecdeg (arc seconds to degrees conversion
! factor). For obliq, first term is Berger 1978 epsilon star; second
! term is series summation in degrees.
obsum = 0.0_SHR_KIND_R8
do i = 1, poblen
obsum = obsum + obamp(i)*psecdeg*cos((obrate(i)*psecdeg*years + &
& obphas(i))*degrad)
end do
obliq = 23.320556_SHR_KIND_R8 + obsum
! Summation of cosine and sine series for computation of eccentricity
! (eccen; e in Berger 1978) and fixed vernal equinox longitude of
! perihelion (fvelp; pi in Berger 1978), which is used for computation
! of moving vernal equinox longitude of perihelion. Convert the rates,
! which are in arc seconds, into degrees via multiplication by psecdeg.
cossum = 0.0_SHR_KIND_R8
do i = 1, pecclen
cossum = cossum+ecamp(i)*cos((ecrate(i)*psecdeg*years+ecphas(i))*degrad)
end do
sinsum = 0.0_SHR_KIND_R8
do i = 1, pecclen
sinsum = sinsum+ecamp(i)*sin((ecrate(i)*psecdeg*years+ecphas(i))*degrad)
end do
! Use summations to calculate eccentricity
eccen2 = cossum*cossum + sinsum*sinsum
eccen = sqrt(eccen2)
eccen3 = eccen2*eccen
! A series of cases for fvelp, which is in radians.
if (abs(cossum) .le. 1.0E-8_SHR_KIND_R8) then
if (sinsum .eq. 0.0_SHR_KIND_R8) then
fvelp = 0.0_SHR_KIND_R8
else if (sinsum .lt. 0.0_SHR_KIND_R8) then
fvelp = 1.5_SHR_KIND_R8*pi
else if (sinsum .gt. 0.0_SHR_KIND_R8) then
fvelp = .5_SHR_KIND_R8*pi
endif
else if (cossum .lt. 0.0_SHR_KIND_R8) then
fvelp = atan(sinsum/cossum) + pi
else if (cossum .gt. 0.0_SHR_KIND_R8) then
if (sinsum .lt. 0.0_SHR_KIND_R8) then
fvelp = atan(sinsum/cossum) + 2.0_SHR_KIND_R8*pi
else
fvelp = atan(sinsum/cossum)
endif
endif
! Summation of sin series for computation of moving vernal equinox long
! of perihelion (mvelp; omega bar in Berger 1978) in degrees. For mvelp,
! first term is fvelp in degrees; second term is Berger 1978 psi bar
! times years and in degrees; third term is Berger 1978 zeta; fourth
! term is series summation in degrees. Convert the amplitudes and rates,
! which are in arc seconds, into degrees via multiplication by psecdeg.
! Series summation plus second and third terms constitute Berger 1978
! psi, which is the general precession.
mvsum = 0.0_SHR_KIND_R8
do i = 1, pmvelen
mvsum = mvsum + mvamp(i)*psecdeg*sin((mvrate(i)*psecdeg*years + &
& mvphas(i))*degrad)
end do
mvelp = fvelp/degrad + 50.439273_SHR_KIND_R8*psecdeg*years + 3.392506_SHR_KIND_R8 + mvsum
! Cases to make sure mvelp is between 0 and 360.
do while (mvelp .lt. 0.0_SHR_KIND_R8)
mvelp = mvelp + 360.0_SHR_KIND_R8
end do
do while (mvelp .ge. 360.0_SHR_KIND_R8)
mvelp = mvelp - 360.0_SHR_KIND_R8
end do
! END IF ! end of test on whether to calculate or use input orbital params
! Orbit needs the obliquity in radians
obliqr = obliq*degrad
! 180 degrees must be added to mvelp since observations are made from the
! earth and the sun is considered (wrongly for the algorithm) to go around
! the earth. For a more graphic explanation see Appendix B in:
!
! A. Berger, M. Loutre and C. Tricot. 1993. Insolation and Earth Orbital
! Periods. J. of Geophysical Research 98:10,341-10,362.
!
! Additionally, orbit will need this value in radians. So mvelp becomes
! mvelpp (mvelp plus pi)
mvelpp = (mvelp + 180._SHR_KIND_R8)*degrad
! Set up an argument used several times in lambm0 calculation ahead.
beta = sqrt(1._SHR_KIND_R8 - eccen2)
! The mean longitude at the vernal equinox (lambda m nought in Berger
! 1978; in radians) is calculated from the following formula given in
! Berger 1978. At the vernal equinox the true longitude (lambda in Berger
! 1978) is 0.
lambm0 = 2._SHR_KIND_R8*((.5_SHR_KIND_R8*eccen + .125_SHR_KIND_R8*eccen3)*(1._SHR_KIND_R8 + beta)*sin(mvelpp) &
& - .250_SHR_KIND_R8*eccen2*(.5_SHR_KIND_R8 + beta)*sin(2._SHR_KIND_R8*mvelpp) &
& + .125_SHR_KIND_R8*eccen3*(1._SHR_KIND_R8/3._SHR_KIND_R8 + beta)*sin(3._SHR_KIND_R8*mvelpp))
! if ( log_print ) then
! write(s_logunit,F03) '------ Computed Orbital Parameters ------'
! write(s_logunit,F03) 'Eccentricity = ',eccen
! write(s_logunit,F03) 'Obliquity (deg) = ',obliq
! write(s_logunit,F03) 'Obliquity (rad) = ',obliqr
! write(s_logunit,F03) 'Long of perh(deg) = ',mvelp
! write(s_logunit,F03) 'Long of perh(rad) = ',mvelpp
! write(s_logunit,F03) 'Long at v.e.(rad) = ',lambm0
! write(s_logunit,F03) '-----------------------------------------'
! end if
END SUBROUTINE shr_orb_params
!===============================================================================
SUBROUTINE shr_orb_decl(calday ,eccen ,mvelpp ,lambm0 ,obliqr ,delta ,eccf) 2
!-------------------------------------------------------------------------------
!
! Compute earth/orbit parameters using formula suggested by
! Duane Thresher.
!
!---------------------------Code history----------------------------------------
!
! Original version: Erik Kluzek
! Date: Oct/1997
!
!-------------------------------------------------------------------------------
!------------------------------Arguments--------------------------------
real (SHR_KIND_R8),intent(in) :: calday ! Calendar day, including fraction
real (SHR_KIND_R8),intent(in) :: eccen ! Eccentricity
real (SHR_KIND_R8),intent(in) :: obliqr ! Earths obliquity in radians
real (SHR_KIND_R8),intent(in) :: lambm0 ! Mean long of perihelion at the
! vernal equinox (radians)
real (SHR_KIND_R8),intent(in) :: mvelpp ! moving vernal equinox longitude
! of perihelion plus pi (radians)
real (SHR_KIND_R8),intent(out) :: delta ! Solar declination angle in rad
real (SHR_KIND_R8),intent(out) :: eccf ! Earth-sun distance factor (ie. (1/r)**2)
!---------------------------Local variables-----------------------------
real (SHR_KIND_R8),parameter :: dayspy = 365.0_SHR_KIND_R8 ! days per year
real (SHR_KIND_R8),parameter :: ve = 80.5_SHR_KIND_R8 ! Calday of vernal equinox
! assumes Jan 1 = calday 1
real (SHR_KIND_R8) :: lambm ! Lambda m, mean long of perihelion (rad)
real (SHR_KIND_R8) :: lmm ! Intermediate argument involving lambm
real (SHR_KIND_R8) :: lamb ! Lambda, the earths long of perihelion
real (SHR_KIND_R8) :: invrho ! Inverse normalized sun/earth distance
real (SHR_KIND_R8) :: sinl ! Sine of lmm
! Compute eccentricity factor and solar declination using
! day value where a round day (such as 213.0) refers to 0z at
! Greenwich longitude.
!
! Use formulas from Berger, Andre 1978: Long-Term Variations of Daily
! Insolation and Quaternary Climatic Changes. J. of the Atmo. Sci.
! 35:2362-2367.
!
! To get the earths true longitude (position in orbit; lambda in Berger
! 1978) which is necessary to find the eccentricity factor and declination,
! must first calculate the mean longitude (lambda m in Berger 1978) at
! the present day. This is done by adding to lambm0 (the mean longitude
! at the vernal equinox, set as March 21 at noon, when lambda=0; in radians)
! an increment (delta lambda m in Berger 1978) that is the number of
! days past or before (a negative increment) the vernal equinox divided by
! the days in a model year times the 2*pi radians in a complete orbit.
lambm = lambm0 + (calday - ve)*2._SHR_KIND_R8*pi/dayspy
lmm = lambm - mvelpp
! The earths true longitude, in radians, is then found from
! the formula in Berger 1978:
sinl = sin(lmm)
lamb = lambm + eccen*(2._SHR_KIND_R8*sinl + eccen*(1.25_SHR_KIND_R8*sin(2._SHR_KIND_R8*lmm) &
& + eccen*((13.0_SHR_KIND_R8/12.0_SHR_KIND_R8)*sin(3._SHR_KIND_R8*lmm) - 0.25_SHR_KIND_R8*sinl)))
! Using the obliquity, eccentricity, moving vernal equinox longitude of
! perihelion (plus), and earths true longitude, the declination (delta)
! and the normalized earth/sun distance (rho in Berger 1978; actually inverse
! rho will be used), and thus the eccentricity factor (eccf), can be
! calculated from formulas given in Berger 1978.
invrho = (1._SHR_KIND_R8 + eccen*cos(lamb - mvelpp)) / (1._SHR_KIND_R8 - eccen*eccen)
! Set solar declination and eccentricity factor
delta = asin(sin(obliqr)*sin(lamb))
eccf = invrho*invrho
return
END SUBROUTINE shr_orb_decl
!===============================================================================
END MODULE shr_orb_mod
module surfFileMod 1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: surfFileMod
!
! !DESCRIPTION:
! Contains methods for reading in surface data file and determining
! two-dimensional subgrid weights as well as writing out new surface
! dataset. When reading in the surface dataset, determines array
! which sets the PFT for each of the [maxpatch] patches and
! array which sets the relative abundance of the PFT.
! Also fills in the PFTs for vegetated portion of each grid cell.
! Fractional areas for these points pertain to "vegetated"
! area not to total grid area. Need to adjust them for fraction of grid
! that is vegetated. Also fills in urban, lake, wetland, and glacier patches.
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: surfrd !Read surface dataset and determine subgrid weights
! public :: surfwrt !Write surface dataset
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: surfrd
!
! !INTERFACE:
!Yaqiong Lu 01/13/2009
subroutine surfrd(organicxy,efisopxy,gtixy,ilx,jlx,iveg,isl,lndmsk) 1,38
!
! !DESCRIPTION:
! Read the surface dataset and create subgrid weights.
! The model's surface dataset recognizes 5 basic land cover types within
! a grid cell: lake, wetland, urban, glacier, and vegetated. The vegetated
! portion of the grid cell is comprised of up to [maxpatch_pft] PFTs. These
! subgrid patches are read in explicitly for each grid cell. This is in
! contrast to LSMv1, where the PFTs were built implicitly from biome types.
! Read surface boundary data with the exception of
! monthly lai,sai,and heights at top and bottom of canopy
! on [lsmlon] x [lsmlat] grid.
! o real edges of grid
! o integer number of longitudes per latitude
! o real latitude of grid cell (degrees)
! o real longitude of grid cell (degrees)
! o integer surface type: 0 = ocean or 1 = land
! o integer soil color (1 to 9) for use with soil albedos
! o real soil texture, %sand, for thermal and hydraulic properties
! o real soil texture, %clay, for thermal and hydraulic properties
! o real % of cell covered by lake for use as subgrid patch
! o real % of cell covered by wetland for use as subgrid patch
! o real % of cell that is urban for use as subgrid patch
! o real % of cell that is glacier for use as subgrid patch
! o integer PFTs
! o real % abundance PFTs (as a percent of vegetated area)
!
! OFFLINE MODE ONLY:
! Surface grid edges -- Grids do not have to be global.
! If grid is read in from dataset, grid is assumed to be global
! (does not have to be regular, however)
! If grid is generated by model, grid does not have to be global but must then
! define the north, east, south, and west edges:
!
! o lsmedge(1) = northern edge of grid (degrees): > -90 and <= 90
! o lsmedge(2) = eastern edge of grid (degrees) : see following notes
! o lsmedge(3) = southern edge of grid (degrees): >= -90 and < 90
! o lsmedge(4) = western edge of grid (degrees) : see following notes
!
! For partial grids, northern and southern edges are any latitude
! between 90 (North Pole) and -90 (South Pole). Western and eastern
! edges are any longitude between -180 and 180, with longitudes
! west of Greenwich negative. That is, western edge >= -180 and < 180;
! eastern edge > western edge and <= 180.
!
! For global grids, northern and southern edges are 90 (North Pole)
! and -90 (South Pole). The western and eastern edges depend on
! whether the grid starts at Dateline or Greenwich. Regardless,
! these edges must span 360 degrees. Examples:
!
! West edge East edge
! ---------------------------------------------------
! (1) Dateline : -180 to 180 (negative W of Greenwich)
! (2) Greenwich (centered): 0 - dx/2 to 360 - dx/2
!
! Grid 1 is the grid for offline mode
! Grid 2 is the grid for cam and csm mode since the NCAR CAM
! starts at Greenwich, centered on Greenwich
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varpar !parameters
!use clm_varsur !surface data !BSINGH:02/04/2013: Commented out this use statement as it is repeated below
use pftvarcon, only : noveg, crop !vegetation type (PFT)
use clm_varcon,only : sand,clay,soic,plant,cover,num_landcover_types
use clm_varsur , only :gti, wtxy,vegxy,soic2d,sand3d,clay3d,organic3d,efisop2d &
,pctgla,pctlak,pctwet,pcturb !surface data
use decompMod , only: get_proc_bounds
use module_cam_support, only: endrun
!
! !ARGUMENTS:
implicit none
!!ylu add new variables:
integer :: ilx,jlx
real(r8) :: organicxy(maxpatch)
real(r8) :: efisopxy(6)
real(r8) :: gtixy
!
! !CALLED FROM:
! subroutine initialize in module initializeMod
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein, Sam Levis and Gordon Bonan
!
!EOP
! variables from MM5 11/25/2003 Jiming Jin
integer :: iveg,isl,lndmsk
!
! !LOCAL VARIABLES:
integer :: g,k,m,k1,k2,begg,endg ! indices
integer :: ncid,dimid,varid ! netCDF id's
integer :: ier ! error status
integer ,allocatable :: pft(:,:) ! PFT
integer ,allocatable :: cft(:,:) ! CFT
real(r8),allocatable :: pctcft_lunit(:,:) ! % of crop lunit area for CFTs
real(r8),allocatable :: pctpft_lunit(:,:) ! % of vegetated lunit area PFTs
real(r8), allocatable :: pctpft(:,:) ! percent of vegetated gridcell area for PFTs
!ylu change pctspec to pctspec1, pctspec now to be a vector in clm_varsur,so pctspec can be used in pftdynMod.F
real(r8) :: pctspec1 ! percent of gridcell made up of special landunits
integer :: cropcount ! temporary counter
real(r8) :: sumscl ! temporory scalar sum
real(r8),allocatable :: sumvec(:) ! temporary vector sum
logical :: found ! temporary for error check
integer :: iindx, jindx ! temporary for error check
integer :: miss = 99999 ! missing data indicator
real(r8) :: wst(0:numpft) ! as[signed?] pft at specific i, j
integer :: wsti(maxpatch_pft) ! ranked indices of largest values in wst
real(r8) :: wst_sum ! sum of %pft
real(r8) :: sumpct ! sum of %pft over maxpatch_pft
real(r8) :: diff ! the difference (wst_sum - sumpct)
real(r8) :: rmax ! maximum patch cover
!ylu 01/16/2009
integer :: pftid
!!-------------------------------------------------------------------------
! Initialize surface data to fill value
call CLMDebug('surfrd-mark1')
call get_proc_bounds(begg=begg, endg=endg)
call CLMDebug('get begg,endg')
soic2d(:) = -999
sand3d(:,:) = -999.
clay3d(:,:) = -999.
pctlak(:) = 0.0
pctwet(:) = 0.0
pcturb(:) = 0.0
pctgla(:) = 0.0
!ylu
pftid = 0
call CLMDebug('allocate sumvec')
allocate(sumvec(begg:endg))
call CLMDebug('allocate cft')
allocate(cft(begg:endg,numcft))
call CLMDebug('allocate pft')
allocate(pft(begg:endg,maxpatch_pft))
call CLMDebug('allocate pctpft_lunit')
allocate(pctcft_lunit(begg:endg,numcft))
call CLMDebug('allocate pctpft_lunit')
allocate(pctpft_lunit(begg:endg,maxpatch_pft))
call CLMDebug('allocate pctpft')
allocate(pctpft(begg:endg,0:numpft))
pctpft(:,:) = 0.0
pft(:,:) = 0
call CLMDebug('surfrd-mark')
! Obtain netcdf file and read surface data
do g=begg,endg
soic2d(g) = soic(isl)
efisop2d(:,g) = efisopxy(:)
gti(g) = gtixy
do k=1,nlevsoi
sand3d(g,k) = sand(isl)
clay3d(g,k) = clay(isl)
organic3d(g,k) = organicxy(k)
end do
call CLMDebug('surfrd-mark2')
!---------------------------------------------------
! in current versions of CLM, the lake scheme has problems
! in simulating deep lakes. Esepcially, observed lake depth data should
! be used in the lake scheme. Wetland and glacier schemes haven't been developed
! within CLM. Thus, the following lines are temporirially commented out
! -- Jiming Jin 10/18/2012
! if(iveg == 17 .or. iveg == 18) then
! pctwet(g) = 100.0
! elseif(iveg.eq.16.and.lndmsk.eq.1) then
! pctlak(g) = 100.0
! elseif(iveg.eq.24) then
! pctgla(g) = 100.0
! end if
!----------------------------------------------------
do m=1,maxpatch_pft
pft(g,m) = plant(iveg,m)
if(cover(iveg,m).ne.0.0) then
pctpft(g,pft(g,m)) = cover(iveg,m)
end if
end do
!CLM caculates urban separately. See module_sf_clm
! pcturb(g) = 0
! if(pctgla(g) .eq. 100 .or. pctlak(g) .eq. 100 .or.pctwet(g) .eq. 100) then
! pftid = 1 !no pft distribution for this grid cell
! pctpft(g,0) = 100.
! pctpft(g,1:numpft) = 0.
! pft(g,:) = 0.
! end if
!---------------------------------------------------------------------
end do
call CLMDebug('surfrd--mark3')
! Error check: valid PFTs and sum of cover must equal 100
#ifndef DGVM
sumvec(:) = abs(sum(pctpft,dim=2)-100.)
do g=begg,endg
do m = 1, maxpatch_pft
if (pft(g,m)<0 .or. pft(g,m)>numpft) then
write(6,*)'SURFRD error: invalid PFT for g,m=',ilx,jlx,m,pft(g,m)
call endrun
end if
end do
!ylu
if (sumvec(g)>1.e-04 .and. pftid == 0) then
write(6,*)'SURFRD error: PFT cover ne 100 for g=',ilx,jlx
do m=1,maxpatch_pft
write(6,*)'m= ',m,' pft= ',pft(g,m)
end do
write(6,*)'sumvec= ',sumvec(g)
call endrun
end if
end do
#endif
call CLMDebug('surfrd--mark4')
! 1. pctpft must go back to %vegetated landunit instead of %gridcell
! 2. pctpft bare = 100 when landmask = 1 and 100% special landunit
! NB: (1) and (2) do not apply to crops.
! For now keep all cfts (< 4 anyway) instead of 4 most dominant cfts
do g=begg,endg
cft(g,:) = 0
pctcft_lunit(g,:) = 0.
cropcount = 0
pctspec1 = pcturb(g) + pctgla(g) + pctlak(g) + pctwet(g)
if (pctspec1 < 100.) then
do m = 0, numpft
if (crop(m) == 1. .and. pctpft(g,m) > 0.) then
cropcount = cropcount + 1
if (cropcount > maxpatch_cft) then
write(6,*) 'ERROR surfFileMod: cropcount>maxpatch_cft'
call endrun()
end if
cft(g,cropcount) = m
pctcft_lunit(g,cropcount) = pctpft(g,m) !* 100./(100.-pctspec)
pctpft(g,m) = 0.0
else if (crop(m) == 0.) then
pctpft(g,m) = pctpft(g,m) !* 100./(100.-pctspec)
end if
end do
else if (pctspec1 == 100.) then
pctpft(g,0) = 100.
pctpft(g,1:numpft) = 0.
end if
end do
call CLMDebug('surfrd-mark5')
! Find pft and pct arrays
! Save percent cover by PFT [wst] and total percent cover [wst_sum]
do g=begg,endg
wst_sum = 0.
sumpct = 0
do m = 0, numpft
wst(m) = pctpft(g,m)
wst_sum = wst_sum + pctpft(g,m)
end do
! Rank [wst] in ascendg order to obtain the top [maxpatch_pft] PFTs
!ylu for lake, glacier,wetland, pft = noveg ,pftid = 1
if (pftid .eq. 0) call mkrank (numpft, wst, miss, wsti, maxpatch_pft)
! Fill in [pft] and [pctpft] with data for top [maxpatch_pft] PFTs.
! If land model grid cell is ocean, set to no PFTs.
! If land model grid cell is land then:
! 1. If [pctlnd_o] = 0, there is no PFT data from the input grid.
! Since need land data, use bare ground.
! 2. If [pctlnd_o] > 0, there is PFT data from the input grid but:
! a. use the chosen PFT so long as it is not a missing value
! b. missing value means no more PFTs with cover > 0
if (pftid .eq. 0) then ! vegetated grid
do m = 1, maxpatch_pft
if(wsti(m) /= miss) then
pft(g,m) = wsti(m)
pctpft_lunit(g,m) = wst(wsti(m))
else
pft(g,m) = noveg
pctpft_lunit(g,m) = 0.
end if
sumpct = sumpct + pctpft_lunit(g,m)
end do
else ! grid with other type =100 ! model grid wants ocean
do m = 1, maxpatch_pft
pft(g,m) = 0
pctpft_lunit(g,m) = 0.
end do
end if
call CLMDebug('surfrd--mark6')
! Correct for the case of more than [maxpatch_pft] PFTs present
if (sumpct < wst_sum) then
diff = wst_sum - sumpct
sumpct = 0.
do m = 1, maxpatch_pft
pctpft_lunit(g,m) = pctpft_lunit(g,m) + diff/maxpatch_pft
sumpct = sumpct + pctpft_lunit(g,m)
end do
end if
! Error check: make sure have a valid PFT
do m = 1,maxpatch_pft
if (pft(g,m) < 0 .or. pft(g,m) > numpft) then
write (6,*)'surfrd error: invalid PFT at gridcell g=',ilx,jlx,pft(g,m)
call endrun()
end if
end do
! As done in mksrfdatMod.F90 for other percentages, truncate pctpft to
! ensure that weight relative to landunit is not nonzero
! (i.e. a very small number such as 1e-16) where it really should be zero
do m=1,maxpatch_pft
pctpft_lunit(g,m) = float(nint(pctpft_lunit(g,m)))
end do
do m=1,maxpatch_cft
pctcft_lunit(g,m) = float(nint(pctcft_lunit(g,m)))
end do
! Make sure sum of PFT cover == 100 for land points. If not,
! subtract excess from most dominant PFT.
call CLMDebug('surfrd--mark7')
rmax = -9999.
k1 = -9999
k2 = -9999
sumpct = 0.
do m = 1, maxpatch_pft
sumpct = sumpct + pctpft_lunit(g,m)
if (pctpft_lunit(g,m) > rmax) then
k1 = m
rmax = pctpft_lunit(g,m)
end if
end do
do m = 1, maxpatch_cft
sumpct = sumpct + pctcft_lunit(g,m)
if (pctcft_lunit(g,m) > rmax) then
k2 = m
rmax = pctcft_lunit(g,m)
end if
end do
if (k1 == -9999 .and. k2 == -9999) then
write(6,*)'surfrd error: largest PFT patch not found'
call endrun()
else if(pftid /=1) then
if (sumpct < 95 .or. sumpct > 105.) then
write(6,*)'surfrd error: sum of PFT cover =',sumpct,' at g=',ilx,jlx
call endrun()
else if (sumpct /= 100. .and. k2 /= -9999) then
pctcft_lunit(g,k2) = pctcft_lunit(g,k2) - (sumpct-100.)
else if (sumpct /= 100.) then
pctpft_lunit(g,k1) = pctpft_lunit(g,k1) - (sumpct-100.)
end if
end if
! Error check: make sure PFTs sum to 100% cover
sumpct = 0.
do m = 1, maxpatch_pft
sumpct = sumpct + pctpft_lunit(g,m)
end do
do m = 1, maxpatch_cft
sumpct = sumpct + pctcft_lunit(g,m)
end do
if (pftid == 0) then
if (abs(sumpct - 100.) > 0.000001) then
write(6,*)'surfFileMod error: sum(pct) over maxpatch_pft is not = 100.'
write(6,*)sumpct, g
call endrun()
end if
if (sumpct < -0.000001) then
write(6,*)'surfFileMod error: sum(pct) over maxpatch_pft is < 0.'
write(6,*)sumpct, g
call endrun()
end if
end if
end do ! end of g loop
call CLMDebug('surfrd--mark8')
! Error check: glacier, lake, wetland, urban sum must be less than 100
found = .false.
do g=begg,endg
sumscl = pctlak(g)+pctwet(g)+pcturb(g)+pctgla(g)
if (sumscl > 100.+1.e-04) then
found = .true.
iindx = ilx
jindx = jlx
exit
end if
if (found) exit
end do
if ( found ) then
write(6,*)'surfrd error: PFT cover>100 for g=',ilx,jlx
call endrun()
end if
! Error check that urban parameterization is not yet finished
#ifndef TESTZACK
found = .false.
do g=begg,endg
if (pcturb(g) /= 0.) then
found = .true.
iindx = ilx
jindx = jlx
exit
end if
if (found) exit
end do
if ( found ) then
write (6,*)'surfrd error: urban parameterization not implemented at g= ',ilx,jlx
call endrun()
end if
#endif
! Determine array [veg], which sets the PFT for each of the [maxpatch]
! patches and array [wt], which sets the relative abundance of the PFT.
! Fill in PFTs for vegetated portion of grid cell. Fractional areas for
! these points [pctpft] pertain to "vegetated" area not to total grid area.
! So need to adjust them for fraction of grid that is vegetated.
! Next, fill in urban, lake, wetland, and glacier patches.
vegxy(:,:) = 0
wtxy(:,:) = 0.
do g=begg,endg
if (lndmsk == 1) then
sumscl = pcturb(g)+pctlak(g)+pctwet(g)+pctgla(g)
do m = 1, maxpatch_pft
!ylu changed according to CLM4
#ifdef CNDV
if (create_crop_landunit) then ! been through surfrd_wtxy_veg_all
if (crop(m-1) == 0) then ! so update natural vegetation only
wtxy(g,m) = 0._r8 ! crops should have values >= 0.
end if
else ! not been through surfrd_wtxy_veg_all
wtxy(g,m) = 0._r8 ! so update all vegetation
vegxy(g,m) = m - 1 ! 0 (bare ground) to maxpatch_pft-1 (= 16)
end if
!!!
call CLMDebug('surfrd--mark8')
! vegxy(g,m) = noveg !spinup initialization
! wtxy(g,m) = 1.0/maxpatch_pft * (100.-sumscl)/100.
#else
vegxy(g,m) = pft(g,m)
wtxy(g,m) = pctpft_lunit(g,m) * (100.-sumscl)/10000.
#endif
end do
vegxy(g,npatch_urban) = noveg
wtxy(g,npatch_urban) = pcturb(g)/100.
vegxy(g,npatch_lake) = noveg
wtxy(g,npatch_lake) = pctlak(g)/100.
vegxy(g,npatch_wet) = noveg
wtxy(g,npatch_wet) = pctwet(g)/100.
vegxy(g,npatch_glacier) = noveg
wtxy(g,npatch_glacier) = pctgla(g)/100.
do m = 1,maxpatch_cft
#ifdef DGVM
vegxy(g,npatch_glacier+m) = noveg ! currently assume crop=0 if DGVM mode
wtxy(g,npatch_glacier+m)= 0.
#else
vegxy(g,npatch_glacier+m) = cft(g,m)
wtxy(g,npatch_glacier+m)= pctcft_lunit(g,m) * (100.-sumscl)/10000.
#endif
end do
end if
end do
found = .false.
sumvec(:) = abs(sum(wtxy,dim=2)-1.)
do g=begg,endg
if (sumvec(g) > 1.e-06 .and. lndmsk==1) then
found = .true.
iindx = ilx
jindx = jlx
exit
endif
if (found) exit
end do
if ( found ) then
write (6,*)'surfrd error: WT > 1 or <1 occurs at g= ',iindx,jindx
call endrun()
end if
call CLMDebug('surfrd done')
deallocate(sumvec)
deallocate(cft)
deallocate(pft)
deallocate(pctcft_lunit)
deallocate(pctpft_lunit)
deallocate(pctpft)
end subroutine surfrd
end module surfFileMod
module SNICARMod 6,4
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: SNICARMod
!
! !DESCRIPTION:
! Calculate albedo of snow containing impurities
! and the evolution of snow effective radius
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use shr_const_mod , only : SHR_CONST_RHOICE
use clm_varcon, only: ss_alb_bc1,asm_prm_bc1,ext_cff_mss_bc1,ss_alb_bc2,asm_prm_bc2,ext_cff_mss_bc2&
,ss_alb_oc1,asm_prm_oc1,ext_cff_mss_oc1,ss_alb_oc2,asm_prm_oc2,ext_cff_mss_oc2&
,ss_alb_dst1,asm_prm_dst1,ext_cff_mss_dst1,ss_alb_dst2,asm_prm_dst2,ext_cff_mss_dst2 &
,ss_alb_dst3,asm_prm_dst3,ext_cff_mss_dst3,ss_alb_dst4,asm_prm_dst4,ext_cff_mss_dst4 &
,ss_alb_snw_drc,asm_prm_snw_drc,ext_cff_mss_snw_drc,ss_alb_snw_dfs,asm_prm_snw_dfs &
,ext_cff_mss_snw_dfs,snowage_tau,snowage_kappa,snowage_drdt0 &
,xx_ss_alb_snw_drc &
,xx_asm_prm_snw_drc &
,xx_ext_cff_mss_snw_drc &
,xx_ss_alb_snw_dfs &
,xx_asm_prm_snw_dfs &
,xx_ext_cff_mss_snw_dfs &
,xx_snowage_tau &
,xx_snowage_kappa &
,xx_snowage_drdt0 &
,idx_Mie_snw_mx &
,idx_T_max &
,idx_Tgrd_max &
,idx_rhos_max &
,numrad_snw
use module_cam_support, only: endrun
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: SNICAR_RT ! Snow albedo and vertically-resolved solar absorption
public :: SnowAge_grain ! Snow effective grain size evolution
!
! !PUBLIC DATA MEMBERS:
real(r8), public, parameter :: snw_rds_min = 54.526_r8 ! minimum allowed snow effective radius (also "fresh snow" value) [microns]
integer, public, parameter :: sno_nbr_aer = 8 ! number of aerosol species in snowpack (indices described above) [nbr]
logical, public, parameter :: DO_SNO_OC = .false. ! parameter to include organic carbon (OC) in snowpack radiative calculations
logical, public, parameter :: DO_SNO_AER = .true. ! parameter to include aerosols in snowpack radiative calculations
real(r8), public, parameter :: scvng_fct_mlt_bcphi = 0.20_r8 ! scavenging factor for hydrophillic BC inclusion in meltwater [frc]
real(r8), public, parameter :: scvng_fct_mlt_bcpho = 0.03_r8 ! scavenging factor for hydrophobic BC inclusion in meltwater [frc]
real(r8), public, parameter :: scvng_fct_mlt_ocphi = 0.20_r8 ! scavenging factor for hydrophillic OC inclusion in meltwater [frc]
real(r8), public, parameter :: scvng_fct_mlt_ocpho = 0.03_r8 ! scavenging factor for hydrophobic OC inclusion in meltwater [frc]
real(r8), public, parameter :: scvng_fct_mlt_dst1 = 0.02_r8 ! scavenging factor for dust species 1 inclusion in meltwater [frc]
real(r8), public, parameter :: scvng_fct_mlt_dst2 = 0.02_r8 ! scavenging factor for dust species 2 inclusion in meltwater [frc]
real(r8), public, parameter :: scvng_fct_mlt_dst3 = 0.01_r8 ! scavenging factor for dust species 3 inclusion in meltwater [frc]
real(r8), public, parameter :: scvng_fct_mlt_dst4 = 0.01_r8 ! scavenging factor for dust species 4 inclusion in meltwater [frc]
! !PRIVATE MEMBER FUNCTIONS:
!
! !PRIVATE DATA MEMBERS:
! Aerosol species indices:
! 1= hydrophillic black carbon
! 2= hydrophobic black carbon
! 3= hydrophilic organic carbon
! 4= hydrophobic organic carbon
! 5= dust species 1
! 6= dust species 2
! 7= dust species 3
! 8= dust species 4
integer, parameter :: nir_bnd_bgn = 2 ! first band index in near-IR spectrum [idx]
integer, parameter :: nir_bnd_end = 5 ! ending near-IR band index [idx]
integer, parameter :: idx_T_min = 1 ! minimum temperature index used in aging lookup table [idx]
integer, parameter :: idx_Tgrd_min = 1 ! minimum temperature gradient index used in aging lookup table [idx]
integer, parameter :: idx_rhos_min = 1 ! minimum snow density index used in aging lookup table [idx]
integer, parameter :: snw_rds_max_tbl = 1500 ! maximum effective radius defined in Mie lookup table [microns]
integer, parameter :: snw_rds_min_tbl = 30 ! minimium effective radius defined in Mie lookup table [microns]
real(r8), parameter :: snw_rds_max = 1500._r8 ! maximum allowed snow effective radius [microns]
real(r8), parameter :: snw_rds_refrz = 1000._r8 ! effective radius of re-frozen snow [microns]
real(r8), parameter :: min_snw = 1.0E-30_r8 ! minimum snow mass required for SNICAR RT calculation [kg m-2]
!real(r8), parameter :: C1_liq_Brun89 = 1.28E-17_r8 ! constant for liquid water grain growth [m3 s-1], from Brun89
real(r8), parameter :: C1_liq_Brun89 = 0._r8 ! constant for liquid water grain growth [m3 s-1], from Brun89: zeroed to accomodate dry snow aging
real(r8), parameter :: C2_liq_Brun89 = 4.22E-13_r8 ! constant for liquid water grain growth [m3 s-1], from Brun89: corrected for LWC in units of percent
real(r8), parameter :: tim_cns_bc_rmv = 2.2E-8_r8 ! time constant for removal of BC in snow on sea-ice [s-1] (50% mass removal/year)
real(r8), parameter :: tim_cns_oc_rmv = 2.2E-8_r8 ! time constant for removal of OC in snow on sea-ice [s-1] (50% mass removal/year)
real(r8), parameter :: tim_cns_dst_rmv = 2.2E-8_r8 ! time constant for removal of dust in snow on sea-ice [s-1] (50% mass removal/year)
! scaling of the snow aging rate (tuning option):
logical :: flg_snoage_scl = .false. ! flag for scaling the snow aging rate by some arbitrary factor
real(r8), parameter :: xdrdt = 1.0_r8 ! arbitrary factor applied to snow aging rate
!
! !REVISION HISTORY:
! Created by Mark Flanner
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SNICAR_RT
!
!
! !CALLED FROM:
! subroutine SurfaceAlbedo in module SurfaceAlbedoMod (CLM)
! subroutine albice (CSIM)
!
! !REVISION HISTORY:
! Author: Mark Flanner
!
! !INTERFACE:
subroutine SNICAR_RT (flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, & 10,11
coszen, flg_slr_in, h2osno_liq, h2osno_ice, snw_rds, &
mss_cnc_aer_in, albsfc, albout, flx_abs)
!
! !DESCRIPTION:
! Determine reflectance of, and vertically-resolved solar absorption in,
! snow with impurities.
!
! Original references on physical models of snow reflectance include:
! Wiscombe and Warren [1980] and Warren and Wiscombe [1980],
! Journal of Atmospheric Sciences, 37,
!
! The multi-layer solution for multiple-scattering used here is from:
! Toon et al. [1989], Rapid calculation of radiative heating rates
! and photodissociation rates in inhomogeneous multiple scattering atmospheres,
! J. Geophys. Res., 94, D13, 16287-16301
!
! The implementation of the SNICAR model in CLM/CSIM is described in:
! Flanner, M., C. Zender, J. Randerson, and P. Rasch [2007],
! Present-day climate forcing and response from black carbon in snow,
! J. Geophys. Res., 112, D11202, doi: 10.1029/2006JD008003
! !USES:
use clmtype
use clm_varpar , only : nlevsno, numrad
use shr_const_mod , only : SHR_CONST_PI
use globals , only : nstep
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: flg_snw_ice ! flag: =1 when called from CLM, =2 when called from CSIM
integer , intent(in) :: lbc, ubc ! column index bounds [unitless]
integer , intent(in) :: num_nourbanc ! number of columns in non-urban filter
integer , intent(in) :: filter_nourbanc(ubc-lbc+1) ! column filter for non-urban points
real(r8), intent(in) :: coszen(lbc:ubc) ! cosine of solar zenith angle for next time step (col) [unitless]
integer , intent(in) :: flg_slr_in ! flag: =1 for direct-beam incident flux, =2 for diffuse incident flux
real(r8), intent(in) :: h2osno_liq(lbc:ubc,-nlevsno+1:0) ! liquid water content (col,lyr) [kg/m2]
real(r8), intent(in) :: h2osno_ice(lbc:ubc,-nlevsno+1:0) ! ice content (col,lyr) [kg/m2]
integer, intent(in) :: snw_rds(lbc:ubc,-nlevsno+1:0) ! snow effective radius (col,lyr) [microns, m^-6]
real(r8), intent(in) :: mss_cnc_aer_in(lbc:ubc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of all aerosol species (col,lyr,aer) [kg/kg]
real(r8), intent(in) :: albsfc(lbc:ubc,numrad) ! albedo of surface underlying snow (col,bnd) [frc]
real(r8), intent(out) :: albout(lbc:ubc,numrad) ! snow albedo, averaged into 2 bands (=0 if no sun or no snow) (col,bnd) [frc]
real(r8), intent(out) :: flx_abs(lbc:ubc,-nlevsno+1:1,numrad) ! absorbed flux in each layer per unit flux incident on top of snowpack (col,lyr,bnd) [frc]
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer, pointer :: snl(:) ! negative number of snow layers (col) [nbr]
real(r8), pointer :: h2osno(:) ! snow liquid water equivalent (col) [kg/m2]
integer, pointer :: clandunit(:) ! corresponding landunit of column (col) [idx] (debugging only)
integer, pointer :: cgridcell(:) ! columns's gridcell index (col) [idx] (debugging only)
integer, pointer :: ltype(:) ! landunit type (lnd) (debugging only)
real(r8), pointer :: londeg(:) ! longitude (degrees) (debugging only)
real(r8), pointer :: latdeg(:) ! latitude (degrees) (debugging only)
!
! !OTHER LOCAL VARIABLES:
!EOP
!-----------------------------------------------------------------------
!
! variables for snow radiative transfer calculations
! Local variables representing single-column values of arrays:
integer :: snl_lcl ! negative number of snow layers [nbr]
integer :: snw_rds_lcl(-nlevsno+1:0) ! snow effective radius [m^-6]
real(r8):: flx_slrd_lcl(1:numrad_snw) ! direct beam incident irradiance [W/m2] (set to 1)
real(r8):: flx_slri_lcl(1:numrad_snw) ! diffuse incident irradiance [W/m2] (set to 1)
real(r8):: mss_cnc_aer_lcl(-nlevsno+1:0,1:sno_nbr_aer) ! aerosol mass concentration (lyr,aer_nbr) [kg/kg]
real(r8):: h2osno_lcl ! total column snow mass [kg/m2]
real(r8):: h2osno_liq_lcl(-nlevsno+1:0) ! liquid water mass [kg/m2]
real(r8):: h2osno_ice_lcl(-nlevsno+1:0) ! ice mass [kg/m2]
real(r8):: albsfc_lcl(1:numrad_snw) ! albedo of underlying surface [frc]
real(r8):: ss_alb_snw_lcl(-nlevsno+1:0) ! single-scatter albedo of ice grains (lyr) [frc]
real(r8):: asm_prm_snw_lcl(-nlevsno+1:0) ! asymmetry parameter of ice grains (lyr) [frc]
real(r8):: ext_cff_mss_snw_lcl(-nlevsno+1:0) ! mass extinction coefficient of ice grains (lyr) [m2/kg]
real(r8):: ss_alb_aer_lcl(sno_nbr_aer) ! single-scatter albedo of aerosol species (aer_nbr) [frc]
real(r8):: asm_prm_aer_lcl(sno_nbr_aer) ! asymmetry parameter of aerosol species (aer_nbr) [frc]
real(r8):: ext_cff_mss_aer_lcl(sno_nbr_aer) ! mass extinction coefficient of aerosol species (aer_nbr) [m2/kg]
! Other local variables
integer :: APRX_TYP ! two-stream approximation type (1=Eddington, 2=Quadrature, 3=Hemispheric Mean) [nbr]
integer :: DELTA ! flag to use Delta approximation (Joseph, 1976) (1= use, 0= don't use)
real(r8):: flx_wgt(1:numrad_snw) ! weights applied to spectral bands, specific to direct and diffuse cases (bnd) [frc]
integer :: flg_nosnl ! flag: =1 if there is snow, but zero snow layers, =0 if at least 1 snow layer [flg]
integer :: trip ! flag: =1 to redo RT calculation if result is unrealistic
integer :: flg_dover ! defines conditions for RT redo (explained below)
real(r8):: albedo ! temporary snow albedo [frc]
real(r8):: flx_sum ! temporary summation variable for NIR weighting
real(r8):: albout_lcl(numrad_snw) ! snow albedo by band [frc]
real(r8):: flx_abs_lcl(-nlevsno+1:1,numrad_snw)! absorbed flux per unit incident flux at top of snowpack (lyr,bnd) [frc]
real(r8):: L_snw(-nlevsno+1:0) ! h2o mass (liquid+solid) in snow layer (lyr) [kg/m2]
real(r8):: tau_snw(-nlevsno+1:0) ! snow optical depth (lyr) [unitless]
real(r8):: L_aer(-nlevsno+1:0,sno_nbr_aer) ! aerosol mass in snow layer (lyr,nbr_aer) [kg/m2]
real(r8):: tau_aer(-nlevsno+1:0,sno_nbr_aer) ! aerosol optical depth (lyr,nbr_aer) [unitless]
real(r8):: tau_sum ! cumulative (snow+aerosol) optical depth [unitless]
real(r8):: tau_clm(-nlevsno+1:0) ! column optical depth from layer bottom to snowpack top (lyr) [unitless]
real(r8):: omega_sum ! temporary summation of single-scatter albedo of all aerosols [frc]
real(r8):: g_sum ! temporary summation of asymmetry parameter of all aerosols [frc]
real(r8):: tau(-nlevsno+1:0) ! weighted optical depth of snow+aerosol layer (lyr) [unitless]
real(r8):: omega(-nlevsno+1:0) ! weighted single-scatter albedo of snow+aerosol layer (lyr) [frc]
real(r8):: g(-nlevsno+1:0) ! weighted asymmetry parameter of snow+aerosol layer (lyr) [frc]
real(r8):: tau_star(-nlevsno+1:0) ! transformed (i.e. Delta-Eddington) optical depth of snow+aerosol layer (lyr) [unitless]
real(r8):: omega_star(-nlevsno+1:0) ! transformed (i.e. Delta-Eddington) SSA of snow+aerosol layer (lyr) [frc]
real(r8):: g_star(-nlevsno+1:0) ! transformed (i.e. Delta-Eddington) asymmetry paramater of snow+aerosol layer (lyr) [frc]
integer :: g_idx, c_idx, l_idx ! gridcell, column, and landunit indices [idx]
integer :: bnd_idx ! spectral band index (1 <= bnd_idx <= numrad_snw) [idx]
integer :: rds_idx ! snow effective radius index for retrieving Mie parameters from lookup table [idx]
integer :: snl_btm ! index of bottom snow layer (0) [idx]
integer :: snl_top ! index of top snow layer (-4 to 0) [idx]
integer :: fc ! column filter index
integer :: i ! layer index [idx]
integer :: j ! aerosol number index [idx]
integer :: n ! tridiagonal matrix index [idx]
integer :: m ! secondary layer index [idx]
integer :: ix,k ! an index
real(r8):: F_direct(-nlevsno+1:0) ! direct-beam radiation at bottom of layer interface (lyr) [W/m^2]
real(r8):: F_net(-nlevsno+1:0) ! net radiative flux at bottom of layer interface (lyr) [W/m^2]
real(r8):: F_abs(-nlevsno+1:0) ! net absorbed radiative energy (lyr) [W/m^2]
real(r8):: F_abs_sum ! total absorbed energy in column [W/m^2]
real(r8):: F_sfc_pls ! upward radiative flux at snowpack top [W/m^2]
real(r8):: F_btm_net ! net flux at bottom of snowpack [W/m^2]
real(r8):: F_sfc_net ! net flux at top of snowpack [W/m^2]
real(r8):: energy_sum ! sum of all energy terms; should be 0.0 [W/m^2]
real(r8):: F_direct_btm ! direct-beam radiation at bottom of snowpack [W/m^2]
real(r8):: mu_not ! cosine of solar zenith angle (used locally) [frc]
integer :: err_idx ! counter for number of times through error loop [nbr]
real(r8):: lat_coord ! gridcell latitude (debugging only)
real(r8):: lon_coord ! gridcell longitude (debugging only)
integer :: sfctype ! underlying surface type (debugging only)
real(r8):: pi ! 3.1415...
! intermediate variables for radiative transfer approximation:
real(r8):: gamma1(-nlevsno+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless]
real(r8):: gamma2(-nlevsno+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless]
real(r8):: gamma3(-nlevsno+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless]
real(r8):: gamma4(-nlevsno+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless]
real(r8):: lambda(-nlevsno+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless]
real(r8):: GAMMA(-nlevsno+1:0) ! two-stream coefficient from Toon et al. (lyr) [unitless]
real(r8):: mu_one ! two-stream coefficient from Toon et al. (lyr) [unitless]
real(r8):: e1(-nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (lyr)
real(r8):: e2(-nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (lyr)
real(r8):: e3(-nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (lyr)
real(r8):: e4(-nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (lyr)
real(r8):: C_pls_btm(-nlevsno+1:0) ! intermediate variable: upward flux at bottom interface (lyr) [W/m2]
real(r8):: C_mns_btm(-nlevsno+1:0) ! intermediate variable: downward flux at bottom interface (lyr) [W/m2]
real(r8):: C_pls_top(-nlevsno+1:0) ! intermediate variable: upward flux at top interface (lyr) [W/m2]
real(r8):: C_mns_top(-nlevsno+1:0) ! intermediate variable: downward flux at top interface (lyr) [W/m2]
real(r8):: A(-2*nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr)
real(r8):: B(-2*nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr)
real(r8):: D(-2*nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr)
real(r8):: E(-2*nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr)
real(r8):: AS(-2*nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr)
real(r8):: DS(-2*nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr)
real(r8):: X(-2*nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr)
real(r8):: Y(-2*nlevsno+1:0) ! tri-diag intermediate variable from Toon et al. (2*lyr)
! Assign local pointers to derived subtypes components (column-level)
! (CLM-specific)
if (flg_snw_ice == 1) then
snl => clm3%g%l%c%cps%snl
h2osno => clm3%g%l%c%cws%h2osno
clandunit => clm3%g%l%c%landunit ! (debug only)
cgridcell => clm3%g%l%c%gridcell ! (debug only)
ltype => clm3%g%l%itype ! (debug only)
londeg => clm3%g%londeg ! (debug only)
latdeg => clm3%g%latdeg ! (debug only)
endif
ix = 0
do i=1, idx_Mie_snw_mx
do j=1, numrad_snw
ix = ix+1
ss_alb_snw_drc(i,j) = xx_ss_alb_snw_drc(ix)
asm_prm_snw_drc(i,j) = xx_asm_prm_snw_drc(ix)
ext_cff_mss_snw_drc(i,j) = xx_ext_cff_mss_snw_drc(ix)
ss_alb_snw_dfs(i,j) = xx_ss_alb_snw_dfs(ix)
asm_prm_snw_dfs(i,j) = xx_asm_prm_snw_dfs(ix)
ext_cff_mss_snw_dfs(i,j) = xx_ext_cff_mss_snw_dfs(ix)
end do
end do
ix = 0
do i=1,idx_T_max
do j=1,idx_Tgrd_max
do k=1,idx_rhos_max
ix = ix + 1
snowage_tau(i,j,k) = xx_snowage_tau(ix)
snowage_kappa(i,j,k) = xx_snowage_kappa(ix)
snowage_drdt0(i,j,k) = xx_snowage_drdt0(ix)
end do
end do
end do
! Define constants
pi = SHR_CONST_PI
! always use Delta approximation for snow
DELTA = 1
! Loop over all non-urban columns
! (when called from CSIM, there is only one column)
do fc = 1,num_nourbanc
c_idx = filter_nourbanc(fc)
! Zero absorbed radiative fluxes:
do i=-nlevsno+1,1,1
flx_abs_lcl(:,:) = 0._r8
flx_abs(c_idx,i,:) = 0._r8
enddo
! set snow/ice mass to be used for RT:
if (flg_snw_ice == 1) then
h2osno_lcl = h2osno(c_idx)
else
h2osno_lcl = h2osno_ice(c_idx,0)
endif
! Qualifier for computing snow RT:
! 1) sunlight from atmosphere model
! 2) minimum amount of snow on ground.
! Otherwise, set snow albedo to zero
if ((coszen(c_idx) > 0._r8) .and. (h2osno_lcl > min_snw)) then
! Set variables specific to CLM
if (flg_snw_ice == 1) then
! Assign local (single-column) variables to global values
! If there is snow, but zero snow layers, we must create a layer locally.
! This layer is presumed to have the fresh snow effective radius.
if (snl(c_idx) > -1) then
flg_nosnl = 1
snl_lcl = -1
h2osno_ice_lcl(0) = h2osno_lcl
h2osno_liq_lcl(0) = 0._r8
snw_rds_lcl(0) = nint(snw_rds_min)
else
flg_nosnl = 0
snl_lcl = snl(c_idx)
h2osno_liq_lcl(:) = h2osno_liq(c_idx,:)
h2osno_ice_lcl(:) = h2osno_ice(c_idx,:)
snw_rds_lcl(:) = snw_rds(c_idx,:)
endif
snl_btm = 0
snl_top = snl_lcl+1
! for debugging only
l_idx = clandunit(c_idx)
g_idx = cgridcell(c_idx)
sfctype = ltype(l_idx)
lat_coord = latdeg(g_idx)
lon_coord = londeg(g_idx)
! Set variables specific to CSIM
else
flg_nosnl = 0
snl_lcl = -1
h2osno_liq_lcl(:) = h2osno_liq(c_idx,:)
h2osno_ice_lcl(:) = h2osno_ice(c_idx,:)
snw_rds_lcl(:) = snw_rds(c_idx,:)
snl_btm = 0
snl_top = 0
sfctype = -1
lat_coord = -90
lon_coord = 0
endif
! Set local aerosol array
do j=1,sno_nbr_aer
mss_cnc_aer_lcl(:,j) = mss_cnc_aer_in(c_idx,:,j)
enddo
! Set spectral underlying surface albedos to their corresponding VIS or NIR albedos
albsfc_lcl(1) = albsfc(c_idx,1)
albsfc_lcl(nir_bnd_bgn:nir_bnd_end) = albsfc(c_idx,2)
! Error check for snow grain size:
do i=snl_top,snl_btm,1
if ((snw_rds_lcl(i) < snw_rds_min_tbl) .or. (snw_rds_lcl(i) > snw_rds_max_tbl)) then
write (6,*) "SNICAR ERROR: snow grain radius of ", snw_rds_lcl(i), " out of bounds."
write (6,*) "NSTEP= ", nstep
write (6,*) "flg_snw_ice= ", flg_snw_ice
write (6,*) "column: ", c_idx, " level: ", i, " snl(c)= ", snl_lcl
write (6,*) "lat= ", lat_coord, " lon= ", lon_coord
write (6,*) "h2osno(c)= ", h2osno_lcl
call endrun()
endif
enddo
! Incident flux weighting parameters
! - sum of all VIS bands must equal 1
! - sum of all NIR bands must equal 1
!
! Spectral bands (5-band case)
! Band 1: 0.3-0.7um (VIS)
! Band 2: 0.7-1.0um (NIR)
! Band 3: 1.0-1.2um (NIR)
! Band 4: 1.2-1.5um (NIR)
! Band 5: 1.5-5.0um (NIR)
!
! The following weights are appropriate for surface-incident flux in a mid-latitude winter atmosphere
!
! 3-band weights
if (numrad_snw==3) then
! Direct:
if (flg_slr_in == 1) then
flx_wgt(1) = 1._r8
flx_wgt(2) = 0.66628670195247_r8
flx_wgt(3) = 0.33371329804753_r8
! Diffuse:
elseif (flg_slr_in == 2) then
flx_wgt(1) = 1._r8
flx_wgt(2) = 0.77887652162877_r8
flx_wgt(3) = 0.22112347837123_r8
endif
! 5-band weights
elseif(numrad_snw==5) then
! Direct:
if (flg_slr_in == 1) then
flx_wgt(1) = 1._r8
flx_wgt(2) = 0.49352158521175_r8
flx_wgt(3) = 0.18099494230665_r8
flx_wgt(4) = 0.12094898498813_r8
flx_wgt(5) = 0.20453448749347_r8
! Diffuse:
elseif (flg_slr_in == 2) then
flx_wgt(1) = 1._r8
flx_wgt(2) = 0.58581507618433_r8
flx_wgt(3) = 0.20156903770812_r8
flx_wgt(4) = 0.10917889346386_r8
flx_wgt(5) = 0.10343699264369_r8
endif
endif
! Loop over snow spectral bands
do bnd_idx = 1,numrad_snw
mu_not = coszen(c_idx) ! must set here, because of error handling
flg_dover = 1 ! default is to redo
err_idx = 0 ! number of times through loop
do while (flg_dover > 0)
! DEFAULT APPROXIMATIONS:
! VIS: Delta-Eddington
! NIR (all): Delta-Hemispheric Mean
! WARNING: DO NOT USE DELTA-EDDINGTON FOR NIR DIFFUSE - this sometimes results in negative albedo
!
! ERROR CONDITIONS:
! Conditions which cause "trip", resulting in redo of RT approximation:
! 1. negative absorbed flux
! 2. total absorbed flux greater than incident flux
! 3. negative albedo
! NOTE: These errors have only been encountered in spectral bands 4 and 5
!
! ERROR HANDLING
! 1st error (flg_dover=2): switch approximation (Edd->HM or HM->Edd)
! 2nd error (flg_dover=3): change zenith angle by 0.02 (this happens about 1 in 10^6 cases)
! 3rd error (flg_dover=4): switch approximation with new zenith
! Subsequent errors: repeatedly change zenith and approximations...
if (bnd_idx == 1) then
if (flg_dover == 2) then
APRX_TYP = 3
elseif (flg_dover == 3) then
APRX_TYP = 1
if (coszen(c_idx) > 0.5_r8) then
mu_not = mu_not - 0.02_r8
else
mu_not = mu_not + 0.02_r8
endif
elseif (flg_dover == 4) then
APRX_TYP = 3
else
APRX_TYP = 1
endif
else
if (flg_dover == 2) then
APRX_TYP = 1
elseif (flg_dover == 3) then
APRX_TYP = 3
if (coszen(c_idx) > 0.5_r8) then
mu_not = mu_not - 0.02_r8
else
mu_not = mu_not + 0.02_r8
endif
elseif (flg_dover == 4) then
APRX_TYP = 1
else
APRX_TYP = 3
endif
endif
! Set direct or diffuse incident irradiance to 1
! (This has to be within the bnd loop because mu_not is adjusted in rare cases)
if (flg_slr_in == 1) then
flx_slrd_lcl(bnd_idx) = 1._r8/(mu_not*pi) ! this corresponds to incident irradiance of 1.0
flx_slri_lcl(bnd_idx) = 0._r8
else
flx_slrd_lcl(bnd_idx) = 0._r8
flx_slri_lcl(bnd_idx) = 1._r8
endif
! Pre-emptive error handling: aerosols can reap havoc on these absorptive bands.
! Since extremely high soot concentrations have a negligible effect on these bands, zero them.
if ( (numrad_snw == 5).and.((bnd_idx == 5).or.(bnd_idx == 4)) ) then
mss_cnc_aer_lcl(:,:) = 0._r8
endif
if ( (numrad_snw == 3).and.(bnd_idx == 3) ) then
mss_cnc_aer_lcl(:,:) = 0._r8
endif
! Define local Mie parameters based on snow grain size and aerosol species,
! retrieved from a lookup table.
if (flg_slr_in == 1) then
do i=snl_top,snl_btm,1
rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1
! snow optical properties (direct radiation)
ss_alb_snw_lcl(i) = ss_alb_snw_drc(rds_idx,bnd_idx)
asm_prm_snw_lcl(i) = asm_prm_snw_drc(rds_idx,bnd_idx)
ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_drc(rds_idx,bnd_idx)
enddo
elseif (flg_slr_in == 2) then
do i=snl_top,snl_btm,1
rds_idx = snw_rds_lcl(i) - snw_rds_min_tbl + 1
! snow optical properties (diffuse radiation)
ss_alb_snw_lcl(i) = ss_alb_snw_dfs(rds_idx,bnd_idx)
asm_prm_snw_lcl(i) = asm_prm_snw_dfs(rds_idx,bnd_idx)
ext_cff_mss_snw_lcl(i) = ext_cff_mss_snw_dfs(rds_idx,bnd_idx)
enddo
endif
! aerosol species 1 optical properties
ss_alb_aer_lcl(1) = ss_alb_bc1(1,bnd_idx)
asm_prm_aer_lcl(1) = asm_prm_bc1(1,bnd_idx)
ext_cff_mss_aer_lcl(1) = ext_cff_mss_bc1(1,bnd_idx)
! aerosol species 2 optical properties
ss_alb_aer_lcl(2) = ss_alb_bc2(1,bnd_idx)
asm_prm_aer_lcl(2) = asm_prm_bc2(1,bnd_idx)
ext_cff_mss_aer_lcl(2) = ext_cff_mss_bc2(1,bnd_idx)
! aerosol species 3 optical properties
ss_alb_aer_lcl(3) = ss_alb_oc1(1,bnd_idx)
asm_prm_aer_lcl(3) = asm_prm_oc1(1,bnd_idx)
ext_cff_mss_aer_lcl(3) = ext_cff_mss_oc1(1,bnd_idx)
! aerosol species 4 optical properties
ss_alb_aer_lcl(4) = ss_alb_oc2(1,bnd_idx)
asm_prm_aer_lcl(4) = asm_prm_oc2(1,bnd_idx)
ext_cff_mss_aer_lcl(4) = ext_cff_mss_oc2(1,bnd_idx)
! aerosol species 5 optical properties
ss_alb_aer_lcl(5) = ss_alb_dst1(1,bnd_idx)
asm_prm_aer_lcl(5) = asm_prm_dst1(1,bnd_idx)
ext_cff_mss_aer_lcl(5) = ext_cff_mss_dst1(1,bnd_idx)
! aerosol species 6 optical properties
ss_alb_aer_lcl(6) = ss_alb_dst2(1,bnd_idx)
asm_prm_aer_lcl(6) = asm_prm_dst2(1,bnd_idx)
ext_cff_mss_aer_lcl(6) = ext_cff_mss_dst2(1,bnd_idx)
! aerosol species 7 optical properties
ss_alb_aer_lcl(7) = ss_alb_dst3(1,bnd_idx)
asm_prm_aer_lcl(7) = asm_prm_dst3(1,bnd_idx)
ext_cff_mss_aer_lcl(7) = ext_cff_mss_dst3(1,bnd_idx)
! aerosol species 8 optical properties
ss_alb_aer_lcl(8) = ss_alb_dst4(1,bnd_idx)
asm_prm_aer_lcl(8) = asm_prm_dst4(1,bnd_idx)
ext_cff_mss_aer_lcl(8) = ext_cff_mss_dst4(1,bnd_idx)
! 1. snow and aerosol layer column mass (L_snw, L_aer [kg/m^2])
! 2. optical Depths (tau_snw, tau_aer)
! 3. weighted Mie properties (tau, omega, g)
! Weighted Mie parameters of each layer
do i=snl_top,snl_btm,1
L_snw(i) = h2osno_ice_lcl(i)+h2osno_liq_lcl(i)
tau_snw(i) = L_snw(i)*ext_cff_mss_snw_lcl(i)
do j=1,sno_nbr_aer
L_aer(i,j) = L_snw(i)*mss_cnc_aer_lcl(i,j)
tau_aer(i,j) = L_aer(i,j)*ext_cff_mss_aer_lcl(j)
enddo
tau_sum = 0._r8
omega_sum = 0._r8
g_sum = 0._r8
do j=1,sno_nbr_aer
tau_sum = tau_sum + tau_aer(i,j)
omega_sum = omega_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j))
g_sum = g_sum + (tau_aer(i,j)*ss_alb_aer_lcl(j)*asm_prm_aer_lcl(j))
enddo
tau(i) = tau_sum + tau_snw(i)
if(tau(i) == 0) then
write(6,*) 'FATAL ERROR in SNICAR RT, tau(',i,') is the denominatoer can not equal to ',tau(i)
call endrun()
end if
omega(i) = (1/tau(i))*(omega_sum+(ss_alb_snw_lcl(i)*tau_snw(i)))
g(i) = (1/(tau(i)*omega(i)))*(g_sum+ (asm_prm_snw_lcl(i)*ss_alb_snw_lcl(i)*tau_snw(i)))
enddo
! DELTA transformations, if requested
if (DELTA == 1) then
do i=snl_top,snl_btm,1
g_star(i) = g(i)/(1+g(i))
omega_star(i) = ((1-(g(i)**2))*omega(i)) / (1-(omega(i)*(g(i)**2)))
tau_star(i) = (1-(omega(i)*(g(i)**2)))*tau(i)
enddo
else
do i=snl_top,snl_btm,1
g_star(i) = g(i)
omega_star(i) = omega(i)
tau_star(i) = tau(i)
enddo
endif
! Total column optical depth:
! tau_clm(i) = total optical depth above the bottom of layer i
tau_clm(snl_top) = 0._r8
do i=snl_top+1,snl_btm,1
tau_clm(i) = tau_clm(i-1)+tau_star(i-1)
enddo
! Direct radiation at bottom of snowpack:
F_direct_btm = albsfc_lcl(bnd_idx)*mu_not*exp(-(tau_clm(snl_btm)+tau_star(snl_btm))/mu_not)*pi*flx_slrd_lcl(bnd_idx)
! Intermediates
! Gamma values are approximation-specific.
! Eddington
if (APRX_TYP==1) then
do i=snl_top,snl_btm,1
gamma1(i) = (7-(omega_star(i)*(4+(3*g_star(i)))))/4
gamma2(i) = -(1-(omega_star(i)*(4-(3*g_star(i)))))/4
gamma3(i) = (2-(3*g_star(i)*mu_not))/4
gamma4(i) = 1-gamma3(i)
mu_one = 0.5
enddo
! Quadrature
elseif (APRX_TYP==2) then
do i=snl_top,snl_btm,1
gamma1(i) = (3**0.5)*(2-(omega_star(i)*(1+g_star(i))))/2
gamma2(i) = omega_star(i)*(3**0.5)*(1-g_star(i))/2
gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2
gamma4(i) = 1-gamma3(i)
mu_one = 1/(3**0.5)
enddo
! Hemispheric Mean
elseif (APRX_TYP==3) then
do i=snl_top,snl_btm,1
gamma1(i) = 2 - (omega_star(i)*(1+g_star(i)))
gamma2(i) = omega_star(i)*(1-g_star(i))
gamma3(i) = (1-((3**0.5)*g_star(i)*mu_not))/2
gamma4(i) = 1-gamma3(i)
mu_one = 0.5
enddo
endif
! Intermediates for tri-diagonal solution
do i=snl_top,snl_btm,1
lambda(i) = sqrt(abs((gamma1(i)**2) - (gamma2(i)**2)))
GAMMA(i) = gamma2(i)/(gamma1(i)+lambda(i))
e1(i) = 1+(GAMMA(i)*exp(-lambda(i)*tau_star(i)))
e2(i) = 1-(GAMMA(i)*exp(-lambda(i)*tau_star(i)))
e3(i) = GAMMA(i) + exp(-lambda(i)*tau_star(i))
e4(i) = GAMMA(i) - exp(-lambda(i)*tau_star(i))
enddo !enddo over snow layers
! Intermediates for tri-diagonal solution
do i=snl_top,snl_btm,1
if (flg_slr_in == 1) then
C_pls_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* &
exp(-(tau_clm(i)+tau_star(i))/mu_not)* &
(((gamma1(i)-(1/mu_not))*gamma3(i))+ &
(gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2)))
C_mns_btm(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* &
exp(-(tau_clm(i)+tau_star(i))/mu_not)* &
(((gamma1(i)+(1/mu_not))*gamma4(i))+ &
(gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2)))
C_pls_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* &
exp(-tau_clm(i)/mu_not)*(((gamma1(i)-(1/mu_not))* &
gamma3(i))+(gamma4(i)*gamma2(i))))/((lambda(i)**2)-(1/(mu_not**2)))
C_mns_top(i) = (omega_star(i)*pi*flx_slrd_lcl(bnd_idx)* &
exp(-tau_clm(i)/mu_not)*(((gamma1(i)+(1/mu_not))* &
gamma4(i))+(gamma2(i)*gamma3(i))))/((lambda(i)**2)-(1/(mu_not**2)))
else
C_pls_btm(i) = 0._r8
C_mns_btm(i) = 0._r8
C_pls_top(i) = 0._r8
C_mns_top(i) = 0._r8
endif
enddo
! Coefficients for tridiaganol matrix solution
do i=2*snl_lcl+1,0,1
!Boundary values for i=1 and i=2*snl_lcl, specifics for i=odd and i=even
if (i==(2*snl_lcl+1)) then
A(i) = 0
B(i) = e1(snl_top)
D(i) = -e2(snl_top)
E(i) = flx_slri_lcl(bnd_idx)-C_mns_top(snl_top)
elseif(i==0) then
A(i) = e1(snl_btm)-(albsfc_lcl(bnd_idx)*e3(snl_btm))
B(i) = e2(snl_btm)-(albsfc_lcl(bnd_idx)*e4(snl_btm))
D(i) = 0
E(i) = F_direct_btm-C_pls_btm(snl_btm)+(albsfc_lcl(bnd_idx)*C_mns_btm(snl_btm))
elseif(mod(i,2)==-1) then ! If odd and i>=3 (n=1 for i=3)
n=floor(i/2.0)
A(i) = (e2(n)*e3(n))-(e4(n)*e1(n))
B(i) = (e1(n)*e1(n+1))-(e3(n)*e3(n+1))
D(i) = (e3(n)*e4(n+1))-(e1(n)*e2(n+1))
E(i) = (e3(n)*(C_pls_top(n+1)-C_pls_btm(n)))+(e1(n)*(C_mns_btm(n)-C_mns_top(n+1)))
elseif(mod(i,2)==0) then ! If even and i<=2*snl_lcl
n=(i/2)
A(i) = (e2(n+1)*e1(n))-(e3(n)*e4(n+1))
B(i) = (e2(n)*e2(n+1))-(e4(n)*e4(n+1))
D(i) = (e1(n+1)*e4(n+1))-(e2(n+1)*e3(n+1))
E(i) = (e2(n+1)*(C_pls_top(n+1)-C_pls_btm(n)))+(e4(n+1)*(C_mns_top(n+1)-C_mns_btm(n)))
endif
enddo
AS(0) = A(0)/B(0)
DS(0) = E(0)/B(0)
do i=-1,(2*snl_lcl+1),-1
X(i) = 1/(B(i)-(D(i)*AS(i+1)))
AS(i) = A(i)*X(i)
DS(i) = (E(i)-(D(i)*DS(i+1)))*X(i)
enddo
Y(2*snl_lcl+1) = DS(2*snl_lcl+1)
do i=(2*snl_lcl+2),0,1
Y(i) = DS(i)-(AS(i)*Y(i-1))
enddo
! Downward direct-beam and net flux (F_net) at the base of each layer:
do i=snl_top,snl_btm,1
F_direct(i) = mu_not*pi*flx_slrd_lcl(bnd_idx)*exp(-(tau_clm(i)+tau_star(i))/mu_not)
F_net(i) = (Y(2*i-1)*(e1(i)-e3(i))) + (Y(2*i)*(e2(i)-e4(i))) + &
C_pls_btm(i) - C_mns_btm(i) - F_direct(i)
enddo
! Upward flux at snowpack top:
F_sfc_pls = (Y(2*snl_lcl+1)*(exp(-lambda(snl_top)*tau_star(snl_top))+ &
GAMMA(snl_top))) + (Y(2*snl_lcl+2)*(exp(-lambda(snl_top)* &
tau_star(snl_top))-GAMMA(snl_top))) + C_pls_top(snl_top)
! Net flux at bottom = absorbed radiation by underlying surface:
F_btm_net = -F_net(snl_btm)
! Bulk column albedo and surface net flux
albedo = F_sfc_pls/((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx))
F_sfc_net = F_sfc_pls - ((mu_not*pi*flx_slrd_lcl(bnd_idx))+flx_slri_lcl(bnd_idx))
trip = 0
! Absorbed flux in each layer
do i=snl_top,snl_btm,1
if(i==snl_top) then
F_abs(i) = F_net(i)-F_sfc_net
else
F_abs(i) = F_net(i)-F_net(i-1)
endif
flx_abs_lcl(i,bnd_idx) = F_abs(i)
! ERROR check: negative absorption
if (flx_abs_lcl(i,bnd_idx) < -0.00001) then
trip = 1
endif
enddo
flx_abs_lcl(1,bnd_idx) = F_btm_net
if (flg_nosnl == 1) then
! If there are no snow layers (but still snow), all absorbed energy must be in top soil layer
!flx_abs_lcl(:,bnd_idx) = 0._r8
!flx_abs_lcl(1,bnd_idx) = F_abs(0) + F_btm_net
! changed on 20070408:
! OK to put absorbed energy in the fictitous snow layer because routine SurfaceRadiation
! handles the case of no snow layers. Then, if a snow layer is addded between now and
! SurfaceRadiation (called in Hydrology1), absorbed energy will be properly distributed.
flx_abs_lcl(0,bnd_idx) = F_abs(0)
flx_abs_lcl(1,bnd_idx) = F_btm_net
endif
!Underflow check (we've already tripped the error condition above)
do i=snl_top,1,1
if (flx_abs_lcl(i,bnd_idx) < 0._r8) then
flx_abs_lcl(i,bnd_idx) = 0._r8
endif
enddo
F_abs_sum = 0._r8
do i=snl_top,snl_btm,1
F_abs_sum = F_abs_sum + F_abs(i)
enddo
!ERROR check: absorption greater than incident flux
! (should make condition more generic than "1._r8")
if (F_abs_sum > 1._r8) then
trip = 1
endif
!ERROR check:
if ((albedo < 0._r8).and.(trip==0)) then
write(6,*) 'ERROR: albedo <0 = ', albedo
trip = 1
endif
! Set conditions for redoing RT calculation
if ((trip == 1).and.(flg_dover == 1)) then
flg_dover = 2
elseif ((trip == 1).and.(flg_dover == 2)) then
flg_dover = 3
elseif ((trip == 1).and.(flg_dover == 3)) then
flg_dover = 4
elseif((trip == 1).and.(flg_dover == 4).and.(err_idx < 20)) then
flg_dover = 3
err_idx = err_idx + 1
write(6,*) "SNICAR WARNING: Both approximations failed with new zenith angle :(. Zenith= ", mu_not, &
" called from: ", flg_snw_ice, " flg_slr= ", flg_slr_in, " bnd= ", bnd_idx, " Moving the sun..."
elseif((trip == 1).and.(flg_dover == 4).and.(err_idx >= 20)) then
flg_dover = 0
write(6,*) "SNICAR ERROR: FOUND A WORMHOLE. STUCK IN INFINITE LOOP! Called from: ", flg_snw_ice
write(6,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(c_idx,0)
write(6,*) "SNICAR STATS: L_snw(0)= ", L_snw(0)
write(6,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl
write(6,*) "SNICAR STATS: soot1(0)= ", mss_cnc_aer_lcl(0,1)
write(6,*) "SNICAR STATS: soot2(0)= ", mss_cnc_aer_lcl(0,2)
write(6,*) "SNICAR STATS: dust1(0)= ", mss_cnc_aer_lcl(0,3)
write(6,*) "SNICAR STATS: dust2(0)= ", mss_cnc_aer_lcl(0,4)
write(6,*) "SNICAR STATS: dust3(0)= ", mss_cnc_aer_lcl(0,5)
write(6,*) "SNICAR STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6)
call endrun()
else
flg_dover = 0
endif
enddo !enddo while (flg_dover > 0)
! Energy conservation check:
! Incident direct+diffuse radiation equals (absorbed+bulk_transmitted+bulk_reflected)
energy_sum = (mu_not*pi*flx_slrd_lcl(bnd_idx)) + flx_slri_lcl(bnd_idx) - (F_abs_sum + F_btm_net + F_sfc_pls)
if (abs(energy_sum) > 0.00001_r8) then
write (6,"(a,e12.6,a,i6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum, &
" at timestep: ", nstep, " at column: ", c_idx
call endrun()
endif
albout_lcl(bnd_idx) = albedo
! Check that albedo is less than 1
if (albout_lcl(bnd_idx) > 1.0) then
write (6,*) "SNICAR ERROR: Albedo > 1.0 at c: ", c_idx, " NSTEP= ",nstep
write (6,*) "SNICAR STATS: bnd_idx= ",bnd_idx
write (6,*) "SNICAR STATS: albout_lcl(bnd)= ",albout_lcl(bnd_idx), " albsfc_lcl(bnd_idx)= ",albsfc_lcl(bnd_idx)
write (6,*) "SNICAR STATS: landtype= ", sfctype
write (6,*) "SNICAR STATS: h2osno= ", h2osno_lcl, " snl= ", snl_lcl
write (6,*) "SNICAR STATS: coszen= ", coszen(c_idx), " flg_slr= ", flg_slr_in
write (6,*) "SNICAR STATS: soot(-4)= ", mss_cnc_aer_lcl(-4,1)
write (6,*) "SNICAR STATS: soot(-3)= ", mss_cnc_aer_lcl(-3,1)
write (6,*) "SNICAR STATS: soot(-2)= ", mss_cnc_aer_lcl(-2,1)
write (6,*) "SNICAR STATS: soot(-1)= ", mss_cnc_aer_lcl(-1,1)
write (6,*) "SNICAR STATS: soot(0)= ", mss_cnc_aer_lcl(0,1)
write (6,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4)
write (6,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3)
write (6,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2)
write (6,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1)
write (6,*) "SNICAR STATS: L_snw(0)= ", L_snw(0)
write (6,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(c_idx,-4)
write (6,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(c_idx,-3)
write (6,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(c_idx,-2)
write (6,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(c_idx,-1)
write (6,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(c_idx,0)
call endrun()
endif
enddo ! loop over wvl bands
! Weight output NIR albedo appropriately
albout(c_idx,1) = albout_lcl(1)
flx_sum = 0._r8
do bnd_idx= nir_bnd_bgn,nir_bnd_end
flx_sum = flx_sum + flx_wgt(bnd_idx)*albout_lcl(bnd_idx)
end do
albout(c_idx,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end))
! Weight output NIR absorbed layer fluxes (flx_abs) appropriately
flx_abs(c_idx,:,1) = flx_abs_lcl(:,1)
do i=snl_top,1,1
flx_sum = 0._r8
do bnd_idx= nir_bnd_bgn,nir_bnd_end
flx_sum = flx_sum + flx_wgt(bnd_idx)*flx_abs_lcl(i,bnd_idx)
enddo
flx_abs(c_idx,i,2) = flx_sum / sum(flx_wgt(nir_bnd_bgn:nir_bnd_end))
end do
! Write diagnostics, if desired. (default is to not compile this)
#if 0
write(6,*) "SNICAR STATS: NSTEP= ", nstep
write(6,*) "SNICAR STATS: Col: ", c_idx
write(6,*) "SNICAR STATS: snl(c)= ",snl_lcl
write(6,*) "SNICAR STATS: cosine zenith= ", coszen(c_idx)
write(6,*) "SNICAR STATS: h2osno(c): ", h2osno_lcl
write(6,*) "SNICAR STATS: albout_lcl(1): ", albout_lcl(1)
write(6,*) "SNICAR STATS: albout_lcl(2): ", albout_lcl(2)
write(6,*) "SNICAR STATS: albout_lcl(3): ", albout_lcl(3)
write(6,*) "SNICAR STATS: albout_lcl(4): ", albout_lcl(4)
write(6,*) "SNICAR STATS: albout_lcl(5): ", albout_lcl(5)
write(6,*) "SNICAR STATS: albout(1): ", albout(c_idx,1)
write(6,*) "SNICAR STATS: albout(2): ", albout(c_idx,2)
write(6,*) "SNICAR STATS: NIR flx_abs(-4): ", flx_abs(c_idx,-4,2)
write(6,*) "SNICAR STATS: NIR flx_abs(-3): ", flx_abs(c_idx,-3,2)
write(6,*) "SNICAR STATS: NIR flx_abs(-2): ", flx_abs(c_idx,-2,2)
write(6,*) "SNICAR STATS: NIR flx_abs(-1): ", flx_abs(c_idx,-1,2)
write(6,*) "SNICAR STATS: NIR flx_abs(0): ", flx_abs(c_idx,0,2)
write(6,*) "SNICAR STATS: TOPLYR ABS, BND 1= ", flx_abs_lcl(snl_top,1)
write(6,*) "SNICAR STATS: TOPLYR ABS, BND 2= ", flx_abs_lcl(snl_top,2)
write(6,*) "SNICAR STATS: TOPLYR ABS, BND 3= ", flx_abs_lcl(snl_top,3)
write(6,*) "SNICAR STATS: TOPLYR ABS, BND 4= ", flx_abs_lcl(snl_top,4)
write(6,*) "SNICAR STATS: TOPLYR ABS, BND 5= ", flx_abs_lcl(snl_top,5)
write (6,*) "SNICAR STATS: L_snw(-4)= ", L_snw(-4)
write (6,*) "SNICAR STATS: L_snw(-3)= ", L_snw(-3)
write (6,*) "SNICAR STATS: L_snw(-2)= ", L_snw(-2)
write (6,*) "SNICAR STATS: L_snw(-1)= ", L_snw(-1)
write (6,*) "SNICAR STATS: L_snw(0)= ", L_snw(0)
write (6,*) "SNICAR STATS: snw_rds(-4)= ", snw_rds(c_idx,-4)
write (6,*) "SNICAR STATS: snw_rds(-3)= ", snw_rds(c_idx,-3)
write (6,*) "SNICAR STATS: snw_rds(-2)= ", snw_rds(c_idx,-2)
write (6,*) "SNICAR STATS: snw_rds(-1)= ", snw_rds(c_idx,-1)
write (6,*) "SNICAR STATS: snw_rds(0)= ", snw_rds(c_idx,0)
#endif
! If snow < minimum_snow, but > 0, and there is sun, set albedo to underlying surface albedo
elseif ( (coszen(c_idx) > 0._r8) .and. (h2osno_lcl < min_snw) .and. (h2osno_lcl > 0._r8) ) then
albout(c_idx,1) = albsfc(c_idx,1)
albout(c_idx,2) = albsfc(c_idx,2)
! There is either zero snow, or no sun
else
albout(c_idx,1) = 0._r8
albout(c_idx,2) = 0._r8
endif ! if column has snow and coszen > 0
enddo ! loop over all columns
end subroutine SNICAR_RT
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SnowAge_grain
!
! !INTERFACE:
subroutine SnowAge_grain(lbc, ubc, num_snowc, filter_snowc, num_nosnowc, filter_nosnowc) 1,5
!
! !DESCRIPTION:
! Updates the snow effective grain size (radius).
! Contributions to grain size evolution are from:
! 1. vapor redistribution (dry snow)
! 2. liquid water redistribution (wet snow)
! 3. re-freezing of liquid water
!
! Vapor redistribution: Method is to retrieve 3 best-bit parameters that
! depend on snow temperature, temperature gradient, and density,
! that are derived from the microphysical model described in:
! Flanner and Zender (2006), Linking snowpack microphysics and albedo
! evolution, J. Geophys. Res., 111, D12208, doi:10.1029/2005JD006834.
! The parametric equation has the form:
! dr/dt = drdt_0*(tau/(dr_fresh+tau))^(1/kappa), where:
! r is the effective radius,
! tau and kappa are best-fit parameters,
! drdt_0 is the initial rate of change of effective radius, and
! dr_fresh is the difference between the current and fresh snow states
! (r_current - r_fresh).
!
! Liquid water redistribution: Apply the grain growth function from:
! Brun, E. (1989), Investigation of wet-snow metamorphism in respect of
! liquid-water content, Annals of Glaciology, 13, 22-26.
! There are two parameters that describe the grain growth rate as
! a function of snow liquid water content (LWC). The "LWC=0" parameter
! is zeroed here because we are accounting for dry snowing with a
! different representation
!
! Re-freezing of liquid water: Assume that re-frozen liquid water clumps
! into an arbitrarily large effective grain size (snw_rds_refrz).
! The phenomenon is observed (Grenfell), but so far unquantified, as far as
! I am aware.
!
!
! !USES:
use clmtype
use clm_varpar , only : nlevsno
use clm_varcon , only : spval
use shr_const_mod , only : SHR_CONST_RHOICE, SHR_CONST_PI
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_snowc ! number of column snow points in column filter
integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points
integer, intent(in) :: num_nosnowc ! number of column non-snow points in column filter
integer, intent(in) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points
!
!
! !CALLED FROM: clm_driver1
!
! !LOCAL VARIABLES:
!
! local pointers to implicit arguments
!
real(r8), pointer :: t_soisno(:,:) ! soil and snow temperature (col,lyr) [K]
integer, pointer :: snl(:) ! negative number of snow layers (col) [nbr]
real(r8), pointer :: t_grnd(:) ! ground temperature (col) [K]
real(r8), pointer :: dz(:,:) ! layer thickness (col,lyr) [m]
real(r8), pointer :: h2osno(:) ! snow water (col) [mm H2O]
real(r8), pointer :: snw_rds(:,:) ! effective grain radius (col,lyr) [microns, m-6]
real(r8), pointer :: snw_rds_top(:) ! effective grain radius, top layer (col) [microns, m-6]
real(r8), pointer :: sno_liq_top(:) ! liquid water fraction (mass) in top snow layer (col) [frc]
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water content (col,lyr) [kg m-2]
real(r8), pointer :: h2osoi_ice(:,:) ! ice content (col,lyr) [kg m-2]
real(r8), pointer :: snot_top(:) ! snow temperature in top layer (col) [K]
real(r8), pointer :: dTdz_top(:) ! temperature gradient in top layer (col) [K m-1]
real(r8), pointer :: qflx_snow_grnd_col(:) ! snow on ground after interception (col) [kg m-2 s-1]
real(r8), pointer :: qflx_snwcp_ice(:) ! excess precipitation due to snow capping [kg m-2 s-1]
real(r8), pointer :: qflx_snofrz_lyr(:,:) ! snow freezing rate (col,lyr) [kg m-2 s-1]
logical , pointer :: do_capsnow(:) ! true => do snow capping
!
! !OTHER LOCAL VARIABLES:
!
integer :: snl_top ! top snow layer index [idx]
integer :: snl_btm ! bottom snow layer index [idx]
integer :: i ! layer index [idx]
integer :: c_idx ! column index [idx]
integer :: fc ! snow column filter index [idx]
integer :: T_idx ! snow aging lookup table temperature index [idx]
integer :: Tgrd_idx ! snow aging lookup table temperature gradient index [idx]
integer :: rhos_idx ! snow aging lookup table snow density index [idx]
real(r8) :: t_snotop ! temperature at upper layer boundary [K]
real(r8) :: t_snobtm ! temperature at lower layer boundary [K]
real(r8) :: dTdz(lbc:ubc,-nlevsno:0) ! snow temperature gradient (col,lyr) [K m-1]
real(r8) :: bst_tau ! snow aging parameter retrieved from lookup table [hour]
real(r8) :: bst_kappa ! snow aging parameter retrieved from lookup table [unitless]
real(r8) :: bst_drdt0 ! snow aging parameter retrieved from lookup table [um hr-1]
real(r8) :: dr ! incremental change in snow effective radius [um]
real(r8) :: dr_wet ! incremental change in snow effective radius from wet growth [um]
real(r8) :: dr_fresh ! difference between fresh snow r_e and current r_e [um]
real(r8) :: newsnow ! fresh snowfall [kg m-2]
real(r8) :: refrzsnow ! re-frozen snow [kg m-2]
real(r8) :: frc_newsnow ! fraction of layer mass that is new snow [frc]
real(r8) :: frc_oldsnow ! fraction of layer mass that is old snow [frc]
real(r8) :: frc_refrz ! fraction of layer mass that is re-frozen snow [frc]
real(r8) :: frc_liq ! fraction of layer mass that is liquid water[frc]
real(r8) :: rhos ! snow density [kg m-3]
real(r8) :: h2osno_lyr ! liquid + solid H2O in snow layer [kg m-2]
! Assign local pointers to derived subtypes components (column-level)
t_soisno => clm3%g%l%c%ces%t_soisno
snl => clm3%g%l%c%cps%snl
t_grnd => clm3%g%l%c%ces%t_grnd
dz => clm3%g%l%c%cps%dz
h2osno => clm3%g%l%c%cws%h2osno
snw_rds => clm3%g%l%c%cps%snw_rds
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
snot_top => clm3%g%l%c%cps%snot_top
dTdz_top => clm3%g%l%c%cps%dTdz_top
snw_rds_top => clm3%g%l%c%cps%snw_rds_top
sno_liq_top => clm3%g%l%c%cps%sno_liq_top
qflx_snow_grnd_col => clm3%g%l%c%cwf%pwf_a%qflx_snow_grnd
qflx_snwcp_ice => clm3%g%l%c%cwf%pwf_a%qflx_snwcp_ice
qflx_snofrz_lyr => clm3%g%l%c%cwf%qflx_snofrz_lyr
do_capsnow => clm3%g%l%c%cps%do_capsnow
! loop over columns that have at least one snow layer
do fc = 1, num_snowc
c_idx = filter_snowc(fc)
snl_btm = 0
snl_top = snl(c_idx) + 1
! loop over snow layers
do i=snl_top,snl_btm,1
!
!********** 1. DRY SNOW AGING ***********
!
h2osno_lyr = h2osoi_liq(c_idx,i) + h2osoi_ice(c_idx,i)
! temperature gradient
if (i == snl_top) then
! top layer
t_snotop = t_grnd(c_idx)
t_snobtm = (t_soisno(c_idx,i+1)*dz(c_idx,i) + t_soisno(c_idx,i)*dz(c_idx,i+1)) / (dz(c_idx,i)+dz(c_idx,i+1))
else
t_snotop = (t_soisno(c_idx,i-1)*dz(c_idx,i) + t_soisno(c_idx,i)*dz(c_idx,i-1)) / (dz(c_idx,i)+dz(c_idx,i-1))
t_snobtm = (t_soisno(c_idx,i+1)*dz(c_idx,i) + t_soisno(c_idx,i)*dz(c_idx,i+1)) / (dz(c_idx,i)+dz(c_idx,i+1))
endif
dTdz(c_idx,i) = abs((t_snotop - t_snobtm) / dz(c_idx,i))
! snow density
rhos = (h2osoi_liq(c_idx,i)+h2osoi_ice(c_idx,i)) / dz(c_idx,i)
! best-fit table indecies
T_idx = nint((t_soisno(c_idx,i)-223) / 5) + 1
Tgrd_idx = nint(dTdz(c_idx,i) / 10) + 1
rhos_idx = nint((rhos-50) / 50) + 1
! boundary check:
if (T_idx < idx_T_min) then
T_idx = idx_T_min
endif
if (T_idx > idx_T_max) then
T_idx = idx_T_max
endif
if (Tgrd_idx < idx_Tgrd_min) then
Tgrd_idx = idx_Tgrd_min
endif
if (Tgrd_idx > idx_Tgrd_max) then
Tgrd_idx = idx_Tgrd_max
endif
if (rhos_idx < idx_rhos_min) then
rhos_idx = idx_rhos_min
endif
if (rhos_idx > idx_rhos_max) then
rhos_idx = idx_rhos_max
endif
! best-fit parameters
bst_tau = snowage_tau(T_idx,Tgrd_idx,rhos_idx)
bst_kappa = snowage_kappa(T_idx,Tgrd_idx,rhos_idx)
bst_drdt0 = snowage_drdt0(T_idx,Tgrd_idx,rhos_idx)
! change in snow effective radius, using best-fit parameters
dr_fresh = snw_rds(c_idx,i)-snw_rds_min
dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1/bst_kappa)) * (dtime/3600)
!
!********** 2. WET SNOW AGING ***********
!
! We are assuming wet and dry evolution occur simultaneously, and
! the contributions from both can be summed.
! This is justified by setting the linear offset constant C1_liq_Brun89 to zero [Brun, 1989]
! liquid water faction
frc_liq = min(0.1_r8, (h2osoi_liq(c_idx,i) / (h2osoi_liq(c_idx,i)+h2osoi_ice(c_idx,i))))
!dr_wet = 1E6_r8*(dtime*(C1_liq_Brun89 + C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*(snw_rds(c_idx,i)/1E6)**(2)))
!simplified, units of microns:
dr_wet = 1E18_r8*(dtime*(C2_liq_Brun89*(frc_liq**(3))) / (4*SHR_CONST_PI*snw_rds(c_idx,i)**(2)))
dr = dr + dr_wet
!
!********** 3. SNOWAGE SCALING (TURNED OFF BY DEFAULT) *************
!
! Multiply rate of change of effective radius by some constant, xdrdt
if (flg_snoage_scl) then
dr = dr*xdrdt
endif
!
!********** 4. INCREMENT EFFECTIVE RADIUS, ACCOUNTING FOR: ***********
! DRY AGING
! WET AGING
! FRESH SNOW
! RE-FREEZING
!
! new snowfall [kg/m2]
if (do_capsnow(c_idx)) then
newsnow = max(0._r8, (qflx_snwcp_ice(c_idx)*dtime))
else
newsnow = max(0._r8, (qflx_snow_grnd_col(c_idx)*dtime))
endif
! snow that has re-frozen [kg/m2]
refrzsnow = max(0._r8, (qflx_snofrz_lyr(c_idx,i)*dtime))
! fraction of layer mass that is re-frozen
frc_refrz = refrzsnow / h2osno_lyr
! fraction of layer mass that is new snow
if (i == snl_top) then
frc_newsnow = newsnow / h2osno_lyr
else
frc_newsnow = 0._r8
endif
if ((frc_refrz + frc_newsnow) > 1._r8) then
frc_refrz = frc_refrz / (frc_refrz + frc_newsnow)
frc_newsnow = 1._r8 - frc_refrz
frc_oldsnow = 0._r8
else
frc_oldsnow = 1._r8 - frc_refrz - frc_newsnow
endif
! mass-weighted mean of fresh snow, old snow, and re-frozen snow effective radius
snw_rds(c_idx,i) = (snw_rds(c_idx,i)+dr)*frc_oldsnow + snw_rds_min*frc_newsnow + snw_rds_refrz*frc_refrz
!
!********** 5. CHECK BOUNDARIES ***********
!
! boundary check
if (snw_rds(c_idx,i) < snw_rds_min) then
snw_rds(c_idx,i) = snw_rds_min
endif
if (snw_rds(c_idx,i) > snw_rds_max) then
snw_rds(c_idx,i) = snw_rds_max
end if
! set top layer variables for history files
if (i == snl_top) then
snot_top(c_idx) = t_soisno(c_idx,i)
dTdz_top(c_idx) = dTdz(c_idx,i)
snw_rds_top(c_idx) = snw_rds(c_idx,i)
sno_liq_top(c_idx) = h2osoi_liq(c_idx,i) / (h2osoi_liq(c_idx,i)+h2osoi_ice(c_idx,i))
endif
enddo
enddo
! Special case: snow on ground, but not enough to have defined a snow layer:
! set snw_rds to fresh snow grain size:
do fc = 1, num_nosnowc
c_idx = filter_nosnowc(fc)
if (h2osno(c_idx) > 0._r8) then
snw_rds(c_idx,0) = snw_rds_min
endif
enddo
end subroutine SnowAge_grain
!--------------------------------------------------------------------------------------------------
!ylu removed SnowOptics_init,SnowAge_init, all vars defined in clm_varcon, and some will read in
!table in clmi
!--------------------------------------------------------------------------------------------------
end module SNICARMod
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: mkarbinit
!
! !INTERFACE:
subroutine mkarbinit(snlx ,snowdpx , dzclmx ,zclmx ,& 1,11
ziclmx ,h2osnox ,h2osoi_liqx,h2osoi_icex,t_grndx,&
t_soisnox ,t_lakex ,t_vegx ,h2ocanx ,h2ocan_colx,&
h2osoi_volx,t_ref2mx,snw_rdsx &
#ifdef CN
,tlaix,tsaix,htopx,hbotx &
#endif
)
! !DESCRIPTION:
! Initializes the following time varying variables:
! water : h2osno, h2ocan, h2osoi_liq, h2osoi_ice, h2osoi_vol
! snow : snowdp, snowage, snl, dz, z, zi
! temperature: t_soisno, t_veg, t_grnd
! The variable, h2osoi_vol, is needed by clm_soilalb -this is not needed on
! restart since it is computed before the soil albedo computation is called.
! The remaining variables are initialized by calls to ecosystem dynamics
! and albedo subroutines.
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use decompMod , only : get_proc_bounds
use clm_varpar , only : nlevgrnd,nlevsoi, nlevsno, nlevlak,maxpatch
use clm_varcon , only : bdsno, istice, istwet, istsoil, &
denice, denh2o, spval, sb, tfrz
use SNICARMod , only : snw_rds_min
use globals , only : nstep
!
! !ARGUMENTS:
implicit none
!
! !CALLED FROM:
! subroutine iniTimeVar
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: pcolumn(:) ! column index associated with each pft
integer , pointer :: clandunit(:) ! landunit index associated with each column
integer , pointer :: ltype(:) ! landunit type
logical , pointer :: lakpoi(:) ! true => landunit is a lake point
real(r8), pointer :: dz(:,:) ! layer thickness depth (m)
real(r8), pointer :: zi(:,:) ! interface depth (m) over snow only
real(r8), pointer :: z(:,:) ! interface depth (m) over snow only
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity) (nlevsoi)
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
real(r8), pointer :: bsw2(:,:) ! Clapp and Hornberger "b" for CN code
real(r8), pointer :: psisat(:,:) ! soil water potential at saturation for CN code (MPa)
real(r8), pointer :: vwcsat(:,:) ! volumetric water content at saturation for CN code (m3/m3)
! real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m)
!Is it different now, not just for snow?????
real(r8), pointer :: wa(:) ! water in the unconfined aquifer (mm)
real(r8), pointer :: wt(:) ! total water storage (unsaturated soil water + groundwater) (mm)
real(r8), pointer :: zwt(:) ! water table depth (m)
real(r8), pointer :: h2ocan_loss(:) ! canopy water mass balance term (column)
!!!!!!!!!!!!!!!!!!!!!!!!
!
! local pointers to implicit out arguments
!
integer , pointer :: snl(:) ! number of snow layers
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevsoi)
real(r8), pointer :: t_lake(:,:) ! lake temperature (Kelvin) (1:nlevlak)
real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin)
real(r8), pointer :: t_veg(:) ! vegetation temperature (Kelvin)
real(r8), pointer :: h2osoi_vol(:,:) ! volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3]
real(r8), pointer :: h2ocan_col(:) ! canopy water (mm H2O) (column-level)
real(r8), pointer :: h2ocan_pft(:) ! canopy water (mm H2O) (pft-level)
real(r8), pointer :: h2osno(:) ! snow water (mm H2O)
real(r8), pointer :: snowdp(:) ! snow height (m)
#ifdef CN
real(r8), pointer :: tlai(:) ! one-sided leaf area index, no burying by snow
real(r8), pointer :: tsai(:) ! one-sided stem area index, no burying by snow
real(r8), pointer :: htop(:) ! canopy top (m)
real(r8), pointer :: hbot(:) ! canopy bottom (m)
#endif
real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (Kelvin)
real(r8) :: t_ref2mx(maxpatch)
! real(r8), pointer :: snowage(:) ! non dimensional snow age [-] (new)
real(r8), pointer :: eflx_lwrad_out(:) ! emitted infrared (longwave) radiation (W/m**2)
!New variables
real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa)
!!!!!!!!!!!!!!!
! The following vraiables for a WRF restart run
integer :: snlx(maxpatch)
real(r8) :: snowdpx(maxpatch)
! real(r8) :: snowagex(maxpatch)
real(r8) :: h2osnox(maxpatch)
real(r8) :: t_grndx(maxpatch)
real(r8) :: t_vegx(maxpatch)
real(r8) :: h2ocanx(maxpatch)
real(r8) :: h2ocan_colx(maxpatch)
real(r8) :: snw_rdsx(maxpatch,-nlevsno+1:0)
real(r8) :: t_lakex(maxpatch,nlevlak)
real(r8) :: t_soisnox(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: h2osoi_liqx(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: h2osoi_icex(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: dzclmx(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: zclmx(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: ziclmx(maxpatch,-nlevsno:nlevgrnd)
real(r8) :: h2osoi_volx(maxpatch,nlevgrnd)
#ifdef CN
real(r8) :: tlaix(maxpatch)
real(r8) :: tsaix(maxpatch)
real(r8) :: htopx(maxpatch)
real(r8) :: hbotx(maxpatch)
#endif
real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6]
real(r8), pointer :: snw_rds_top(:) ! snow grain size, top (col) [microns]
real(r8), pointer :: sno_liq_top(:) ! liquid water fraction (mass) in top snow layer (col) [frc]
real(r8), pointer :: mss_bcpho(:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bcphi(:,:) ! mass of hydrophillic BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bctot(:,:) ! total mass of BC (pho+phi) (col,lyr) [kg]
real(r8), pointer :: mss_bc_col(:) ! total mass of BC in snow column (col) [kg]
real(r8), pointer :: mss_bc_top(:) ! total mass of BC in top snow layer (col) [kg]
real(r8), pointer :: mss_cnc_bcphi(:,:) ! mass concentration of BC species 1 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_bcpho(:,:) ! mass concentration of BC species 2 (col,lyr) [kg/kg]
real(r8), pointer :: mss_ocpho(:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocphi(:,:) ! mass of hydrophillic OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_octot(:,:) ! total mass of OC (pho+phi) (col,lyr) [kg]
real(r8), pointer :: mss_oc_col(:) ! total mass of OC in snow column (col) [kg]
real(r8), pointer :: mss_oc_top(:) ! total mass of OC in top snow layer (col) [kg]
real(r8), pointer :: mss_cnc_ocphi(:,:) ! mass concentration of OC species 1 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_ocpho(:,:) ! mass concentration of OC species 2 (col,lyr) [kg/kg]
real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dsttot(:,:) ! total mass of dust in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst_col(:) ! total mass of dust in snow column (col) [kg]
real(r8), pointer :: mss_dst_top(:) ! total mass of dust in top snow layer (col) [kg]
real(r8), pointer :: mss_cnc_dst1(:,:) ! mass concentration of dust species 1 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst2(:,:) ! mass concentration of dust species 2 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst3(:,:) ! mass concentration of dust species 3 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst4(:,:) ! mass concentration of dust species 4 (col,lyr) [kg/kg]
!
!EeP
!
! !OTHER LOCAL VARIABLES:
integer :: j,l,c,p ! indices
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
real(r8):: vwc,psi ! for calculating soilpsi
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (landunit-level)
ltype => clm3%g%l%itype
lakpoi => clm3%g%l%lakpoi
! Assign local pointers to derived subtypes components (column-level)
clandunit => clm3%g%l%c%landunit
snl => clm3%g%l%c%cps%snl
dz => clm3%g%l%c%cps%dz
zi => clm3%g%l%c%cps%zi
z => clm3%g%l%c%cps%z
watsat => clm3%g%l%c%cps%watsat
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_vol => clm3%g%l%c%cws%h2osoi_vol
h2ocan_col => clm3%g%l%c%cws%pws_a%h2ocan
! snowage => clm3%g%l%c%cps%snowage
snowdp => clm3%g%l%c%cps%snowdp
h2osno => clm3%g%l%c%cws%h2osno
t_soisno => clm3%g%l%c%ces%t_soisno
t_lake => clm3%g%l%c%ces%t_lake
t_grnd => clm3%g%l%c%ces%t_grnd
!New variables
bsw2 => clm3%g%l%c%cps%bsw2
vwcsat => clm3%g%l%c%cps%vwcsat
psisat => clm3%g%l%c%cps%psisat
soilpsi => clm3%g%l%c%cps%soilpsi
wa => clm3%g%l%c%cws%wa
wt => clm3%g%l%c%cws%wt
zwt => clm3%g%l%c%cws%zwt
h2ocan_loss => clm3%g%l%c%cwf%h2ocan_loss
!!!!!!
snw_rds => clm3%g%l%c%cps%snw_rds
snw_rds_top => clm3%g%l%c%cps%snw_rds_top
sno_liq_top => clm3%g%l%c%cps%sno_liq_top
mss_bcpho => clm3%g%l%c%cps%mss_bcpho
mss_bcphi => clm3%g%l%c%cps%mss_bcphi
mss_bctot => clm3%g%l%c%cps%mss_bctot
mss_bc_col => clm3%g%l%c%cps%mss_bc_col
mss_bc_top => clm3%g%l%c%cps%mss_bc_top
mss_cnc_bcphi => clm3%g%l%c%cps%mss_cnc_bcphi
mss_cnc_bcpho => clm3%g%l%c%cps%mss_cnc_bcpho
mss_ocpho => clm3%g%l%c%cps%mss_ocpho
mss_ocphi => clm3%g%l%c%cps%mss_ocphi
mss_octot => clm3%g%l%c%cps%mss_octot
mss_oc_col => clm3%g%l%c%cps%mss_oc_col
mss_oc_top => clm3%g%l%c%cps%mss_oc_top
mss_cnc_ocphi => clm3%g%l%c%cps%mss_cnc_ocphi
mss_cnc_ocpho => clm3%g%l%c%cps%mss_cnc_ocpho
mss_dst1 => clm3%g%l%c%cps%mss_dst1
mss_dst2 => clm3%g%l%c%cps%mss_dst2
mss_dst3 => clm3%g%l%c%cps%mss_dst3
mss_dst4 => clm3%g%l%c%cps%mss_dst4
mss_dsttot => clm3%g%l%c%cps%mss_dsttot
mss_dst_col => clm3%g%l%c%cps%mss_dst_col
mss_dst_top => clm3%g%l%c%cps%mss_dst_top
mss_cnc_dst1 => clm3%g%l%c%cps%mss_cnc_dst1
mss_cnc_dst2 => clm3%g%l%c%cps%mss_cnc_dst2
mss_cnc_dst3 => clm3%g%l%c%cps%mss_cnc_dst3
mss_cnc_dst4 => clm3%g%l%c%cps%mss_cnc_dst4
t_ref2m => clm3%g%l%c%p%pes%t_ref2m
#ifdef CN
htop => clm3%g%l%c%p%pps%htop
hbot => clm3%g%l%c%p%pps%hbot
tlai => clm3%g%l%c%p%pps%tlai
tsai => clm3%g%l%c%p%pps%tsai
#endif
! Assign local pointers to derived subtypes components (pft-level)
pcolumn => clm3%g%l%c%p%column
h2ocan_pft => clm3%g%l%c%p%pws%h2ocan
t_veg => clm3%g%l%c%p%pes%t_veg
eflx_lwrad_out => clm3%g%l%c%p%pef%eflx_lwrad_out
! Determine subgrid bounds on this processor
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! ========================================================================
! Set snow water
! ========================================================================
! NOTE: h2ocan, h2osno, snowdp and snowage has valid values everywhere
! canopy water (pft level)
do p = begp, endp
h2ocan_pft(p) = h2ocanx(p)
t_ref2m(p) = t_ref2mx(p)
#ifdef CN
htop(p) = htopx(p)
hbot(p) = hbotx(p)
tlai(p) = tlaix(p)
write(6,*) 'tlaix(',p,')=',tlaix(p)
tsai(p) = tsaix(p)
#endif
end do
!dir$ concurrent
!cdir nodep
do c = begc,endc
! canopy water (column level)
h2ocan_col(c) = h2ocan_colx(c)
!New variable: canopy water loss
h2ocan_loss(c) = 0._r8
! snow water
h2osno(c) = h2osnox(c)
! snow depth
snowdp(c) = snowdpx(c)
! snow age
! snowage(c) = snowagex(c)
end do
! ========================================================================
! Set snow layer number, depth and thickiness
! ========================================================================
do c = begc,endc
! snl(c) = snlx(c)
dz(c,-nlevsno+1:0) = dzclmx(c,-nlevsno+1:0)
z(c,-nlevsno+1:0) = zclmx(c,-nlevsno+1:0)
zi(c,-nlevsno+0:0) = ziclmx(c,-nlevsno+0:0)
end do
do c = begc,endc
snl(c) = snlx(c)
dz(c,1:nlevgrnd) = dzclmx(c,1:nlevgrnd)
z(c,1:nlevgrnd) = zclmx(c,1:nlevgrnd)
zi(c,1:nlevgrnd) = ziclmx(c,1:nlevgrnd)
end do
! write(6,*) 'snlx=',snlx
! ========================================================================
! Set snow/soil temperature
! ========================================================================
! NOTE:
! t_soisno only has valid values over non-lake
! t_lake only has valid values over lake
! t_grnd has valid values over all land
! t_veg has valid values over all land
!dir$ concurrent
!cdir nodep
do c = begc,endc
t_soisno(c,-nlevsno+1:nlevgrnd) = t_soisnox(c,-nlevsno+1:nlevgrnd) !in CLM4,nlevsoil=>nlevgrnd
t_lake(c,1:nlevlak) = t_lakex(c,1:nlevlak)
t_grnd(c) = t_grndx(c)
end do
! write(6,*) 'in mkabinit, t_soisnox=',t_soisnox
!dir$ concurrent
!cdir nodep
do p = begp, endp
c = pcolumn(p)
t_veg(p) = t_vegx(c)
eflx_lwrad_out(p) = sb * (t_grnd(c))**4
end do
! ========================================================================
! Set snow/soil ice and liquid mass
! ========================================================================
! volumetric water is set first and liquid content and ice lens are obtained
! NOTE: h2osoi_vol, h2osoi_liq and h2osoi_ice only have valid values over soil
do c = begc,endc
do j=1,nlevgrnd
h2osoi_vol(c,j) = h2osoi_volx(c,j)
end do
do j=-nlevsno+1,nlevgrnd
h2osoi_liq(c,j) = h2osoi_liqx(c,j)
h2osoi_ice(c,j) = h2osoi_icex(c,j)
end do
end do
call CLMDebug('initialize SNICAR')
! write(6,*) 'snl=',snl
! initialize SNICAR fields:
! may need to change later.
do c = begc,endc
mss_bctot(c,:) = 0._r8
mss_bcpho(c,:) = 0._r8 !r
mss_bcphi(c,:) = 0._r8 !r
mss_cnc_bcphi(c,:)=0._r8
mss_cnc_bcpho(c,:)=0._r8
mss_octot(c,:) = 0._r8
mss_ocpho(c,:) = 0._r8 !r
mss_ocphi(c,:) = 0._r8 !r
mss_cnc_ocphi(c,:)=0._r8
mss_cnc_ocpho(c,:)=0._r8
mss_dst1(c,:) = 0._r8 !r
mss_dst2(c,:) = 0._r8 !r
mss_dst3(c,:) = 0._r8 !r
mss_dst4(c,:) = 0._r8 !r 5layers
mss_dsttot(c,:) = 0._r8
mss_cnc_dst1(c,:)=0._r8
mss_cnc_dst2(c,:)=0._r8
mss_cnc_dst3(c,:)=0._r8
mss_cnc_dst4(c,:)=0._r8
! if(nstep == 1) then
! if (snl(c) < 0) then
! snw_rds(c,snl(c)+1:0) = snw_rds_min
! snw_rds(c,-nlevsno+1:snl(c)) = 0._r8
! snw_rds_top(c) = snw_rds_min
! sno_liq_top(c) = h2osoi_liq(c,snl(c)+1) / (h2osoi_liq(c,snl(c)+1)+h2osoi_ice(c,snl(c)+1))
! elseif (h2osno(c) > 0._r8) then
! snw_rds(c,0) = snw_rds_min
! snw_rds(c,-nlevsno+1:-1) = 0._r8
! snw_rds_top(c) = spval
! sno_liq_top(c) = spval
! else
! snw_rds(c,:) = 0._r8
! snw_rds_top(c) = spval
! sno_liq_top(c) = spval
! endif
! else
snw_rds(c,-nlevsno+1:0) = snw_rdsx(c,-nlevsno+1:0)
! end if
enddo
call CLMDebug('mark1')
!New variables
wa(begc:endc) = 5000._r8
wt(begc:endc) = 5000._r8
zwt(begc:endc) = 0._r8
!!!!!!!!
!Switched loop order
do c = begc,endc
!For new variables
l = clandunit(c)
if (.not. lakpoi(l)) then !not lake
wa(c) = 4800._r8
wt(c) = wa(c)
zwt(c) = (25._r8 + zi(c,nlevsoi)) - wa(c)/0.2_r8 /1000._r8 ! One meter below soil column
end if
!!!!!!!
do j = 1,nlevgrnd !changed nlevsoi => nlevgrnd
l = clandunit(c)
if (.not. lakpoi(l)) then !not lake
! volumetric water
if(h2osoi_vol(c,j) > watsat(c,j)) then
h2osoi_vol(c,j) = watsat(c,j)
if(h2osoi_liq(c,j)/(dz(c,j)*denh2o)+ &
h2osoi_ice(c,j)/(dz(c,j)*denice)> &
h2osoi_vol(c,j) ) then
if(t_soisno(c,j) > tfrz) then
h2osoi_liq(c,j) = dz(c,j)*denh2o*watsat(c,j)
h2osoi_ice(c,j) = 0.0
else
h2osoi_liq(c,j) = 0.0
h2osoi_ice(c,j) = dz(c,j)*denice*watsat(c,j)
end if
end if
endif
!For CN
#if (defined CN)
! soil water potential (added 10/21/03, PET)
! required for CN code
if (ltype(l) == istsoil) then
if (h2osoi_liq(c,j) > 0._r8) then
vwc = h2osoi_liq(c,j)/(dz(c,j)*denh2o)
psi = psisat(c,j) * (vwc/vwcsat(c,j))**bsw2(c,j)
soilpsi(c,j) = max(psi, -15.0_r8)
soilpsi(c,j) = min(soilpsi(c,j),0.0_r8)
end if
end if
#endif
!!!!!!!!!!!!!!
end if
end do
end do
#ifdef DGVM
! Determine new subgrid weights and areas (obtained
! from new value of fpcgrid read in above) - this is needed
! here to avoid round off level errors on restart before
! lpj is called the first time
call resetWeightsDGVM(begg, endg, begc, endc, begp, endp)
#endif
call CLMDebug('done mkarbinit')
end subroutine mkarbinit
module aerdepMOD 2,4
!-----------------------------------------------------------------------
! This entire module will be removed....................
!BOP
!
! !MODULE: aerdepMod
!
! !DESCRIPTION:
! read an interpolate aerosol deposition data
!
! !USES:
use shr_kind_mod, only : r8 => shr_kind_r8
use clm_varcon , only : secspday,set_caerdep_from_file, set_dustdep_from_file
use decompMod , only : get_proc_bounds
use module_cam_support, only: endrun
!
! !PUBLIC TYPES:
implicit none
private
! !INCLUDES:
!
! !PUBLIC MEMBER FUNCTIONS:
public :: interpMonthlyAerdep ! interpolate monthly aerosol deposition data
public :: aerdepini ! aerosol deposition initialization
!
! !REVISION HISTORY:
! Created by Mark Flanner,
! based on vegetation interpolation schemes in STATICEcosystemDynMod
! 2009-Apr-17 B. Kauffman -- added multi-year time series functionality
!
!
! !PRIVATE MEMBER FUNCTIONS:
private :: readMonthlyAerdep ! read monthly aerosol deposition data for two months
!
! !PRIVATE TYPES:
!EOP
real(r8), save, private, allocatable :: bcphiwet2t(:,:)
real(r8), save, private, allocatable :: bcphidry2t(:,:)
real(r8), save, private, allocatable :: bcphodry2t(:,:)
real(r8), save, private, allocatable :: ocphiwet2t(:,:)
real(r8), save, private, allocatable :: ocphidry2t(:,:)
real(r8), save, private, allocatable :: ocphodry2t(:,:)
real(r8), save, private, allocatable :: dstx01wd2t(:,:)
real(r8), save, private, allocatable :: dstx01dd2t(:,:)
real(r8), save, private, allocatable :: dstx02wd2t(:,:)
real(r8), save, private, allocatable :: dstx02dd2t(:,:)
real(r8), save, private, allocatable :: dstx03wd2t(:,:)
real(r8), save, private, allocatable :: dstx03dd2t(:,:)
real(r8), save, private, allocatable :: dstx04wd2t(:,:)
real(r8), save, private, allocatable :: dstx04dd2t(:,:)
integer,parameter :: nt =12 ! size of time(:) array
real(r8) :: time(12) ! data time, elapsed days since 0000-01-01 0s
real(r8),parameter :: daysPerYear = 365.0_r8 ! days per year
integer,parameter :: debug = 1 ! internal debug level
!================================================================================
contains
!================================================================================
!BOP
!
! !IROUTINE: aerdepini
!
! !INTERFACE:
subroutine aerdepini() 1,4
!
! !DESCRIPTION:
! Dynamically allocate memory and set to signaling NaN.
!
! !USES:
use nanMod , only : nan
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! 2009-Apr-17 B. Kauffman -- added multi-year time series functionality
!
!
! !LOCAL VARIABLES:
!EOP
integer :: ier ! error code
integer :: begg,endg ! local beg and end p index
character(256) :: locfn ! local file name
integer :: ncid,dimid,varid ! input netCDF id's
! integer,allocatable :: cdate(:) ! calendar date yyyymmdd
! integer,allocatable :: eday(:) ! elapsed days since 0000-01-01
! integer,allocatable :: secs(:) ! elapsed secs within current date
integer :: n ! loop index
integer :: m1,m2 ! month 1, month 2
integer, parameter :: ndaypm(12) = &
(/31,28,31,30,31,30,31,31,30,31,30,31/) !days per month
character(*),parameter :: subName = '(aerdepini) '
character(*),parameter :: F00 = "('(aerdepini) ',4a)"
character(*),parameter :: F01 = "('(aerdepini) ',a,4f13.3)"
!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------
call get_proc_bounds(begg=begg,endg=endg)
if ( set_caerdep_from_file )then
ier = 0
if(.not.allocated(bcphiwet2t)) then
allocate(bcphiwet2t(begg:endg,2))
allocate(bcphidry2t(begg:endg,2))
allocate(bcphodry2t(begg:endg,2))
allocate(ocphiwet2t(begg:endg,2))
allocate(ocphidry2t(begg:endg,2))
allocate(ocphodry2t(begg:endg,2))
endif
if (ier /= 0) then
write(6,*) 'aerdepini allocation error'
call endrun()
end if
bcphiwet2t(begg:endg,1:2) = nan
bcphidry2t(begg:endg,1:2) = nan
bcphodry2t(begg:endg,1:2) = nan
ocphiwet2t(begg:endg,1:2) = nan
ocphidry2t(begg:endg,1:2) = nan
ocphodry2t(begg:endg,1:2) = nan
end if
if ( set_dustdep_from_file )then
allocate(dstx01wd2t(begg:endg,2))
allocate(dstx01dd2t(begg:endg,2))
allocate(dstx02wd2t(begg:endg,2))
allocate(dstx02dd2t(begg:endg,2))
allocate(dstx03wd2t(begg:endg,2))
allocate(dstx03dd2t(begg:endg,2))
allocate(dstx04wd2t(begg:endg,2))
allocate(dstx04dd2t(begg:endg,2))
if (ier /= 0) then
write(6,*) 'aerdepini allocation error'
call endrun()
end if
dstx01wd2t(begg:endg,1:2) = nan
dstx01dd2t(begg:endg,1:2) = nan
dstx02wd2t(begg:endg,1:2) = nan
dstx02dd2t(begg:endg,1:2) = nan
dstx03wd2t(begg:endg,1:2) = nan
dstx03dd2t(begg:endg,1:2) = nan
dstx04wd2t(begg:endg,1:2) = nan
dstx04dd2t(begg:endg,1:2) = nan
end if
!----------------------------------------------------------------------------
! read time axis from data file
!----------------------------------------------------------------------------
n = 365
time( 1) = n + float(ndaypm( 1))/2.0_r8 ; n = n + ndaypm( 1)
time( 2) = n + float(ndaypm( 2))/2.0_r8 ; n = n + ndaypm( 2)
time( 3) = n + float(ndaypm( 3))/2.0_r8 ; n = n + ndaypm( 3)
time( 4) = n + float(ndaypm( 4))/2.0_r8 ; n = n + ndaypm( 4)
time( 5) = n + float(ndaypm( 5))/2.0_r8 ; n = n + ndaypm( 5)
time( 6) = n + float(ndaypm( 6))/2.0_r8 ; n = n + ndaypm( 6)
time( 7) = n + float(ndaypm( 7))/2.0_r8 ; n = n + ndaypm( 7)
time( 8) = n + float(ndaypm( 8))/2.0_r8 ; n = n + ndaypm( 8)
time( 9) = n + float(ndaypm( 9))/2.0_r8 ; n = n + ndaypm( 9)
time(10) = n + float(ndaypm(10))/2.0_r8 ; n = n + ndaypm(10)
time(11) = n + float(ndaypm(11))/2.0_r8 ; n = n + ndaypm(11)
time(12) = n + float(ndaypm(12))/2.0_r8
end subroutine aerdepini
!================================================================================
!BOP
!
! !IROUTINE: interpMonthlyAerdep
!
! !INTERFACE:
subroutine interpMonthlyAerdep (kmo, kda) 1,10
!
! !DESCRIPTION:
! Determine if 2 new months of data are to be read.
!
! !USES:
use clmtype
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! 2009-Apr-17 B. Kauffman -- added multi-year time series functionality
! Adapted by Mark Flanner
!
!
!
! local pointers to implicit out arguments
!
real(r8), pointer :: forc_aer(:,:) ! aerosol deposition rate (kg/m2/s)
! !LOCAL VARIABLES:
!EOP
real(r8):: timwt_aer(2) ! time weights for month 1 and month 2 (aerosol deposition)
integer :: kmo ! month (1, ..., 12)
integer :: kda ! day of month (1, ..., 31)
integer :: g
integer :: begg,endg ! beg and end local g index
integer :: n ! counter to prevent infinite LB/UB search
integer :: edays ! elapsed days since 0000-01-01 0s (excluding partial days)
real(r8) :: t ! model time, elapsed days since 0000-01-01
integer ,save :: nLB = 0 ! tLB = time(nLB)
integer ,save :: nUB = 1 ! tUB = time(nUB)
real(r8),save :: tLB =-1.0 ! upper bound time sample, model time is in [tLB,tUB]
real(r8),save :: tUB =-2.0 ! lower bound time sample, model time is in [tLB,tUB]
real(r8) :: fUB,fLB ! t-interp fracs for UB,LB
logical ,save :: firstCallA = .true. ! id 1st occurance of case A
logical ,save :: firstCallB = .true. ! id 1st occurance of case B
logical ,save :: firstCallC = .true. ! id 1st occurance of case C
character(1) :: case ! flags case A, B, or C
logical :: readNewData ! T <=> read new LB,UB data
integer, parameter :: ndaypm(12) = &
(/31,28,31,30,31,30,31,31,30,31,30,31/) !days per month
character(*),parameter :: subName = '(interpMonthlyAerdep) '
character(*),parameter :: F00 = "('(interpMonthlyAerdep) ',4a)"
character(*),parameter :: F01 = "('(interpMonthlyAerdep) ',a,i4.4,2('-',i2.2),3f11.2,2i6,2x,2f6.3)"
character(*),parameter :: F02 = "('(interpMonthlyAerdep) ',a,i4.4,2('-',i2.2),i7,'s ',f12.3)"
!-------------------------------------------------------------------------------
! WARNING: this is (and has always been) hard-coded to assume 365 days per year
!-------------------------------------------------------------------------------
! Determine necessary indices
call get_proc_bounds(begg=begg,endg=endg)
! Assign local pointers to derived subtypes components (gridcell level)
forc_aer => clm_a2l%forc_aer
!----------------------------------------------------------------------------
! find input data LB & UB, time units are elapsed days since 0000-01-01
!----------------------------------------------------------------------------
t = (kda-0.5) / ndaypm(kmo)
CASE = "B" ! => interpolate within input time series
if (t < time( 1) ) CASE = "A" ! => loop over 1st year of input data
if (t > time(nt) ) CASE = "C" ! => loop over last year of input data
if ( case == "A" ) then
!--- CASE A: loop over first year of data ----------------------
if ( firstCallA ) then
nLB = 0 ; tLB = -2.0
nUB = 1 ; tUB = -1.0 ! forces search for new LB,UB
firstCallA = .false.
end if
t = mod(t,daysPerYear) + daysPerYear ! CASE A: put t in year 1
n = 0
readNewData = .false.
do while (t < tLB .or. tUB < t)
readNewData = .true.
!--- move tUB,tLB forward in time ---
nLB = nLB + 1 ; if (nLB > 12) nLB = 1
nUB = nLB + 1 ; if (nUB > 12) nUB = 1
tLB = mod(time(nLB),daysPerYear) + daysPerYear ! set year to 1
tUB = mod(time(nUB),daysPerYear) + daysPerYear
!--- deal with wrap around situation ---
if (nLB == 12) then
if (tLB <= t ) then
tUB = tUB + daysPerYear ! put UB in year 2
else if (t < tUB ) then
tLB = tLB - daysPerYear ! put LB in year 1
else
write(6,*) "ERROR: in case A aerinterp"
call endrun()
end if
end if
!--- prevent infinite search ---
n = n + 1
if (n > 12) then
write(6,F01) "ERROR: date,tLB,t,tUB = ",kmo,kda,tLB,t,tUB
call endrun()
end if
end do
else if ( case == "C" ) then
!--- CASE C: loop over last year of data -----------------------
if ( firstCallC ) then
nLB = nt-12 ; tLB = -2.0
nUB = nt-11 ; tUB = -1.0 ! forces search for new LB,UB
firstCallC = .false.
end if
t = mod(t,daysPerYear) + daysPerYear ! set year to 1
n = 0
readNewData = .false.
do while (t < tLB .or. tUB < t)
readNewData = .true.
!--- move tUB,tLB forward in time ---
nLB = nLB + 1 ; if (nLB > nt) nLB = nt - 11
nUB = nLB + 1 ; if (nUB > nt) nUB = nt - 11
tLB = mod(time(nLB),daysPerYear) + daysPerYear ! set year to 1
tUB = mod(time(nUB),daysPerYear) + daysPerYear
!--- deal with wrap around situation ---
if (nLB == nt) then
if (tLB <= t ) then
tUB = tUB + daysPerYear ! put UB in year 2
else if (t < tUB ) then
tLB = tLB - daysPerYear ! put LB in year 1
else
write(6,*) "ERROR: in case A second aerinterp"
call endrun()
end if
end if
!--- prevent infinite search ---
n = n + 1
if (n > 12) then
write(6,F01) "ERROR: date,tLB,t,tUB = ",kmo,kda,tLB,t,tUB
call endrun()
end if
end do
else
!--- CASE B: interpolate within time series --------------------
if ( firstCallB ) then
nLB = 0 ; tLB = -2.0
nUB = 1 ; tUB = -1.0 ! forces search for new LB,UB
firstCallB = .false.
end if
readNewData = .false.
do while (tUB < t)
readNewData = .true.
nLB = nLB + 1
nUB = nLB + 1
tLB = time(nLB)
tUB = time(nUB)
if (nUB > nt) then
write(6,*) "ERROR: nt < nUB aerinterp"
call endrun()
end if
end do
end if
call readMonthlyAerdep (kmo,kda) ! input the new LB,UB data
!----------------------------------------------------------------------------
! interpolate aerosol deposition data into 'forcing' array:
!----------------------------------------------------------------------------
fLB = (tUB - t)/(tUB - tLB)
fUB = 1.0_r8 - fLB
do g = begg, endg
if ( set_caerdep_from_file )then
forc_aer(g, 1) = fLB*bcphidry2t(g,1) + fUB*bcphidry2t(g,2)
forc_aer(g, 2) = fLB*bcphodry2t(g,1) + fUB*bcphodry2t(g,2)
forc_aer(g, 3) = fLB*bcphiwet2t(g,1) + fUB*bcphiwet2t(g,2)
forc_aer(g, 4) = fLB*ocphidry2t(g,1) + fUB*ocphidry2t(g,2)
forc_aer(g, 5) = fLB*ocphodry2t(g,1) + fUB*ocphodry2t(g,2)
forc_aer(g, 6) = fLB*ocphiwet2t(g,1) + fUB*ocphiwet2t(g,2)
end if
if ( set_dustdep_from_file )then
forc_aer(g, 7) = fLB*dstx01wd2t(g,1) + fUB*dstx01wd2t(g,2)
forc_aer(g, 8) = fLB*dstx01dd2t(g,1) + fUB*dstx01dd2t(g,2)
forc_aer(g, 9) = fLB*dstx02wd2t(g,1) + fUB*dstx02wd2t(g,2)
forc_aer(g,10) = fLB*dstx02dd2t(g,1) + fUB*dstx02dd2t(g,2)
forc_aer(g,11) = fLB*dstx03wd2t(g,1) + fUB*dstx03wd2t(g,2)
forc_aer(g,12) = fLB*dstx03dd2t(g,1) + fUB*dstx03dd2t(g,2)
forc_aer(g,13) = fLB*dstx04wd2t(g,1) + fUB*dstx04wd2t(g,2)
forc_aer(g,14) = fLB*dstx04dd2t(g,1) + fUB*dstx04dd2t(g,2)
end if
enddo
call aerdealloc()
end subroutine interpMonthlyAerdep
!---------------------------------------------
!Revised readMonthlyAerdep for coupling model
!---------------------------------------------
subroutine readMonthlyAerdep(kmo, kda) 1,2
use clm_varcon , only :bcphidry,bcphodry,bcphiwet,ocphidry,ocphodry,ocphiwet,dstx01wd,dstx01dd,dstx02wd,&
dstx02dd,dstx03wd,dstx03dd,dstx04wd,dstx04dd
! !ARGUMENTS:
implicit none
integer, intent(in) :: kmo ! month (1, ..., 12)
integer, intent(in) :: kda ! day of month (1, ..., 31)
! LOCAL VARIABLES:
integer :: k,g
integer :: begg
integer :: endg
integer :: begl
integer :: endl
integer :: begc
integer :: endc
integer :: begp
integer :: endp
real(r8):: t ! a fraction: kda/ndaypm
integer :: it(2) ! month 1 and month 2 (step 1)
integer :: months(2) ! months to be interpolated (1 to 12)
integer, dimension(12) :: ndaypm= &
(/31,28,31,30,31,30,31,31,30,31,30,31/) !days per month
!-----------------------------------------------------------------------
t = (kda-0.5) / ndaypm(kmo)
it(1) = t + 0.5
it(2) = it(1) + 1
months(1) = kmo + it(1) - 1
months(2) = kmo + it(2) - 1
if (months(1) < 1) months(1) = 12
if (months(2) > 12) months(2) = 1
call get_proc_bounds (begg, endg, begl, endl, begc, endc, begp, endp)
do g = begg,endg
do k=1,2
bcphidry2t(g,k) = bcphidry(months(k))
bcphodry2t(g,k) = bcphodry(months(k))
bcphiwet2t(g,k) = bcphiwet(months(k))
ocphidry2t(g,k) = ocphidry(months(k))
ocphodry2t(g,k) = ocphodry(months(k))
ocphiwet2t(g,k) = ocphiwet(months(k))
dstx01wd2t(g,k) = dstx01wd(months(k))
dstx01dd2t(g,k) = dstx01dd(months(k))
dstx02wd2t(g,k) = dstx02wd(months(k))
dstx02dd2t(g,k) = dstx02dd(months(k))
dstx03wd2t(g,k) = dstx03wd(months(k))
dstx03dd2t(g,k) = dstx03dd(months(k))
dstx04wd2t(g,k) = dstx04wd(months(k))
dstx04dd2t(g,k) = dstx04dd(months(k))
end do
end do
end subroutine readMonthlyAerdep
subroutine aerdealloc 1
implicit none
if(allocated(bcphidry2t)) deallocate(bcphidry2t)
if(allocated(bcphodry2t)) deallocate(bcphodry2t)
if(allocated(bcphiwet2t)) deallocate(bcphiwet2t)
if(allocated(ocphidry2t)) deallocate(ocphidry2t)
if(allocated(ocphodry2t)) deallocate(ocphodry2t)
if(allocated(ocphiwet2t)) deallocate(ocphiwet2t)
if(allocated(dstx01wd2t)) deallocate(dstx01wd2t)
if(allocated(dstx01dd2t)) deallocate(dstx01dd2t)
if(allocated(dstx02wd2t)) deallocate(dstx02wd2t)
if(allocated(dstx02dd2t)) deallocate(dstx02dd2t)
if(allocated(dstx03wd2t)) deallocate(dstx03wd2t)
if(allocated(dstx03dd2t)) deallocate(dstx03dd2t)
if(allocated(dstx04wd2t)) deallocate(dstx04wd2t)
if(allocated(dstx04dd2t)) deallocate(dstx04dd2t)
end subroutine aerdealloc
end module aerdepMod
module accumulMod 3,7
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: accumulMod
!
! !DESCRIPTION:
! This module contains generic subroutines that can be used to
! define, accumulate and extract user-specified fields over
! user-defined intervals. Each interval and accumulation type is
! unique to each field processed.
! Subroutine [init_accumulator] defines the values of the accumulated
! field data structure. Subroutine [update_accum_field] does
! the actual accumulation for a given field.
! Four types of accumulations are possible:
! - Average over time interval. Time average fields are only
! valid at the end of the averaging interval.
! - Running mean over time interval. Running means are valid once the
! length of the simulation exceeds the
! - Running accumulation over time interval. Accumulated fields are
! continuously accumulated. The trigger value "-99999." resets
! the accumulation to zero.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varpar , only: maxpatch
use module_cam_support, only: endrun
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: init_accum_field ! Initialize an accumulator field
public :: accum_dealloc
public :: extract_accum_field ! Extracts the current value of an accumulator field
interface extract_accum_field 47
module procedure extract_accum_field_sl! Extract current val of single-level accumulator field
module procedure extract_accum_field_ml! Extract current val of multi-level accumulator field
end interface
public :: update_accum_field
interface update_accum_field ! Updates the current value of an accumulator field 26
module procedure update_accum_field_sl! Update single-level accumulator field
module procedure update_accum_field_ml! Update multi-level accumulator field
end interface
!
! !REVISION HISTORY:
! Created by Sam Levis
! Updated to clm2.1 data structures by Mariana Vertenstein
! Updated to include all subgrid type and multilevel fields, M. Vertenstein 03/2003
!
!EOP
!
private
!
! PRIVATE TYPES:
!
type accum_field
character(len= 8) :: name !field name
character(len=128) :: desc !field description
character(len= 8) :: units !field units
character(len= 8) :: acctype !accumulation type: ["timeavg","runmean","runaccum"]
character(len= 8) :: type1d !subgrid type: ["gridcell","landunit","column" or "pft"]
character(len= 8) :: type2d !type2d ('','levsoi','numrad',..etc. )
integer :: beg1d !subgrid type beginning index
integer :: end1d !subgrid type ending index
integer :: num1d !total subgrid points
integer :: numlev !number of vertical levels in field
real(r8):: initval !initial value of accumulated field
real(r8), pointer :: val(:,:) !accumulated field
integer :: period !field accumulation period (in model time steps)
end type accum_field
integer, parameter :: max_accum = 100 !maximum number of accumulated fields
type (accum_field) :: accum(max_accum) !array accumulated fields
integer :: naccflds = 0
!------------------------------------------------------------------------
contains
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_accum_field
!
! !INTERFACE:
subroutine init_accum_field (name, units, desc, & 24,6
accum_type, accum_period, numlev, subgrid_type, init_value,type2d)
!
! !DESCRIPTION:
! Initialize accumulation fields. This subroutine sets:
! o name of accumulated field
! o units of accumulated field
! o accumulation type of accumulated field
! o description of accumulated fields: accdes
! o accumulation period for accumulated field (in iterations)
! o initial value of accumulated field
!
! !USES:
use clm_varcon, only : cday
use globals, only : dtime
use decompMod, only : get_proc_bounds
!
! !ARGUMENTS:
implicit none
character(len=*), intent(in) :: name !field name
character(len=*), intent(in) :: units !field units
character(len=*), intent(in) :: desc !field description
character(len=*), intent(in) :: accum_type !field type: tavg, runm, runa, ins
integer , intent(in) :: accum_period !field accumulation period
character(len=*), intent(in) :: subgrid_type !["gridcell","landunit","column" or "pft"]
integer , intent(in) :: numlev !number of vertical levels
real(r8), intent(in) :: init_value !field initial or reset value
character(len=*), intent(in), optional :: type2d !level type (optional) - needed if numlev > 1
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein 03/2003
!
!EOP
!
! LOCAL VARIABLES:
integer :: nf ! field index
integer :: beg1d,end1d ! beggining and end subgrid indices
integer :: num1d ! total number subgrid indices
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
!------------------------------------------------------------------------
! Determine necessary indices
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! update field index
! Consistency check that number of accumulated does not exceed maximum.
! this needs to be changed
! naccflds = nct
if (naccflds > max_accum) then
write (6,*) 'INIT_ACCUM_FIELD error: user-defined accumulation fields ', &
'equal to ',naccflds,' exceeds max_accum'
call endrun
end if
nf = naccflds
! Note accumulation period must be converted from days
! to number of iterations
accum(nf)%name = trim(name)
accum(nf)%units = trim(units)
accum(nf)%desc = trim(desc)
accum(nf)%acctype = trim(accum_type)
accum(nf)%initval = init_value
accum(nf)%period = accum_period
if (accum(nf)%period < 0) then
accum(nf)%period = -accum(nf)%period * nint(cday) / dtime
end if
select case (trim(subgrid_type))
case ('gridcell')
beg1d = begg
end1d = endg
num1d = endg - begg + 1
case ('landunit')
beg1d = begl
end1d = endl
num1d = endl - begl + 1
case ('column')
beg1d = begc
end1d = endc
num1d = endc - begc + 1
case ('pft')
beg1d = begp
end1d = endp
num1d = endp - begp + 1
case default
write(6,*)'INIT_ACCUM_FIELD: unknown subgrid type ',subgrid_type
call endrun ()
end select
accum(nf)%type1d = trim(subgrid_type)
accum(nf)%beg1d = beg1d
accum(nf)%end1d = end1d
accum(nf)%num1d = num1d
accum(nf)%numlev = numlev
if (present(type2d)) then
accum(nf)%type2d = type2d
else
accum(nf)%type2d = ' '
end if
! Allocate and initialize accumulation field
! Here numlev is always equal to 1
allocate(accum(nf)%val(beg1d:end1d,numlev))
accum(nf)%val(beg1d:end1d,1) = init_value
end subroutine init_accum_field
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: extract_accum_field_sl
!
! !INTERFACE:
subroutine extract_accum_field_sl (name, field, nstep) 1,3
!
! !DESCRIPTION:
! Extract single-level accumulated field.
! This routine extracts the field values from the multi-level
! accumulation field. It extracts the current value except if
! the field type is a time average. In this case, an absurd value
! is assigned to indicate the time average is not yet valid.
!
! !USES:
use clm_varcon, only : spval
!
! !ARGUMENTS:
implicit none
character(len=*), intent(in) :: name !field name
real(r8), pointer, dimension(:) :: field !field values for current time step
integer , intent(in) :: nstep !timestep index
!
! !REVISION HISTORY:
! Created by Sam Levis
! Updated to clm2.1 data structures by Mariana Vertenstein
! Updated to include all subgrid type and multilevel fields, Mariana Vertenstein 03-2003
!
!EOP
!
! LOCAL VARIABLES:
integer :: i,k,nf !indices
integer :: beg,end !subgrid beginning,ending indices
!------------------------------------------------------------------------
! find field index. return if "name" is not on list
nf = 0
!dir$ concurrent
!cdir nodep
do i = 1, naccflds
if (name == accum(i)%name) nf = i
end do
if (nf == 0) then
write(6,*) 'EXTRACT_ACCUM_FIELD_SL error: field name ',name,' not found'
call endrun
endif
! error check
beg = accum(nf)%beg1d
end = accum(nf)%end1d
if (size(field,dim=1) /= end-beg+1) then
write(6,*)'ERROR in extract_accum_field for field ',accum(nf)%name
write(6,*)'size of first dimension of field is ',&
size(field,dim=1),' and should be ',end-beg+1
call endrun
endif
! extract field
if (accum(nf)%acctype == 'timeavg' .and. &
mod(nstep,accum(nf)%period) /= 0) then
!dir$ concurrent
!cdir nodep
do k = beg,end
field(k) = spval !assign absurd value when avg not ready
end do
else
!dir$ concurrent
!cdir nodep
do k = beg,end
field(k) = accum(nf)%val(k,1)
end do
end if
end subroutine extract_accum_field_sl
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: extract_accum_field_ml
!
! !INTERFACE:
subroutine extract_accum_field_ml (name, field, nstep) 1,4
!
! !DESCRIPTION:
! Extract mutli-level accumulated field.
! This routine extracts the field values from the multi-level
! accumulation field. It extracts the current value except if
! the field type is a time average. In this case, an absurd value
! is assigned to indicate the time average is not yet valid.
!
! !USES:
use clm_varcon, only : spval
!
! !ARGUMENTS:
implicit none
character(len=*), intent(in) :: name !field name
real(r8), pointer, dimension(:,:) :: field !field values for current time step
integer, intent(in) :: nstep !timestep index
!
! !REVISION HISTORY:
! Created by Sam Levis
! Updated to clm2.1 data structures by Mariana Vertenstein
! Updated to include all subgrid type and multilevel fields, M. Vertenstein 03/2003
!
!EOP
!
! LOCAL VARIABLES:
integer :: i,j,k,nf !indices
integer :: beg,end !subgrid beginning,ending indices
integer :: numlev !number of vertical levels
!------------------------------------------------------------------------
! find field index. return if "name" is not on list
nf = 0
do i = 1, naccflds
if (name == accum(i)%name) nf = i
end do
if (nf == 0) then
write(6,*) 'EXTRACT_ACCUM_FIELD_ML error: field name ',name,' not found'
call endrun
endif
! error check
numlev = accum(nf)%numlev
beg = accum(nf)%beg1d
end = accum(nf)%end1d
if (size(field,dim=1) /= end-beg+1) then
write(6,*)'ERROR in extract_accum_field for field ',accum(nf)%name
write(6,*)'size of first dimension of field is ',&
size(field,dim=1),' and should be ',end-beg+1
call endrun
else if (size(field,dim=2) /= numlev) then
write(6,*)'ERROR in extract_accum_field for field ',accum(nf)%name
write(6,*)'size of second dimension of field iis ',&
size(field,dim=2),' and should be ',numlev
call endrun
endif
!extract field
if (accum(nf)%acctype == 'timeavg' .and. &
mod(nstep,accum(nf)%period) /= 0) then
do j = 1,numlev
!dir$ concurrent
!cdir nodep
do k = beg,end
field(k,j) = spval !assign absurd value when avg not ready
end do
end do
else
do j = 1,numlev
!dir$ concurrent
!cdir nodep
do k = beg,end
field(k,j) = accum(nf)%val(k,j)
end do
end do
end if
end subroutine extract_accum_field_ml
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: update_accum_field_sl
!
! !INTERFACE:
subroutine update_accum_field_sl (name, field, nstep) 1,3
!
! !DESCRIPTION:
! Accumulate single level field over specified time interval.
! The appropriate field is accumulated in the array [accval].
!
! !ARGUMENTS:
implicit none
character(len=*), intent(in) :: name !field name
real(r8), pointer, dimension(:) :: field !field values for current time step
integer , intent(in) :: nstep !time step index
!
! !REVISION HISTORY:
! Created by Sam Levis
! Updated to clm2.1 data structures by Mariana Vertenstein
! Updated to include all subgrid type and multilevel fields by M. Vertenstein 03/2003
!
!EOP
!
! LOCAL VARIABLES:
integer :: i,k,nf !indices
integer :: accper !temporary accumulation period
integer :: beg,end !subgrid beginning,ending indices
!------------------------------------------------------------------------
! find field index. return if "name" is not on list
nf = 0
do i = 1, naccflds
if (name == accum(i)%name) nf = i
end do
if (nf == 0) then
write(6,*) 'UPDATE_ACCUM_FIELD_SL error: field name ',name,' not found'
call endrun
endif
! error check
beg = accum(nf)%beg1d
end = accum(nf)%end1d
if (size(field,dim=1) /= end-beg+1) then
write(6,*)'ERROR in UPDATE_ACCUM_FIELD_SL for field ',accum(nf)%name
write(6,*)'size of first dimension of field is ',size(field,dim=1),&
' and should be ',end-beg+1
call endrun
endif
! accumulate field
if (accum(nf)%acctype /= 'timeavg' .AND. &
accum(nf)%acctype /= 'runmean' .AND. &
accum(nf)%acctype /= 'runaccum') then
write(6,*) 'UPDATE_ACCUM_FIELD_SL error: incorrect accumulation type'
write(6,*) ' was specified for field ',name
write(6,*)' accumulation type specified is ',accum(nf)%acctype
write(6,*)' only [timeavg, runmean, runaccum] are currently acceptable'
call endrun()
end if
! reset accumulated field value if necessary and update
! accumulation field
! running mean never reset
if (accum(nf)%acctype == 'timeavg') then
!time average field reset every accumulation period
!normalize at end of accumulation period
if ((mod(nstep,accum(nf)%period) == 1) .and. (nstep /= 0)) then
accum(nf)%val(beg:end,1) = 0._r8
end if
accum(nf)%val(beg:end,1) = accum(nf)%val(beg:end,1) + field(beg:end)
if (mod(nstep,accum(nf)%period) == 0) then
accum(nf)%val(beg:end,1) = accum(nf)%val(beg:end,1) / accum(nf)%period
endif
else if (accum(nf)%acctype == 'runmean') then
!running mean - reset accumulation period until greater than nstep
accper = min (nstep,accum(nf)%period)
accum(nf)%val(beg:end,1) = ((accper-1)*accum(nf)%val(beg:end,1) + field(beg:end)) / accper
else if (accum(nf)%acctype == 'runaccum') then
!running accumulation field reset at trigger -99999
!dir$ concurrent
!cdir nodep
do k = beg,end
if (nint(field(k)) == -99999) then
accum(nf)%val(k,1) = 0._r8
end if
end do
accum(nf)%val(beg:end,1) = min(max(accum(nf)%val(beg:end,1) + field(beg:end), 0._r8), 99999._r8)
end if
end subroutine update_accum_field_sl
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: update_accum_field_ml
!
! !INTERFACE:
subroutine update_accum_field_ml (name, field, nstep) 1,4
!
! !DESCRIPTION:
! Accumulate multi level field over specified time interval.
!
! !ARGUMENTS:
implicit none
character(len=*), intent(in) :: name !field name
real(r8), pointer, dimension(:,:) :: field !field values for current time step
integer , intent(in) :: nstep !time step index
!
! !REVISION HISTORY:
! Created by Sam Levis
! Updated to clm2.1 data structures by Mariana Vertenstein
! Updated to include all subgrid type and multilevel fields by M. Vertenstein 03/2003
!
!EOP
!
! LOCAL VARIABLES:
integer :: i,j,k,nf !indices
integer :: accper !temporary accumulation period
integer :: beg,end !subgrid beginning,ending indices
integer :: numlev !number of vertical levels
!------------------------------------------------------------------------
! find field index. return if "name" is not on list
nf = 0
do i = 1, naccflds
if (name == accum(i)%name) nf = i
end do
if (nf == 0) then
write(6,*) 'UPDATE_ACCUM_FIELD_ML error: field name ',name,' not found'
call endrun
endif
! error check
numlev = accum(nf)%numlev
beg = accum(nf)%beg1d
end = accum(nf)%end1d
if (size(field,dim=1) /= end-beg+1) then
write(6,*)'ERROR in UPDATE_ACCUM_FIELD_ML for field ',accum(nf)%name
write(6,*)'size of first dimension of field is ',size(field,dim=1),&
' and should be ',end-beg+1
call endrun
else if (size(field,dim=2) /= numlev) then
write(6,*)'ERROR in UPDATE_ACCUM_FIELD_ML for field ',accum(nf)%name
write(6,*)'size of second dimension of field is ',size(field,dim=2),&
' and should be ',numlev
call endrun
endif
! accumulate field
if (accum(nf)%acctype /= 'timeavg' .AND. &
accum(nf)%acctype /= 'runmean' .AND. &
accum(nf)%acctype /= 'runaccum') then
write(6,*) 'UPDATE_ACCUM_FIELD_ML error: incorrect accumulation type'
write(6,*) ' was specified for field ',name
write(6,*)' accumulation type specified is ',accum(nf)%acctype
write(6,*)' only [timeavg, runmean, runaccum] are currently acceptable'
call endrun()
end if
! accumulate field
! reset accumulated field value if necessary and update
! accumulation field
! running mean never reset
if (accum(nf)%acctype == 'timeavg') then
!time average field reset every accumulation period
!normalize at end of accumulation period
if ((mod(nstep,accum(nf)%period) == 1) .and. (nstep /= 0)) then
accum(nf)%val(beg:end,1:numlev) = 0._r8
endif
accum(nf)%val(beg:end,1:numlev) = accum(nf)%val(beg:end,1:numlev) + field(beg:end,1:numlev)
if (mod(nstep,accum(nf)%period) == 0) then
accum(nf)%val(beg:end,1:numlev) = accum(nf)%val(beg:end,1:numlev) / accum(nf)%period
endif
else if (accum(nf)%acctype == 'runmean') then
!running mean - reset accumulation period until greater than nstep
accper = min (nstep,accum(nf)%period)
accum(nf)%val(beg:end,1:numlev) = &
((accper-1)*accum(nf)%val(beg:end,1:numlev) + field(beg:end,1:numlev)) / accper
else if (accum(nf)%acctype == 'runaccum') then
!running accumulation field reset at trigger -99999
do j = 1,numlev
!dir$ concurrent
!cdir nodep
do k = beg,end
if (nint(field(k,j)) == -99999) then
accum(nf)%val(k,j) = 0._r8
end if
end do
end do
accum(nf)%val(beg:end,1:numlev) = &
min(max(accum(nf)%val(beg:end,1:numlev) + field(beg:end,1:numlev), 0._r8), 99999._r8)
end if
end subroutine update_accum_field_ml
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: accum_dealloc
!
! !INTERFACE:
subroutine accum_dealloc
!
! !DESCRIPTION:
! Deallocate dynamic memory for module variables
!
! !ARGUMENTS:
implicit none
integer :: i
!EOP
!-----------------------------------------------------------------------
do i = 1,naccflds
deallocate (accum(i)%val)
end do
end subroutine accum_dealloc
end module accumulMod
module accFldsMod,2
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: accFldsMod
!
! !DESCRIPTION:
! This module contains subroutines that initialize, update and extract
! the user-specified fields over user-defined intervals. Each interval
! and accumulation type is unique to each field processed.
! Subroutine [initAccumFlds] defines the fields to be processed
! and the type of accumulation. Subroutine [updateAccumFlds] does
! the actual accumulation for a given field. Fields are accumulated
! by calls to subroutine [update_accum_field]. To accumulate a field,
! it must first be defined in subroutine [initAccumFlds] and then
! accumulated by calls to [updateAccumFlds].
! Four types of accumulations are possible:
! o average over time interval
! o running mean over time interval
! o running accumulation over time interval
! Time average fields are only valid at the end of the averaging interval.
! Running means are valid once the length of the simulation exceeds the
! averaging interval. Accumulated fields are continuously accumulated.
! The trigger value "-99999." resets the accumulation to zero.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use module_cam_support, only: endrun
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: initAccFlds ! Initialization accumulator fields
public :: initAccClmtype ! Initialize clmtype variables obtained from accum fields
public :: updateAccFlds ! Update accumulator fields
!
! !REVISION HISTORY:
! Created by M. Vertenstein 03/2003
!
!EOP
contains
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: initAccFlds()
!
! !INTERFACE:
!#if (defined CNDV)
! subroutine initAccFlds(t_ref2m ,tda ,t10 ,fnpsn10 ,prec365,&
! agdd0 ,agdd5 ,agddtw ,agdd)
!#else
subroutine initAccFlds(),31
!#endif
!
! !DESCRIPTION:
! Initializes accumulator and sets up array of accumulated fields
!
! !USES:
use decompMod , only : get_proc_bounds
use accumulMod , only : init_accum_field
use globals , only : dtime, nstep
use clm_varcon , only : cday, tfrz
use nanMod , only : bigint
use clm_varpar , only : maxpatch
use shr_const_mod, only : SHR_CONST_TKFRZ
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY::
! Created by M. Vertenstein 03/2003
!
! LOCAL VARIABLES:
!
integer, parameter :: not_used = bigint
!------------------------------------------------------------------------
call init_accum_field(name='TREFAV', units='K', &
desc='average over an hour of 2-m temperature', &
accum_type='timeavg', accum_period=nint(3600._r8/dtime), &
subgrid_type='pft', numlev=1, init_value=0._r8)
! Hourly average of Urban 2m temperature.
call init_accum_field(name='TREFAV_U', units='K', &
desc='average over an hour of urban 2-m temperature', &
accum_type='timeavg', accum_period=nint(3600._r8/dtime), &
subgrid_type='pft', numlev=1, init_value=0._r8)
! Hourly average of Rural 2m temperature.
call init_accum_field(name='TREFAV_R', units='K', &
desc='average over an hour of rural 2-m temperature', &
accum_type='timeavg', accum_period=nint(3600._r8/dtime), &
subgrid_type='pft', numlev=1, init_value=0._r8)
! 24hr average of vegetation temperature (heald, 04/06)
call init_accum_field (name='T_VEG24', units='K', &
desc='24hr average of vegetation temperature', &
accum_type='runmean', accum_period=-1, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! 240hr average of vegetation temperature (heald, 04/06)
call init_accum_field (name='T_VEG240', units='K', &
desc='240hr average of vegetation temperature', &
accum_type='runmean', accum_period=-10, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! 24hr average of direct solar radiation (heald, 04/06)
call init_accum_field (name='FSD24', units='W/m2', &
desc='24hr average of direct solar radiation', &
accum_type='runmean', accum_period=-1, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! 240hr average of direct solar radiation (heald, 04/06)
call init_accum_field (name='FSD240', units='W/m2', &
desc='240hr average of direct solar radiation', &
accum_type='runmean', accum_period=-10, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! 24hr average of diffuse solar radiation (heald, 04/06)
call init_accum_field (name='FSI24', units='W/m2', &
desc='24hr average of diffuse solar radiation', &
accum_type='runmean', accum_period=-1, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! 240hr average of diffuse solar radiation (heald, 04/06)
call init_accum_field (name='FSI240', units='W/m2', &
desc='240hr average of diffuse solar radiation', &
accum_type='runmean', accum_period=-10, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! 24hr average of fraction of canopy that is sunlit (heald, 04/06)
call init_accum_field (name='FSUN24', units='fraction', &
desc='24hr average of diffuse solar radiation', &
accum_type='runmean', accum_period=-1, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! 240hr average of fraction of canopy that is sunlit (heald, 04/06)
call init_accum_field (name='FSUN240', units='fraction', &
desc='240hr average of diffuse solar radiation', &
accum_type='runmean', accum_period=-10, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! Average of LAI from previous and current timestep (heald, 04/06)
call init_accum_field (name='LAIP', units='m2/m2', &
desc='leaf area index average over timestep', &
accum_type='runmean', accum_period=1, &
subgrid_type='pft', numlev=1, init_value=0._r8)
#if (defined CNDV)
! 30-day average of 2m temperature.
call init_accum_field (name='TDA', units='K', &
desc='30-day average of 2-m temperature', &
accum_type='timeavg', accum_period=-30, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! The following are running means.
! The accumulation period is set to 10 days for a 10-day running mean.
call init_accum_field (name='T10', units='K', &
desc='10-day running mean of 2-m temperature', &
accum_type='runmean', accum_period=-10, &
subgrid_type='pft', numlev=1,init_value=SHR_CONST_TKFRZ+20._r8)
call init_accum_field (name='PREC365', units='MM H2O/S', &
desc='365-day running mean of total precipitation', &
accum_type='runmean', accum_period=-365, &
subgrid_type='pft', numlev=1, init_value=0._r8)
! The following are accumulated fields.
! These types of fields are accumulated until a trigger value resets
! the accumulation to zero (see subroutine update_accum_field).
! Hence, [accper] is not valid.
call init_accum_field (name='AGDDTW', units='K', &
desc='growing degree-days base twmax', &
accum_type='runaccum', accum_period=not_used, &
subgrid_type='pft', numlev=1, init_value=0._r8)
call init_accum_field (name='AGDD', units='K', &
desc='growing degree-days base 5C', &
accum_type='runaccum', accum_period=not_used, &
subgrid_type='pft', numlev=1, init_value=0._r8)
#endif
#if (defined CROP)
! 10-day average of min 2m temperature.
call init_accum_field (name='TDM10', units='K', &
desc='10-day running mean of min 2-m temperature', &
accum_type='runmean', accum_period=-10, &
subgrid_type='pft', numlev=1, init_value=SHR_CONST_TKFRZ)
! 5-day average of min 2m temperature.
call init_accum_field (name='TDM5', units='K', &
desc='5-day running mean of min 2-m temperature', &
accum_type='runmean', accum_period=-5, &
subgrid_type='pft', numlev=1, init_value=SHR_CONST_TKFRZ)
! All GDD summations are relative to the planting date
! (Kucharik & Brye 2003)
call init_accum_field (name='GDD0', units='K', &
desc='growing degree-days base 0C from planting', &
accum_type='runaccum', accum_period=not_used, &
subgrid_type='pft', numlev=1, init_value=0._r8)
call init_accum_field (name='GDD8', units='K', &
desc='growing degree-days base 8C from planting', &
accum_type='runaccum', accum_period=not_used, &
subgrid_type='pft', numlev=1, init_value=0._r8)
call init_accum_field (name='GDD10', units='K', &
desc='growing degree-days base 10C from planting', &
accum_type='runaccum', accum_period=not_used, &
subgrid_type='pft', numlev=1, init_value=0._r8)
call init_accum_field (name='GDDPLANT', units='K', &
desc='growing degree-days from planting', &
accum_type='runaccum', accum_period=not_used, &
subgrid_type='pft', numlev=1, init_value=0._r8)
call init_accum_field (name='GDDTSOI', units='K', &
desc='growing degree-days from planting (top two soil layers)', &
accum_type='runaccum', accum_period=not_used, &
subgrid_type='pft', numlev=1, init_value=0._r8)
#endif
! Print output of accumulated fields
! call print_accum_fields()
end subroutine initAccFlds
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: updateAccFlds
!
! !INTERFACE:
subroutine updateAccFlds(),62
!
! !DESCRIPTION:
! Update and/or extract accumulated fields
!
! !USES:
use clmtype
use decompMod , only : get_proc_bounds
use clm_varcon , only : spval
use shr_const_mod, only : SHR_CONST_CDAY, SHR_CONST_TKFRZ
use pftvarcon , only : ndllf_dcd_brl_tree
use globals , only : dtime, nstep, secs,day,dayp1,month
use accumulMod , only : update_accum_field, extract_accum_field
#if (defined CROP)
use pftvarcon , only : nwwheat, mxtmp, baset
! use clm_time_manager , only : get_start_date
#endif
!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by M. Vertenstein 03/2003
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: itype(:) ! pft vegetation
integer , pointer :: pgridcell(:) ! index into gridcell level quantities
real(r8), pointer :: forc_t(:) ! atmospheric temperature (Kelvin)
real(r8), pointer :: forc_rain(:) ! rain rate [mm/s]
real(r8), pointer :: forc_snow(:) ! snow rate [mm/s]
real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (Kelvin)
real(r8), pointer :: t_ref2m_u(:) ! Urban 2 m height surface air temperature (Kelvin)
real(r8), pointer :: t_ref2m_r(:) ! Rural 2 m height surface air temperature (Kelvin)
logical , pointer :: urbpoi(:) ! true => landunit is an urban point
logical , pointer :: ifspecial(:) ! true => landunit is not vegetated
integer , pointer :: plandunit(:) ! landunit index associated with each pft
#if (defined CROP)
real(r8), pointer :: vf(:)
real(r8), pointer :: t_soisno(:,:)
real(r8), pointer :: h2osoi_liq(:,:)
real(r8), pointer :: watsat(:,:)
real(r8), pointer :: dz(:,:)
real(r8), pointer :: latdeg(:) ! latitude (radians)
integer , pointer :: croplive(:)
integer , pointer :: pcolumn(:) ! index into column level quantities
#endif
!
! local pointers to implicit out arguments
!
! heald (04/06): variables to be accumulated for VOC emissions
real(r8), pointer :: t_veg(:) ! pft vegetation temperature (Kelvin)
real(r8), pointer :: forc_solad(:,:) ! direct beam radiation (visible only)
real(r8), pointer :: forc_solai(:,:) ! diffuse radiation (visible only)
real(r8), pointer :: fsun(:) ! sunlit fraction of canopy
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
! heald (04/06): accumulated variables for VOC emissions
real(r8), pointer :: t_veg24(:) ! 24hr average vegetation temperature (K)
real(r8), pointer :: t_veg240(:) ! 240hr average vegetation temperature (Kelvin)
real(r8), pointer :: fsd24(:) ! 24hr average of direct beam radiation
real(r8), pointer :: fsd240(:) ! 240hr average of direct beam radiation
real(r8), pointer :: fsi24(:) ! 24hr average of diffuse beam radiation
real(r8), pointer :: fsi240(:) ! 240hr average of diffuse beam radiation
real(r8), pointer :: fsun24(:) ! 24hr average of sunlit fraction of canopy
real(r8), pointer :: fsun240(:) ! 240hr average of sunlit fraction of canopy
real(r8), pointer :: elai_p(:) ! leaf area index average over timestep
real(r8), pointer :: t_ref2m_min(:) ! daily minimum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_max(:) ! daily maximum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_min_inst(:) ! instantaneous daily min of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_max_inst(:) ! instantaneous daily max of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_min_u(:) ! Urban daily minimum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_min_r(:) ! Rural daily minimum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_max_u(:) ! Urban daily maximum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_max_r(:) ! Rural daily maximum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_min_inst_u(:) ! Urban instantaneous daily min of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_min_inst_r(:) ! Rural instantaneous daily min of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_max_inst_u(:) ! Urban instantaneous daily max of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_max_inst_r(:) ! Rural instantaneous daily max of average 2 m height surface air temp (K)
#if (defined CNDV)
real(r8), pointer :: t10(:) ! 10-day running mean of the 2 m temperature (K)
real(r8), pointer :: t_mo(:) ! 30-day average temperature (Kelvin)
real(r8), pointer :: t_mo_min(:) ! annual min of t_mo (Kelvin)
real(r8), pointer :: prec365(:) ! 365-day running mean of tot. precipitation
real(r8), pointer :: agddtw(:) ! accumulated growing degree days above twmax
real(r8), pointer :: agdd(:) ! accumulated growing degree days above 5
real(r8), pointer :: twmax(:) ! upper limit of temperature of the warmest month
#endif
#if (defined CROP)
real(r8), pointer :: gdd0(:) ! growing degree-days base 0C'
real(r8), pointer :: gdd8(:) ! growing degree-days base 8C from planting
real(r8), pointer :: gdd10(:) ! growing degree-days base 10C from planting
real(r8), pointer :: gddplant(:) ! growing degree-days from planting
real(r8), pointer :: gddtsoi(:) ! growing degree-days from planting (top two soil layers)
real(r8), pointer :: a10tmin(:) ! 10-day running mean of min 2-m temperature
real(r8), pointer :: a5tmin(:) ! 5-day running mean of min 2-m temperature
#endif
!
!
! !OTHER LOCAL VARIABLES:
!EOP
integer :: g,l,c,p ! indices
integer :: itypveg ! vegetation type
! integer :: dtime ! timestep size [seconds]
! integer :: nstep ! timestep number
! integer :: year ! year (0, ...) for nstep
! integer :: month ! month (1, ..., 12) for nstep
! integer :: day ! day of month (1, ..., 31) for nstep
! integer :: secs ! seconds into current date for nstep
logical :: end_cd ! temporary for is_end_curr_day() value
integer :: ier ! error status
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
real(r8), pointer :: rbufslp(:) ! temporary single level - pft level
!------------------------------------------------------------------------
! Determine necessary indices
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! Assign local pointers to derived subtypes components (gridcell-level)
forc_t => clm_a2l%forc_t
forc_rain => clm_a2l%forc_rain
forc_snow => clm_a2l%forc_snow
forc_solad => clm_a2l%forc_solad ! (heald 04/06)
forc_solai => clm_a2l%forc_solai ! (heald 04/06)
! Assign local pointers to derived subtypes components (landunit-level)
ifspecial => clm3%g%l%ifspecial
urbpoi => clm3%g%l%urbpoi
! Assign local pointers to derived subtypes components (pft-level)
itype => clm3%g%l%c%p%itype
pgridcell => clm3%g%l%c%p%gridcell
t_ref2m => clm3%g%l%c%p%pes%t_ref2m
t_ref2m_max_inst => clm3%g%l%c%p%pes%t_ref2m_max_inst
t_ref2m_min_inst => clm3%g%l%c%p%pes%t_ref2m_min_inst
t_ref2m_max => clm3%g%l%c%p%pes%t_ref2m_max
t_ref2m_min => clm3%g%l%c%p%pes%t_ref2m_min
t_ref2m_u => clm3%g%l%c%p%pes%t_ref2m_u
t_ref2m_r => clm3%g%l%c%p%pes%t_ref2m_r
t_ref2m_max_u => clm3%g%l%c%p%pes%t_ref2m_max_u
t_ref2m_max_r => clm3%g%l%c%p%pes%t_ref2m_max_r
t_ref2m_min_u => clm3%g%l%c%p%pes%t_ref2m_min_u
t_ref2m_min_r => clm3%g%l%c%p%pes%t_ref2m_min_r
t_ref2m_max_inst_u => clm3%g%l%c%p%pes%t_ref2m_max_inst_u
t_ref2m_max_inst_r => clm3%g%l%c%p%pes%t_ref2m_max_inst_r
t_ref2m_min_inst_u => clm3%g%l%c%p%pes%t_ref2m_min_inst_u
t_ref2m_min_inst_r => clm3%g%l%c%p%pes%t_ref2m_min_inst_r
plandunit => clm3%g%l%c%p%landunit
#if (defined CNDV)
t_mo => clm3%g%l%c%p%pdgvs%t_mo
t_mo_min => clm3%g%l%c%p%pdgvs%t_mo_min
t10 => clm3%g%l%c%p%pdgvs%t10
prec365 => clm3%g%l%c%p%pdgvs%prec365
agddtw => clm3%g%l%c%p%pdgvs%agddtw
agdd => clm3%g%l%c%p%pdgvs%agdd
twmax => dgv_pftcon%twmax
#endif
#if (defined CROP)
gdd0 => clm3%g%l%c%p%pps%gdd0
gdd8 => clm3%g%l%c%p%pps%gdd8
gdd10 => clm3%g%l%c%p%pps%gdd10
gddplant => clm3%g%l%c%p%pps%gddplant
gddtsoi => clm3%g%l%c%p%pps%gddtsoi
a10tmin => clm3%g%l%c%p%pps%a10tmin
a5tmin => clm3%g%l%c%p%pps%a5tmin
vf => clm3%g%l%c%p%pps%vf
t_soisno => clm3%g%l%c%ces%t_soisno
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
watsat => clm3%g%l%c%cps%watsat
dz => clm3%g%l%c%cps%dz
latdeg => clm3%g%latdeg
croplive => clm3%g%l%c%p%pps%croplive
pcolumn => clm3%g%l%c%p%column
#endif
t_veg24 => clm3%g%l%c%p%pvs%t_veg24 ! (heald 04/06)
t_veg240 => clm3%g%l%c%p%pvs%t_veg240 ! (heald 04/06)
fsd24 => clm3%g%l%c%p%pvs%fsd24 ! (heald 04/06)
fsd240 => clm3%g%l%c%p%pvs%fsd240 ! (heald 04/06)
fsi24 => clm3%g%l%c%p%pvs%fsi24 ! (heald 04/06)
fsi240 => clm3%g%l%c%p%pvs%fsi240 ! (heald 04/06)
fsun24 => clm3%g%l%c%p%pvs%fsun24 ! (heald 04/06)
fsun240 => clm3%g%l%c%p%pvs%fsun240 ! (heald 04/06)
elai_p => clm3%g%l%c%p%pvs%elai_p ! (heald 04/06)
t_veg => clm3%g%l%c%p%pes%t_veg ! (heald 04/06)
fsun => clm3%g%l%c%p%pps%fsun ! (heald 04/06)
elai => clm3%g%l%c%p%pps%elai ! (heald 04/06)
! Don't do any accumulation if nstep is zero
! (only applies to coupled or cam mode)
if (nstep == 0) return
! NOTE: currently only single level pft fields are used below
! Variables are declared above that should make it easy to incorporate
! multi-level or single-level fields of any subgrid type
! Allocate needed dynamic memory for single level pft field
allocate(rbufslp(begp:endp), stat=ier)
if (ier/=0) then
write(6,*)'update_accum_hist allocation error for rbuf1dp'
call endrun
endif
! Accumulate and extract TREFAV - hourly average 2m air temperature
! Used to compute maximum and minimum of hourly averaged 2m reference
! temperature over a day. Note that "spval" is returned by the call to
! accext if the time step does not correspond to the end of an
! accumulation interval. First, initialize the necessary values for
! an initial run at the first time step the accumulator is called
call update_accum_field ('TREFAV', t_ref2m, nstep)
call extract_accum_field ('TREFAV', rbufslp, nstep)
if(dayp1-day.eq.1) then
end_cd = .true.
else
end_cd = .false.
end if
!dir$ concurrent
!cdir nodep
do p = begp,endp
if (rbufslp(p) /= spval) then
t_ref2m_max_inst(p) = max(rbufslp(p), t_ref2m_max_inst(p))
t_ref2m_min_inst(p) = min(rbufslp(p), t_ref2m_min_inst(p))
endif
if (end_cd) then
t_ref2m_max(p) = t_ref2m_max_inst(p)
t_ref2m_min(p) = t_ref2m_min_inst(p)
t_ref2m_max_inst(p) = -spval
t_ref2m_min_inst(p) = spval
else if (secs == int(dtime)) then
t_ref2m_max(p) = spval
t_ref2m_min(p) = spval
endif
end do
! Accumulate and extract TREFAV_U - hourly average urban 2m air temperature
! Used to compute maximum and minimum of hourly averaged 2m reference
! temperature over a day. Note that "spval" is returned by the call to
! accext if the time step does not correspond to the end of an
! accumulation interval. First, initialize the necessary values for
! an initial run at the first time step the accumulator is called
call update_accum_field ('TREFAV_U', t_ref2m_u, nstep)
call extract_accum_field ('TREFAV_U', rbufslp, nstep)
do p = begp,endp
l = plandunit(p)
if (rbufslp(p) /= spval) then
t_ref2m_max_inst_u(p) = max(rbufslp(p), t_ref2m_max_inst_u(p))
t_ref2m_min_inst_u(p) = min(rbufslp(p), t_ref2m_min_inst_u(p))
endif
if (end_cd) then
if (urbpoi(l)) then
t_ref2m_max_u(p) = t_ref2m_max_inst_u(p)
t_ref2m_min_u(p) = t_ref2m_min_inst_u(p)
t_ref2m_max_inst_u(p) = -spval
t_ref2m_min_inst_u(p) = spval
end if
else if (secs == int(dtime)) then
t_ref2m_max_u(p) = spval
t_ref2m_min_u(p) = spval
endif
end do
! Accumulate and extract TREFAV_R - hourly average rural 2m air temperature
! Used to compute maximum and minimum of hourly averaged 2m reference
! temperature over a day. Note that "spval" is returned by the call to
! accext if the time step does not correspond to the end of an
! accumulation interval. First, initialize the necessary values for
! an initial run at the first time step the accumulator is called
call update_accum_field ('TREFAV_R', t_ref2m_r, nstep)
call extract_accum_field ('TREFAV_R', rbufslp, nstep)
do p = begp,endp
l = plandunit(p)
if (rbufslp(p) /= spval) then
t_ref2m_max_inst_r(p) = max(rbufslp(p), t_ref2m_max_inst_r(p))
t_ref2m_min_inst_r(p) = min(rbufslp(p), t_ref2m_min_inst_r(p))
endif
if (end_cd) then
if (.not.(ifspecial(l))) then
t_ref2m_max_r(p) = t_ref2m_max_inst_r(p)
t_ref2m_min_r(p) = t_ref2m_min_inst_r(p)
t_ref2m_max_inst_r(p) = -spval
t_ref2m_min_inst_r(p) = spval
end if
else if (secs == int(dtime)) then
t_ref2m_max_r(p) = spval
t_ref2m_min_r(p) = spval
endif
end do
! Accumulate and extract T_VEG24 & T_VEG240 (heald 04/06)
do p = begp,endp
rbufslp(p) = t_veg(p)
end do
call update_accum_field ('T_VEG24', rbufslp, nstep)
call extract_accum_field ('T_VEG24', t_veg24, nstep)
call update_accum_field ('T_VEG240', rbufslp, nstep)
call extract_accum_field ('T_VEG240', t_veg240, nstep)
! Accumulate and extract forc_solad24 & forc_solad240 (heald 04/06)
do p = begp,endp
g = pgridcell(p)
rbufslp(p) = forc_solad(g,1)
end do
call update_accum_field ('FSD240', rbufslp, nstep)
call extract_accum_field ('FSD240', fsd240, nstep)
call update_accum_field ('FSD24', rbufslp, nstep)
call extract_accum_field ('FSD24', fsd24, nstep)
! Accumulate and extract forc_solai24 & forc_solai240 (heald 04/06)
do p = begp,endp
g = pgridcell(p)
rbufslp(p) = forc_solai(g,1)
end do
call update_accum_field ('FSI24', rbufslp, nstep)
call extract_accum_field ('FSI24', fsi24, nstep)
call update_accum_field ('FSI240', rbufslp, nstep)
call extract_accum_field ('FSI240', fsi240, nstep)
! Accumulate and extract fsun24 & fsun240 (heald 04/06)
do p = begp,endp
rbufslp(p) = fsun(p)
end do
call update_accum_field ('FSUN24', rbufslp, nstep)
call extract_accum_field ('FSUN24', fsun24, nstep)
call update_accum_field ('FSUN240', rbufslp, nstep)
call extract_accum_field ('FSUN240', fsun240, nstep)
! Accumulate and extract elai_p (heald 04/06)
do p = begp,endp
rbufslp(p) = elai(p)
end do
call update_accum_field ('LAIP', rbufslp, nstep)
call extract_accum_field ('LAIP', elai_p, nstep)
#if (defined CNDV)
! Accumulate and extract TDA
! (accumulates TBOT as 30-day average)
! Also determine t_mo_min
!dir$ concurrent
!cdir nodep
do p = begp,endp
g = pgridcell(p)
rbufslp(p) = forc_t(g)
end do
call update_accum_field ('TDA', rbufslp, nstep)
call extract_accum_field ('TDA', rbufslp, nstep)
!dir$ concurrent
!cdir nodep
do p = begp,endp
t_mo(p) = rbufslp(p)
t_mo_min(p) = min(t_mo_min(p), rbufslp(p))
end do
! Accumulate and extract T10
!(acumulates TSA as 10-day running mean)
call update_accum_field ('T10', t_ref2m, nstep)
call extract_accum_field ('T10', t10, nstep)
! Accumulate and extract FNPSN10
!(accumulates fpsn-frmf as 10-day running mean)
!dir$ concurrent
!cdir nodep
! do p = begp,endp
! rbufslp(p) = fpsn(p) - frmf(p)
! end do
! call update_accum_field ('FNPSN10', rbufslp, nstep)
! call extract_accum_field ('FNPSN10', fnpsn10, nstep)
! Accumulate and extract PREC365
! (accumulates total precipitation as 365-day running mean)
!dir$ concurrent
!cdir nodep
do p = begp,endp
g = pgridcell(p)
rbufslp(p) = forc_rain(g) + forc_snow(g)
end do
call update_accum_field ('PREC365', rbufslp, nstep)
call extract_accum_field ('PREC365', prec365, nstep)
! Accumulate growing degree days based on 10-day running mean temperature.
! Accumulate GDD above 0C and -5C using extracted t10 from accumulated variable.
! The trigger to reset the accumulated values to zero is -99999.
! agddtw is currently reset at the end of each year in subr. lpj
! Accumulate and extract AGDDO
!dir$ concurrent
!cdir nodep
do p = begp,endp
rbufslp(p) = (t10(p) - tfrz) * dtime / cday
if (rbufslp(p) < 0._r8) rbufslp(p) = -99999.
end do
call update_accum_field ('AGDD0', rbufslp, nstep)
call extract_accum_field ('AGDD0', agdd0, nstep)
! Accumulate and extract AGDD5
!dir$ concurrent
!cdir nodep
do p = begp,endp
rbufslp(p) = (t10(p) - (tfrz - 5.0))*dtime / cday
if (rbufslp(p) < 0._r8) rbufslp(p) = -99999.
end do
call update_accum_field ('AGDD5', rbufslp, nstep)
call extract_accum_field ('AGDD5', agdd5, nstep)
! Accumulate and extract AGDDTW
!dir$ concurrent
!cdir nodep
do p = begp,endp
itypveg = itype(p)
rbufslp(p) = max(0.0, (t10(p) - (tfrz+pftpar(itypveg,31))) &
* dtime/cday)
end do
call update_accum_field ('AGDDTW', rbufslp, nstep)
call extract_accum_field ('AGDDTW', agddtw, nstep)
! Accumulate and extract AGDD
!dir$ concurrent
!cdir nodep
do p = begp,endp
rbufslp(p) = max(0.0, (t_ref2m(p) - (tfrz + 5.0)) &
* dtime/cday)
end do
call update_accum_field ('AGDD', rbufslp, nstep)
call extract_accum_field ('AGDD', agdd, nstep)
#endif
!CLM4
#if (defined CROP)
! Accumulate and extract TDM10
do p = begp,endp
rbufslp(p) = min(t_ref2m_min(p),t_ref2m_min_inst(p)) !slevis: ok choice?
if (rbufslp(p) > 1.e30_r8) rbufslp(p) = SHR_CONST_TKFRZ !and were 'min'&
end do !'min_inst' not initialized?
call update_accum_field ('TDM10', rbufslp, nstep)
call extract_accum_field ('TDM10', a10tmin, nstep)
! Accumulate and extract TDM5
do p = begp,endp
rbufslp(p) = min(t_ref2m_min(p),t_ref2m_min_inst(p)) !slevis: ok choice?
if (rbufslp(p) > 1.e30_r8) rbufslp(p) = SHR_CONST_TKFRZ !and were 'min'&
end do !'min_inst' not initialized?
call update_accum_field ('TDM5', rbufslp, nstep)
call extract_accum_field ('TDM5', a5tmin, nstep)
! Accumulate and extract GDD0
do p = begp,endp
itypveg = itype(p)
g = pgridcell(p)
if (month==1 .and. day==1 .and. secs==int(dtime)) then
rbufslp(p) = -99999._r8 ! reset gdd
else if (( month > 3 .and. month < 10 .and. latdeg(g) >= 0._r8) .or. &
((month > 9 .or. month < 4) .and. latdeg(g) < 0._r8) ) then
rbufslp(p) = max(0._r8, min(26._r8, t_ref2m(p)-SHR_CONST_TKFRZ)) &
* dtime/SHR_CONST_CDAY
else
rbufslp(p) = 0._r8 ! keeps gdd unchanged at other times (eg, through Dec in NH)
end if
end do
call update_accum_field ('GDD0', rbufslp, nstep)
call extract_accum_field ('GDD0', gdd0, nstep)
! Accumulate and extract GDD8
do p = begp,endp
itypveg = itype(p)
g = pgridcell(p)
if (month==1 .and. day==1 .and. secs==int(dtime)) then
rbufslp(p) = -99999._r8 ! reset gdd
else if (( month > 3 .and. month < 10 .and. latdeg(g) >= 0._r8) .or. &
((month > 9 .or. month < 4) .and. latdeg(g) < 0._r8) ) then
rbufslp(p) = max(0._r8, min(30._r8, &
t_ref2m(p)-(SHR_CONST_TKFRZ + 8._r8))) &
* dtime/SHR_CONST_CDAY
else
rbufslp(p) = 0._r8 ! keeps gdd unchanged at other times (eg, through Dec in NH)
end if
end do
call update_accum_field ('GDD8', rbufslp, nstep)
call extract_accum_field ('GDD8', gdd8, nstep)
! Accumulate and extract GDD10
do p = begp,endp
itypveg = itype(p)
g = pgridcell(p)
if (month==1 .and. day==1 .and. secs==int(dtime)) then
rbufslp(p) = -99999._r8 ! reset gdd
else if (( month > 3 .and. month < 10 .and. latdeg(g) >= 0._r8) .or. &
((month > 9 .or. month < 4) .and. latdeg(g) < 0._r8) ) then
rbufslp(p) = max(0._r8, min(30._r8, &
t_ref2m(p)-(SHR_CONST_TKFRZ + 10._r8))) &
* dtime/SHR_CONST_CDAY
else
rbufslp(p) = 0._r8 ! keeps gdd unchanged at other times (eg, through Dec in NH)
end if
end do
call update_accum_field ('GDD10', rbufslp, nstep)
call extract_accum_field ('GDD10', gdd10, nstep)
! Accumulate and extract GDDPLANT
do p = begp,endp
if (croplive(p) == 1) then ! relative to planting date
itypveg = itype(p)
rbufslp(p) = max(0._r8, min(mxtmp(itypveg), &
t_ref2m(p)-(SHR_CONST_TKFRZ + baset(itypveg)))) &
* dtime/SHR_CONST_CDAY
if (itypveg == nwwheat) rbufslp(p) = rbufslp(p)*vf(p)
else
rbufslp(p) = -99999._r8
end if
end do
call update_accum_field ('GDDPLANT', rbufslp, nstep)
call extract_accum_field ('GDDPLANT', gddplant, nstep)
! Accumulate and extract GDDTSOI
! In agroibis this variable is calculated
! to 0.05 m, so here we use the top two soil layers
do p = begp,endp
if (croplive(p) == 1) then ! relative to planting date
itypveg = itype(p)
c = pcolumn(p)
rbufslp(p) = max(0._r8, min(mxtmp(itypveg), &
((t_soisno(c,1)*dz(c,1)+t_soisno(c,2)*dz(c,2))/(dz(c,1)+dz(c,2))) - &
(SHR_CONST_TKFRZ + baset(itypveg)))) * dtime/SHR_CONST_CDAY
if (itypveg == nwwheat) rbufslp(p) = rbufslp(p)*vf(p)
else
rbufslp(p) = -99999._r8
end if
end do
call update_accum_field ('GDDTSOI', rbufslp, nstep)
call extract_accum_field ('GDDTSOI', gddtsoi, nstep)
#endif
! Deallocate dynamic memory
deallocate(rbufslp)
end subroutine updateAccFlds
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: initAccClmtype
!
! !INTERFACE:
subroutine initAccClmtype !(t2m_max,t2m_min,t2m_max_inst,t2m_min_inst),29
!
! !DESCRIPTION:
! Initialize clmtype variables that are associated with
! time accumulated fields. This routine is called in an initial run
! at nstep=0 for cam and csm mode and at nstep=1 for offline mode.
! This routine is also always called for a restart run and
! therefore must be called after the restart file is read in
! and the accumulated fields are obtained.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype
use decompMod , only : get_proc_bounds
use accumulMod , only : extract_accum_field
use clm_varcon , only : spval
use globals , only : nstep
!
! !ARGUMENTS:
implicit none
!
! !CALLED FROM:
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
! !LOCAL VARIABLES:
!
! local pointers to implicit out arguments
!
real(r8), pointer :: t_ref2m_min(:) ! daily minimum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_max(:) ! daily maximum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_min_inst(:) ! instantaneous daily min of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_max_inst(:) ! instantaneous daily max of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_min_u(:) ! Urban daily minimum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_min_r(:) ! Rural daily minimum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_max_u(:) ! Urban daily maximum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_max_r(:) ! Rural daily maximum of average 2 m height surface air temperature (K)
real(r8), pointer :: t_ref2m_min_inst_u(:) ! Urban instantaneous daily min of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_min_inst_r(:) ! Rural instantaneous daily min of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_max_inst_u(:) ! Urban instantaneous daily max of average 2 m height surface air temp (K)
real(r8), pointer :: t_ref2m_max_inst_r(:) ! Rural instantaneous daily max of average 2 m height surface air temp (K)
#ifdef CNDV
real(r8), pointer :: t10(:) ! 10-day running mean of the 2 m temperature (K)
real(r8), pointer :: t_mo(:) ! 30-day average temperature (Kelvin)
real(r8), pointer :: prec365(:) ! 365-day running mean of tot. precipitation
real(r8), pointer :: agddtw(:) ! accumulated growing degree days above twmax
real(r8), pointer :: agdd(:) ! accumulated growing degree days above 5
#endif
#if (defined CROP)
real(r8), pointer :: gdd0(:) ! growing degree-days base 0C'
real(r8), pointer :: gdd8(:) ! growing degree-days base 8C from planting
real(r8), pointer :: gdd10(:) ! growing degree-days base 10C from planting
real(r8), pointer :: gddplant(:) ! growing degree-days from planting
real(r8), pointer :: gddtsoi(:) ! growing degree-days from planting (top two soil layers)
real(r8), pointer :: a10tmin(:) ! 10-day running mean of min 2-m temperature
real(r8), pointer :: a5tmin(:) ! 5-day running mean of min 2-m temperature
#endif
! heald (04/06): accumulated variables for VOC emissions
real(r8), pointer :: t_veg24(:) ! 24hr average vegetation temperature (K)
real(r8), pointer :: t_veg240(:) ! 240hr average vegetation temperature (Kelvin)
real(r8), pointer :: fsd24(:) ! 24hr average of direct beam radiation
real(r8), pointer :: fsd240(:) ! 240hr average of direct beam radiation
real(r8), pointer :: fsi24(:) ! 24hr average of diffuse beam radiation
real(r8), pointer :: fsi240(:) ! 240hr average of diffuse beam radiation
real(r8), pointer :: fsun24(:) ! 24hr average of sunlit fraction of canopy
real(r8), pointer :: fsun240(:) ! 240hr average of sunlit fraction of canopy
real(r8), pointer :: elai_p(:) ! leaf area index average over timestep
!
! !LOCAL VARIABLES:
!
!
! !OTHER LOCAL VARIABLES:
!EOP
integer :: p ! indices
! integer :: nstep ! time step
integer :: ier ! error status
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
real(r8), pointer :: rbufslp(:) ! temporary
character(len=32) :: subname = 'initAccClmtype' ! subroutine name
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (pft-level)
t_ref2m_max_inst => clm3%g%l%c%p%pes%t_ref2m_max_inst
t_ref2m_min_inst => clm3%g%l%c%p%pes%t_ref2m_min_inst
t_ref2m_max => clm3%g%l%c%p%pes%t_ref2m_max
t_ref2m_min => clm3%g%l%c%p%pes%t_ref2m_min
t_ref2m_max_inst_u => clm3%g%l%c%p%pes%t_ref2m_max_inst_u
t_ref2m_max_inst_r => clm3%g%l%c%p%pes%t_ref2m_max_inst_r
t_ref2m_min_inst_u => clm3%g%l%c%p%pes%t_ref2m_min_inst_u
t_ref2m_min_inst_r => clm3%g%l%c%p%pes%t_ref2m_min_inst_r
t_ref2m_max_u => clm3%g%l%c%p%pes%t_ref2m_max_u
t_ref2m_max_r => clm3%g%l%c%p%pes%t_ref2m_max_r
t_ref2m_min_u => clm3%g%l%c%p%pes%t_ref2m_min_u
t_ref2m_min_r => clm3%g%l%c%p%pes%t_ref2m_min_r
#if (defined CNDV)
t10 => clm3%g%l%c%p%pdgvs%t10
t_mo => clm3%g%l%c%p%pdgvs%t_mo
prec365 => clm3%g%l%c%p%pdgvs%prec365
agddtw => clm3%g%l%c%p%pdgvs%agddtw
agdd => clm3%g%l%c%p%pdgvs%agdd
#endif
#if (defined CROP)
gdd0 => clm3%g%l%c%p%pps%gdd0
gdd8 => clm3%g%l%c%p%pps%gdd8
gdd10 => clm3%g%l%c%p%pps%gdd10
gddplant => clm3%g%l%c%p%pps%gddplant
gddtsoi => clm3%g%l%c%p%pps%gddtsoi
a10tmin => clm3%g%l%c%p%pps%a10tmin
a5tmin => clm3%g%l%c%p%pps%a5tmin
#endif
! heald (04/06): accumulated variables for VOC emissions
t_veg24 => clm3%g%l%c%p%pvs%t_veg24
t_veg240 => clm3%g%l%c%p%pvs%t_veg240
fsd24 => clm3%g%l%c%p%pvs%fsd24
fsd240 => clm3%g%l%c%p%pvs%fsd240
fsi24 => clm3%g%l%c%p%pvs%fsi24
fsi240 => clm3%g%l%c%p%pvs%fsi240
fsun24 => clm3%g%l%c%p%pvs%fsun24
fsun240 => clm3%g%l%c%p%pvs%fsun240
elai_p => clm3%g%l%c%p%pvs%elai_p
! Determine necessary indices
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! Initialize 2m ref temperature max and min values
do p = begp,endp
t_ref2m_max(p) = spval
t_ref2m_min(p) = spval
t_ref2m_max_inst(p) = -spval
t_ref2m_min_inst(p) = spval
t_ref2m_max_u(p) = spval
t_ref2m_max_r(p) = spval
t_ref2m_min_u(p) = spval
t_ref2m_min_r(p) = spval
t_ref2m_max_inst_u(p) = -spval
t_ref2m_max_inst_r(p) = -spval
t_ref2m_min_inst_u(p) = spval
t_ref2m_min_inst_r(p) = spval
end do
! Allocate needed dynamic memory for single level pft field
allocate(rbufslp(begp:endp), stat=ier)
if (ier/=0) then
write(6,*)'update_accum_hist allocation error for rbufslp'
call endrun
endif
! Initialize clmtype variables that are to be time accumulated
call extract_accum_field ('T_VEG24', rbufslp, nstep)
do p = begp,endp
t_veg24(p) = rbufslp(p)
end do
call extract_accum_field ('T_VEG240', rbufslp, nstep)
do p = begp,endp
t_veg240(p) = rbufslp(p)
end do
call extract_accum_field ('FSD24', rbufslp, nstep)
do p = begp,endp
fsd24(p) = rbufslp(p)
end do
call extract_accum_field ('FSD240', rbufslp, nstep)
do p = begp,endp
fsd240(p) = rbufslp(p)
end do
call extract_accum_field ('FSI24', rbufslp, nstep)
do p = begp,endp
fsi24(p) = rbufslp(p)
end do
call extract_accum_field ('FSI240', rbufslp, nstep)
do p = begp,endp
fsi240(p) = rbufslp(p)
end do
call extract_accum_field ('FSUN24', rbufslp, nstep)
do p = begp,endp
fsun24(p) = rbufslp(p)
end do
call extract_accum_field ('FSUN240', rbufslp, nstep)
do p = begp,endp
fsun240(p) = rbufslp(p)
end do
call extract_accum_field ('LAIP', rbufslp, nstep)
do p = begp,endp
elai_p(p) = rbufslp(p)
end do
#if (defined CROP)
call extract_accum_field ('GDD0', rbufslp, nstep)
do p = begp,endp
gdd0(p) = rbufslp(p)
end do
call extract_accum_field ('GDD8', rbufslp, nstep)
do p = begp,endp
gdd8(p) = rbufslp(p)
end do
call extract_accum_field ('GDD10', rbufslp, nstep)
do p = begp,endp
gdd10(p) = rbufslp(p)
end do
call extract_accum_field ('GDDPLANT', rbufslp, nstep)
do p = begp,endp
gddplant(p) = rbufslp(p)
end do
call extract_accum_field ('GDDTSOI', rbufslp, nstep)
do p = begp,endp
gddtsoi(p) = rbufslp(p)
end do
call extract_accum_field ('TDM10', rbufslp, nstep)
do p = begp,endp
a10tmin(p) = rbufslp(p)
end do
call extract_accum_field ('TDM5', rbufslp, nstep)
do p = begp,endp
a5tmin(p) = rbufslp(p)
end do
#endif
#if (defined CNDV)
call extract_accum_field ('T10', rbufslp, nstep)
do p = begp,endp
t10(p) = rbufslp(p)
end do
call extract_accum_field ('TDA', rbufslp, nstep)
do p = begp,endp
t_mo(p) = rbufslp(p)
end do
call extract_accum_field ('PREC365', rbufslp, nstep)
do p = begp,endp
prec365(p) = rbufslp(p)
end do
call extract_accum_field ('AGDDTW', rbufslp, nstep)
do p = begp,endp
agddtw(p) = rbufslp(p)
end do
call extract_accum_field ('AGDD', rbufslp, nstep)
do p = begp,endp
agdd(p) = rbufslp(p)
end do
#endif
deallocate(rbufslp)
end subroutine initAccClmtype
end module accFldsMod
module SurfaceRadiationMod 1,3
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: SurfaceRadiationMod
!
! !DESCRIPTION:
! Calculate solar fluxes absorbed by vegetation and ground surface
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use globals, only : nstep
use module_cam_support, only: endrun
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: SurfaceRadiation ! Solar fluxes absorbed by veg and ground surface
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! 11/26/03, Peter Thornton: Added new routine for improved treatment of
! sunlit/shaded canopy radiation.
! 4/26/05, Peter Thornton: Adopted the sun/shade algorithm as the default,
! removed the old SurfaceRadiation(), and renamed SurfaceRadiationSunShade()
! as SurfaceRadiation().
!
!EOP
!------------------------------------------------------------------------------
contains
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: SurfaceRadiation
!
! !INTERFACE:
subroutine SurfaceRadiation(lbp, ubp, num_nourbanp, filter_nourbanp) 1,8
!
! !DESCRIPTION:
! Solar fluxes absorbed by vegetation and ground surface
! Note possible problem when land is on different grid than atmosphere.
! Land may have sun above the horizon (coszen > 0) but atmosphere may
! have sun below the horizon (forc_solad = 0 and forc_solai = 0). This is okay
! because all fluxes (absorbed, reflected, transmitted) are multiplied
! by the incoming flux and all will equal zero.
! Atmosphere may have sun above horizon (forc_solad > 0 and forc_solai > 0) but
! land may have sun below horizon. This is okay because fabd, fabi,
! ftdd, ftid, and ftii all equal zero so that sabv=sabg=fsa=0. Also,
! albd and albi equal one so that fsr=forc_solad+forc_solai. In other words, all
! the radiation is reflected. NDVI should equal zero in this case.
! However, the way the code is currently implemented this is only true
! if (forc_solad+forc_solai)|vis = (forc_solad+forc_solai)|nir.
! Output variables are parsun,parsha,sabv,sabg,fsa,fsr,ndvi
!
! !USES:
use clmtype
use clm_varpar , only : numrad
use clm_varcon , only : spval, istsoil
#ifdef CROP
use clm_varcon , only : istcrop
#endif
use clm_varpar , only : nlevsno
use SNICARMod , only : DO_SNO_OC
use globals , only : dtime, secs
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbp, ubp ! pft upper and lower bounds
integer, intent(in) :: num_nourbanp ! number of pfts in non-urban points in pft filter
integer, intent(in) :: filter_nourbanp(ubp-lbp+1) ! pft filter for non-urban points
!
! !CALLED FROM:
! subroutine Biogeophysics1 in module Biogeophysics1Mod
! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod
!
! !REVISION HISTORY:
! Author: Gordon Bonan
! 2/18/02, Peter Thornton: Migrated to new data structures. Added a pft loop.
! 6/05/03, Peter Thornton: Modified sunlit/shaded canopy treatment. Original code
! had all radiation being absorbed in the sunlit canopy, and now the sunlit and shaded
! canopies are each given the appropriate fluxes. There was also an inconsistency in
! the original code, where parsun was not being scaled by leaf area, and so represented
! the entire canopy flux. This goes into Stomata (in CanopyFluxes) where it is assumed
! to be a flux per unit leaf area. In addition, the fpsn flux coming out of Stomata was
! being scaled back up to the canopy by multiplying by lai, but the input radiation flux was
! for the entire canopy to begin with. Corrected this inconsistency in this version, so that
! the parsun and parsha fluxes going into canopy fluxes are per unit lai in the sunlit and
! shaded canopies.
! 6/9/03, Peter Thornton: Moved coszen from g%gps to c%cps to avoid problem
! with OpenMP threading over columns, where different columns hit the radiation
! time step at different times during execution.
! 6/10/03, Peter Thornton: Added constraint on negative tot_aid, instead of
! exiting with error. Appears to be happening only at roundoff level.
! 6/11/03, Peter Thornton: Moved calculation of ext inside if (coszen),
! and added check on laisun = 0 and laisha = 0 in calculation of sun_aperlai
! and sha_aperlai.
! 11/26/03, Peter Thornton: During migration to new vector code, created
! this as a new routine to handle sunlit/shaded canopy calculations.
! 03/28/08, Mark Flanner: Incorporated SNICAR, including absorbed solar radiation
! in each snow layer and top soil layer, and optional radiative forcing calculation
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in arguments
!
integer , pointer :: ivt(:) ! pft vegetation type
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: pgridcell(:) ! pft's gridcell index
real(r8), pointer :: pwtgcell(:) ! pft's weight relative to corresponding gridcell
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) ! one-sided stem area index with burying by snow
real(r8), pointer :: londeg(:) ! longitude (degrees)
real(r8), pointer :: latdeg(:) ! latitude (degrees)
real(r8), pointer :: slasun(:) ! specific leaf area for sunlit canopy, projected area basis (m^2/gC)
real(r8), pointer :: slasha(:) ! specific leaf area for shaded canopy, projected area basis (m^2/gC)
real(r8), pointer :: gdir(:) ! leaf projection in solar direction (0 to 1)
real(r8), pointer :: omega(:,:) ! fraction of intercepted radiation that is scattered (0 to 1)
real(r8), pointer :: coszen(:) ! cosine of solar zenith angle
real(r8), pointer :: forc_solad(:,:) ! direct beam radiation (W/m**2)
real(r8), pointer :: forc_solai(:,:) ! diffuse radiation (W/m**2)
real(r8), pointer :: fabd(:,:) ! flux absorbed by veg per unit direct flux
real(r8), pointer :: fabi(:,:) ! flux absorbed by veg per unit diffuse flux
real(r8), pointer :: ftdd(:,:) ! down direct flux below veg per unit dir flx
real(r8), pointer :: ftid(:,:) ! down diffuse flux below veg per unit dir flx
real(r8), pointer :: ftii(:,:) ! down diffuse flux below veg per unit dif flx
real(r8), pointer :: albgrd(:,:) ! ground albedo (direct)
real(r8), pointer :: albgri(:,:) ! ground albedo (diffuse)
real(r8), pointer :: albd(:,:) ! surface albedo (direct)
real(r8), pointer :: albi(:,:) ! surface albedo (diffuse)
real(r8), pointer :: slatop(:) ! specific leaf area at top of canopy, projected area basis [m^2/gC]
real(r8), pointer :: dsladlai(:) ! dSLA/dLAI, projected area basis [m^2/gC]
!
! local pointers to original implicit out arguments
!
real(r8), pointer :: fsun(:) ! sunlit fraction of canopy
real(r8), pointer :: laisun(:) ! sunlit leaf area
real(r8), pointer :: laisha(:) ! shaded leaf area
real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2)
real(r8), pointer :: sabv(:) ! solar radiation absorbed by vegetation (W/m**2)
real(r8), pointer :: fsa(:) ! solar radiation absorbed (total) (W/m**2)
real(r8), pointer :: fsa_r(:) ! rural solar radiation absorbed (total) (W/m**2)
integer , pointer :: ityplun(:) ! landunit type
integer , pointer :: plandunit(:) ! index into landunit level quantities
real(r8), pointer :: parsun(:) ! average absorbed PAR for sunlit leaves (W/m**2)
real(r8), pointer :: parsha(:) ! average absorbed PAR for shaded leaves (W/m**2)
real(r8), pointer :: fsr(:) ! solar radiation reflected (W/m**2)
real(r8), pointer :: fsds_vis_d(:) ! incident direct beam vis solar radiation (W/m**2)
real(r8), pointer :: fsds_nir_d(:) ! incident direct beam nir solar radiation (W/m**2)
real(r8), pointer :: fsds_vis_i(:) ! incident diffuse vis solar radiation (W/m**2)
real(r8), pointer :: fsds_nir_i(:) ! incident diffuse nir solar radiation (W/m**2)
real(r8), pointer :: fsr_vis_d(:) ! reflected direct beam vis solar radiation (W/m**2)
real(r8), pointer :: fsr_nir_d(:) ! reflected direct beam nir solar radiation (W/m**2)
real(r8), pointer :: fsr_vis_i(:) ! reflected diffuse vis solar radiation (W/m**2)
real(r8), pointer :: fsr_nir_i(:) ! reflected diffuse nir solar radiation (W/m**2)
real(r8), pointer :: fsds_vis_d_ln(:) ! incident direct beam vis solar rad at local noon (W/m**2)
real(r8), pointer :: fsds_nir_d_ln(:) ! incident direct beam nir solar rad at local noon (W/m**2)
real(r8), pointer :: fsr_vis_d_ln(:) ! reflected direct beam vis solar rad at local noon (W/m**2)
real(r8), pointer :: fsr_nir_d_ln(:) ! reflected direct beam nir solar rad at local noon (W/m**2)
real(r8), pointer :: eff_kid(:,:) ! effective extinction coefficient for indirect from direct
real(r8), pointer :: eff_kii(:,:) ! effective extinction coefficient for indirect from indirect
real(r8), pointer :: sun_faid(:,:) ! fraction sun canopy absorbed indirect from direct
real(r8), pointer :: sun_faii(:,:) ! fraction sun canopy absorbed indirect from indirect
real(r8), pointer :: sha_faid(:,:) ! fraction shade canopy absorbed indirect from direct
real(r8), pointer :: sha_faii(:,:) ! fraction shade canopy absorbed indirect from indirect
real(r8), pointer :: sun_add(:,:) ! sun canopy absorbed direct from direct (W/m**2)
real(r8), pointer :: tot_aid(:,:) ! total canopy absorbed indirect from direct (W/m**2)
real(r8), pointer :: sun_aid(:,:) ! sun canopy absorbed indirect from direct (W/m**2)
real(r8), pointer :: sun_aii(:,:) ! sun canopy absorbed indirect from indirect (W/m**2)
real(r8), pointer :: sha_aid(:,:) ! shade canopy absorbed indirect from direct (W/m**2)
real(r8), pointer :: sha_aii(:,:) ! shade canopy absorbed indirect from indirect (W/m**2)
real(r8), pointer :: sun_atot(:,:) ! sun canopy total absorbed (W/m**2)
real(r8), pointer :: sha_atot(:,:) ! shade canopy total absorbed (W/m**2)
real(r8), pointer :: sun_alf(:,:) ! sun canopy total absorbed by leaves (W/m**2)
real(r8), pointer :: sha_alf(:,:) ! shade canopy total absored by leaves (W/m**2)
real(r8), pointer :: sun_aperlai(:,:) ! sun canopy total absorbed per unit LAI (W/m**2)
real(r8), pointer :: sha_aperlai(:,:) ! shade canopy total absorbed per unit LAI (W/m**2)
real(r8), pointer :: flx_absdv(:,:) ! direct flux absorption factor (col,lyr): VIS [frc]
real(r8), pointer :: flx_absdn(:,:) ! direct flux absorption factor (col,lyr): NIR [frc]
real(r8), pointer :: flx_absiv(:,:) ! diffuse flux absorption factor (col,lyr): VIS [frc]
real(r8), pointer :: flx_absin(:,:) ! diffuse flux absorption factor (col,lyr): NIR [frc]
integer , pointer :: snl(:) ! negative number of snow layers [nbr]
real(r8), pointer :: albgrd_pur(:,:) ! pure snow ground albedo (direct)
real(r8), pointer :: albgri_pur(:,:) ! pure snow ground albedo (diffuse)
real(r8), pointer :: albgrd_bc(:,:) ! ground albedo without BC (direct) (col,bnd)
real(r8), pointer :: albgri_bc(:,:) ! ground albedo without BC (diffuse) (col,bnd)
real(r8), pointer :: albgrd_oc(:,:) ! ground albedo without OC (direct) (col,bnd)
real(r8), pointer :: albgri_oc(:,:) ! ground albedo without OC (diffuse) (col,bnd)
real(r8), pointer :: albgrd_dst(:,:) ! ground albedo without dust (direct) (col,bnd)
real(r8), pointer :: albgri_dst(:,:) ! ground albedo without dust (diffuse) (col,bnd)
real(r8), pointer :: albsnd_hst(:,:) ! snow albedo, direct, for history files (col,bnd) [frc]
real(r8), pointer :: albsni_hst(:,:) ! snow ground albedo, diffuse, for history files (col,bnd
real(r8), pointer :: sabg_lyr(:,:) ! absorbed radiative flux (pft,lyr) [W/m2]
real(r8), pointer :: sfc_frc_aer(:) ! surface forcing of snow with all aerosols (pft) [W/m2]
real(r8), pointer :: sfc_frc_bc(:) ! surface forcing of snow with BC (pft) [W/m2]
real(r8), pointer :: sfc_frc_oc(:) ! surface forcing of snow with OC (pft) [W/m2]
real(r8), pointer :: sfc_frc_dst(:) ! surface forcing of snow with dust (pft) [W/m2]
real(r8), pointer :: sfc_frc_aer_sno(:) ! surface forcing of snow with all aerosols, averaged only when snow is present (pft) [W/m2]
real(r8), pointer :: sfc_frc_bc_sno(:) ! surface forcing of snow with BC, averaged only when snow is present (pft) [W/m2]
real(r8), pointer :: sfc_frc_oc_sno(:) ! surface forcing of snow with OC, averaged only when snow is present (pft) [W/m2]
real(r8), pointer :: sfc_frc_dst_sno(:) ! surface forcing of snow with dust, averaged only when snow is present (pft) [W/m2]
real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1)
real(r8), pointer :: fsr_sno_vd(:) ! reflected visible, direct radiation from snow (for history files) (pft) [W/m2]
real(r8), pointer :: fsr_sno_nd(:) ! reflected near-IR, direct radiation from snow (for history files) (pft) [W/m2]
real(r8), pointer :: fsr_sno_vi(:) ! reflected visible, diffuse radiation from snow (for history files) (pft) [W/m2]
real(r8), pointer :: fsr_sno_ni(:) ! reflected near-IR, diffuse radiation from snow (for history files) (pft) [W/m2]
real(r8), pointer :: fsds_sno_vd(:) ! incident visible, direct radiation on snow (for history files) (pft) [W/m2]
real(r8), pointer :: fsds_sno_nd(:) ! incident near-IR, direct radiation on snow (for history files) (pft) [W/m2]
real(r8), pointer :: fsds_sno_vi(:) ! incident visible, diffuse radiation on snow (for history files) (pft) [W/m2]
real(r8), pointer :: fsds_sno_ni(:) ! incident near-IR, diffuse radiation on snow (for history files) (pft) [W/m2]
real(r8), pointer :: snowdp(:) ! snow height (m)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer , parameter :: nband = numrad ! number of solar radiation waveband classes
real(r8), parameter :: mpe = 1.e-06_r8 ! prevents overflow for division by zero
integer :: fp ! non-urban filter pft index
integer :: p ! pft index
integer :: c ! column index
integer :: l ! landunit index
integer :: g ! grid cell index
integer :: ib ! waveband number (1=vis, 2=nir)
real(r8) :: absrad ! absorbed solar radiation (W/m**2)
real(r8) :: rnir ! reflected solar radiation [nir] (W/m**2)
real(r8) :: rvis ! reflected solar radiation [vis] (W/m**2)
real(r8) :: laifra ! leaf area fraction of canopy
real(r8) :: trd(lbp:ubp,numrad) ! transmitted solar radiation: direct (W/m**2)
real(r8) :: tri(lbp:ubp,numrad) ! transmitted solar radiation: diffuse (W/m**2)
real(r8) :: cad(lbp:ubp,numrad) ! direct beam absorbed by canopy (W/m**2)
real(r8) :: cai(lbp:ubp,numrad) ! diffuse radiation absorbed by canopy (W/m**2)
real(r8) :: vai(lbp:ubp) ! total leaf area index + stem area index, one sided
real(r8) :: ext ! optical depth direct beam per unit LAI+SAI
real(r8) :: t1, t2 ! temporary variables
real(r8) :: cosz
integer :: local_secp1 ! seconds into current date in local time
integer :: i ! layer index [idx]
real(r8) :: sabg_snl_sum ! temporary, absorbed energy in all active snow layers [W/m2]
real(r8) :: absrad_pur ! temp: absorbed solar radiation by pure snow [W/m2]
real(r8) :: absrad_bc ! temp: absorbed solar radiation without BC [W/m2]
real(r8) :: absrad_oc ! temp: absorbed solar radiation without OC [W/m2]
real(r8) :: absrad_dst ! temp: absorbed solar radiation without dust [W/m2]
real(r8) :: sabg_pur(lbp:ubp) ! solar radiation absorbed by ground with pure snow [W/m2]
real(r8) :: sabg_bc(lbp:ubp) ! solar radiation absorbed by ground without BC [W/m2]
real(r8) :: sabg_oc(lbp:ubp) ! solar radiation absorbed by ground without OC [W/m2]
real(r8) :: sabg_dst(lbp:ubp) ! solar radiation absorbed by ground without dust [W/m2]
!------------------------------------------------------------------------------
! Assign local pointers to multi-level derived type members (gridcell level)
londeg => clm3%g%londeg
latdeg => clm3%g%latdeg
forc_solad => clm_a2l%forc_solad
forc_solai => clm_a2l%forc_solai
! Assign local pointers to multi-level derived type members (landunit level)
ityplun => clm3%g%l%itype
! Assign local pointers to multi-level derived type members (column level)
albgrd => clm3%g%l%c%cps%albgrd
albgri => clm3%g%l%c%cps%albgri
coszen => clm3%g%l%c%cps%coszen
! Assign local pointers to derived type members (pft-level)
plandunit => clm3%g%l%c%p%landunit
ivt => clm3%g%l%c%p%itype
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
pwtgcell => clm3%g%l%c%p%wtgcell
elai => clm3%g%l%c%p%pps%elai
esai => clm3%g%l%c%p%pps%esai
slasun => clm3%g%l%c%p%pps%slasun
slasha => clm3%g%l%c%p%pps%slasha
gdir => clm3%g%l%c%p%pps%gdir
omega => clm3%g%l%c%p%pps%omega
laisun => clm3%g%l%c%p%pps%laisun
laisha => clm3%g%l%c%p%pps%laisha
fabd => clm3%g%l%c%p%pps%fabd
fabi => clm3%g%l%c%p%pps%fabi
ftdd => clm3%g%l%c%p%pps%ftdd
ftid => clm3%g%l%c%p%pps%ftid
ftii => clm3%g%l%c%p%pps%ftii
albd => clm3%g%l%c%p%pps%albd
albi => clm3%g%l%c%p%pps%albi
fsun => clm3%g%l%c%p%pps%fsun
sabg => clm3%g%l%c%p%pef%sabg
sabv => clm3%g%l%c%p%pef%sabv
snowdp => clm3%g%l%c%cps%snowdp
fsa => clm3%g%l%c%p%pef%fsa
fsa_r => clm3%g%l%c%p%pef%fsa_r
fsr => clm3%g%l%c%p%pef%fsr
parsun => clm3%g%l%c%p%pef%parsun
parsha => clm3%g%l%c%p%pef%parsha
fsds_vis_d => clm3%g%l%c%p%pef%fsds_vis_d
fsds_nir_d => clm3%g%l%c%p%pef%fsds_nir_d
fsds_vis_i => clm3%g%l%c%p%pef%fsds_vis_i
fsds_nir_i => clm3%g%l%c%p%pef%fsds_nir_i
fsr_vis_d => clm3%g%l%c%p%pef%fsr_vis_d
fsr_nir_d => clm3%g%l%c%p%pef%fsr_nir_d
fsr_vis_i => clm3%g%l%c%p%pef%fsr_vis_i
fsr_nir_i => clm3%g%l%c%p%pef%fsr_nir_i
fsds_vis_d_ln => clm3%g%l%c%p%pef%fsds_vis_d_ln
fsds_nir_d_ln => clm3%g%l%c%p%pef%fsds_nir_d_ln
fsr_vis_d_ln => clm3%g%l%c%p%pef%fsr_vis_d_ln
fsr_nir_d_ln => clm3%g%l%c%p%pef%fsr_nir_d_ln
eff_kid => clm3%g%l%c%p%pps%eff_kid
eff_kii => clm3%g%l%c%p%pps%eff_kii
sun_faid => clm3%g%l%c%p%pps%sun_faid
sun_faii => clm3%g%l%c%p%pps%sun_faii
sha_faid => clm3%g%l%c%p%pps%sha_faid
sha_faii => clm3%g%l%c%p%pps%sha_faii
sun_add => clm3%g%l%c%p%pef%sun_add
tot_aid => clm3%g%l%c%p%pef%tot_aid
sun_aid => clm3%g%l%c%p%pef%sun_aid
sun_aii => clm3%g%l%c%p%pef%sun_aii
sha_aid => clm3%g%l%c%p%pef%sha_aid
sha_aii => clm3%g%l%c%p%pef%sha_aii
sun_atot => clm3%g%l%c%p%pef%sun_atot
sha_atot => clm3%g%l%c%p%pef%sha_atot
sun_alf => clm3%g%l%c%p%pef%sun_alf
sha_alf => clm3%g%l%c%p%pef%sha_alf
sun_aperlai => clm3%g%l%c%p%pef%sun_aperlai
sha_aperlai => clm3%g%l%c%p%pef%sha_aperlai
! Assign local pointers to derived type members (ecophysiological)
slatop => pftcon%slatop
dsladlai => pftcon%dsladlai
frac_sno => clm3%g%l%c%cps%frac_sno
flx_absdv => clm3%g%l%c%cps%flx_absdv
flx_absdn => clm3%g%l%c%cps%flx_absdn
flx_absiv => clm3%g%l%c%cps%flx_absiv
flx_absin => clm3%g%l%c%cps%flx_absin
sabg_lyr => clm3%g%l%c%p%pef%sabg_lyr
snl => clm3%g%l%c%cps%snl
sfc_frc_aer => clm3%g%l%c%p%pef%sfc_frc_aer
sfc_frc_aer_sno => clm3%g%l%c%p%pef%sfc_frc_aer_sno
albgrd_pur => clm3%g%l%c%cps%albgrd_pur
albgri_pur => clm3%g%l%c%cps%albgri_pur
sfc_frc_bc => clm3%g%l%c%p%pef%sfc_frc_bc
sfc_frc_bc_sno => clm3%g%l%c%p%pef%sfc_frc_bc_sno
albgrd_bc => clm3%g%l%c%cps%albgrd_bc
albgri_bc => clm3%g%l%c%cps%albgri_bc
sfc_frc_oc => clm3%g%l%c%p%pef%sfc_frc_oc
sfc_frc_oc_sno => clm3%g%l%c%p%pef%sfc_frc_oc_sno
albgrd_oc => clm3%g%l%c%cps%albgrd_oc
albgri_oc => clm3%g%l%c%cps%albgri_oc
sfc_frc_dst => clm3%g%l%c%p%pef%sfc_frc_dst
sfc_frc_dst_sno => clm3%g%l%c%p%pef%sfc_frc_dst_sno
albgrd_dst => clm3%g%l%c%cps%albgrd_dst
albgri_dst => clm3%g%l%c%cps%albgri_dst
albsnd_hst => clm3%g%l%c%cps%albsnd_hst
albsni_hst => clm3%g%l%c%cps%albsni_hst
fsr_sno_vd => clm3%g%l%c%p%pef%fsr_sno_vd
fsr_sno_nd => clm3%g%l%c%p%pef%fsr_sno_nd
fsr_sno_vi => clm3%g%l%c%p%pef%fsr_sno_vi
fsr_sno_ni => clm3%g%l%c%p%pef%fsr_sno_ni
fsds_sno_vd => clm3%g%l%c%p%pef%fsds_sno_vd
fsds_sno_nd => clm3%g%l%c%p%pef%fsds_sno_nd
fsds_sno_vi => clm3%g%l%c%p%pef%fsds_sno_vi
fsds_sno_ni => clm3%g%l%c%p%pef%fsds_sno_ni
! Determine fluxes
!dir$ concurrent
!cdir nodep
do fp = 1,num_nourbanp
p = filter_nourbanp(fp)
if (pwtgcell(p)>0._r8) then ! was redundant b/c filter already included wt>0; not redundant anymore with chg in filter definition
sabg(p) = 0._r8
sabv(p) = 0._r8
fsa(p) = 0._r8
l = plandunit(p)
#ifndef CROP
if (ityplun(l)==istsoil) then
#else
if (ityplun(l)==istsoil .or. ityplun(l)==istcrop) then
#endif
fsa_r(p) = 0._r8
end if
sabg_lyr(p,:) = 0._r8
sabg_pur(p) = 0._r8
sabg_bc(p) = 0._r8
sabg_oc(p) = 0._r8
sabg_dst(p) = 0._r8
end if
end do
! Loop over pfts to calculate fsun, etc
!dir$ concurrent
!cdir nodep
do fp = 1,num_nourbanp
p = filter_nourbanp(fp)
if (pwtgcell(p)>0._r8) then ! see comment with this line above
c = pcolumn(p)
g = pgridcell(p)
vai(p) = elai(p) + esai(p)
if (coszen(c) > 0._r8 .and. elai(p) > 0._r8 .and. gdir(p) > 0._r8) then
cosz = max(0.001_r8, coszen(c))
ext = gdir(p)/cosz
t1 = min(ext*elai(p), 40.0_r8)
t2 = exp(-t1)
fsun(p) = (1._r8-t2)/t1
! new control on low lai, to avoid numerical problems in
! calculation of slasun, slasha
! PET: 2/29/04
if (elai(p) > 0.01_r8) then
laisun(p) = elai(p)*fsun(p)
laisha(p) = elai(p)*(1._r8-fsun(p))
! calculate the average specific leaf area for sunlit and shaded
! canopies, when effective LAI > 0
slasun(p) = (t2*dsladlai(ivt(p))*ext*elai(p) + &
t2*dsladlai(ivt(p)) + &
t2*slatop(ivt(p))*ext - &
dsladlai(ivt(p)) - &
slatop(ivt(p))*ext) / &
(ext*(t2-1._r8))
slasha(p) = ((slatop(ivt(p)) + &
(dsladlai(ivt(p)) * elai(p)/2.0_r8)) * elai(p) - &
laisun(p)*slasun(p)) / laisha(p)
else
! special case for low elai
fsun(p) = 1._r8
laisun(p) = elai(p)
laisha(p) = 0._r8
slasun(p) = slatop(ivt(p))
slasha(p) = 0._r8
end if
else
fsun(p) = 0._r8
laisun(p) = 0._r8
laisha(p) = elai(p)
slasun(p) = 0._r8
slasha(p) = 0._r8
end if
end if
end do
! Loop over nband wavebands
do ib = 1, nband
!dir$ concurrent
!cdir nodep
do fp = 1,num_nourbanp
p = filter_nourbanp(fp)
if (pwtgcell(p)>0._r8) then ! see comment with this line above
c = pcolumn(p)
g = pgridcell(p)
! Absorbed by canopy
cad(p,ib) = forc_solad(g,ib)*fabd(p,ib)
cai(p,ib) = forc_solai(g,ib)*fabi(p,ib)
sabv(p) = sabv(p) + cad(p,ib) + cai(p,ib)
fsa(p) = fsa(p) + cad(p,ib) + cai(p,ib)
l = plandunit(p)
#ifndef CROP
if (ityplun(l)==istsoil) then
#else
if (ityplun(l)==istsoil .or. ityplun(l)==istcrop) then
#endif
fsa_r(p) = fsa_r(p) + cad(p,ib) + cai(p,ib)
end if
! Transmitted = solar fluxes incident on ground
trd(p,ib) = forc_solad(g,ib)*ftdd(p,ib)
tri(p,ib) = forc_solad(g,ib)*ftid(p,ib) + forc_solai(g,ib)*ftii(p,ib)
! Solar radiation absorbed by ground surface
absrad = trd(p,ib)*(1._r8-albgrd(c,ib)) + tri(p,ib)*(1._r8-albgri(c,ib))
sabg(p) = sabg(p) + absrad
fsa(p) = fsa(p) + absrad
#ifndef CROP
if (ityplun(l)==istsoil) then
#else
if (ityplun(l)==istsoil .or. ityplun(l)==istcrop) then
#endif
fsa_r(p) = fsa_r(p) + absrad
end if
#if (defined SNICAR_FRC)
! Solar radiation absorbed by ground surface without BC
absrad_bc = trd(p,ib)*(1._r8-albgrd_bc(c,ib)) + tri(p,ib)*(1._r8-albgri_bc(c,ib))
sabg_bc(p) = sabg_bc(p) + absrad_bc
! Solar radiation absorbed by ground surface without OC
absrad_oc = trd(p,ib)*(1._r8-albgrd_oc(c,ib)) + tri(p,ib)*(1._r8-albgri_oc(c,ib))
sabg_oc(p) = sabg_oc(p) + absrad_oc
! Solar radiation absorbed by ground surface without dust
absrad_dst = trd(p,ib)*(1._r8-albgrd_dst(c,ib)) + tri(p,ib)*(1._r8-albgri_dst(c,ib))
sabg_dst(p) = sabg_dst(p) + absrad_dst
! Solar radiation absorbed by ground surface without any aerosols
absrad_pur = trd(p,ib)*(1._r8-albgrd_pur(c,ib)) + tri(p,ib)*(1._r8-albgri_pur(c,ib))
sabg_pur(p) = sabg_pur(p) + absrad_pur
#endif
! New sunlit.shaded canopy algorithm
if (coszen(c) > 0._r8 .and. elai(p) > 0._r8 .and. gdir(p) > 0._r8 ) then
! 1. calculate flux of direct beam radiation absorbed in the
! sunlit canopy as direct (sun_add), and the flux of direct
! beam radiation absorbed in the total canopy as indirect
sun_add(p,ib) = forc_solad(g,ib) * (1._r8-ftdd(p,ib)) * (1._r8-omega(p,ib))
tot_aid(p,ib) = (forc_solad(g,ib) * fabd(p,ib)) - sun_add(p,ib)
! the following constraint set to catch round-off level errors
! that can cause negative tot_aid
tot_aid(p,ib) = max(tot_aid(p,ib), 0._r8)
! 2. calculate the effective extinction coefficients for indirect
! transmission originating from direct and indirect streams,
! using ftid and ftii
!eff_kid(p,ib) = -(log(ftid(p,ib)))/vai(p)
!eff_kii(p,ib) = -(log(ftii(p,ib)))/vai(p)
! 3. calculate the fraction of indirect radiation being absorbed
! in the sunlit and shaded canopy fraction. Some of this indirect originates in
! the direct beam and some originates in the indirect beam.
!sun_faid(p,ib) = 1.-exp(-eff_kid(p,ib) * vaisun(p))
!sun_faii(p,ib) = 1.-exp(-eff_kii(p,ib) * vaisun(p))
sun_faid(p,ib) = fsun(p)
sun_faii(p,ib) = fsun(p)
sha_faid(p,ib) = 1._r8-sun_faid(p,ib)
sha_faii(p,ib) = 1._r8-sun_faii(p,ib)
! 4. calculate the total indirect flux absorbed by the sunlit
! and shaded canopy based on these fractions and the fabd and
! fabi from surface albedo calculations
sun_aid(p,ib) = tot_aid(p,ib) * sun_faid(p,ib)
sun_aii(p,ib) = forc_solai(g,ib)*fabi(p,ib)*sun_faii(p,ib)
sha_aid(p,ib) = tot_aid(p,ib) * sha_faid(p,ib)
sha_aii(p,ib) = forc_solai(g,ib)*fabi(p,ib)*sha_faii(p,ib)
! 5. calculate the total flux absorbed in the sunlit and shaded
! canopy as the sum of these terms
sun_atot(p,ib) = sun_add(p,ib) + sun_aid(p,ib) + sun_aii(p,ib)
sha_atot(p,ib) = sha_aid(p,ib) + sha_aii(p,ib)
! 6. calculate the total flux absorbed by leaves in the sunlit
! and shaded canopies
laifra = elai(p)/vai(p)
sun_alf(p,ib) = sun_atot(p,ib) * laifra
sha_alf(p,ib) = sha_atot(p,ib) * laifra
! 7. calculate the fluxes per unit lai in the sunlit and shaded
! canopies
if (laisun(p) > 0._r8) then
sun_aperlai(p,ib) = sun_alf(p,ib)/laisun(p)
else
sun_aperlai(p,ib) = 0._r8
endif
if (laisha(p) > 0._r8) then
sha_aperlai(p,ib) = sha_alf(p,ib)/laisha(p)
else
sha_aperlai(p,ib) = 0._r8
endif
else ! coszen = 0 or elai = 0
sun_add(p,ib) = 0._r8
tot_aid(p,ib) = 0._r8
eff_kid(p,ib) = 0._r8
eff_kii(p,ib) = 0._r8
sun_faid(p,ib) = 0._r8
sun_faii(p,ib) = 0._r8
sha_faid(p,ib) = 0._r8
sha_faii(p,ib) = 0._r8
sun_aid(p,ib) = 0._r8
sun_aii(p,ib) = 0._r8
sha_aid(p,ib) = 0._r8
sha_aii(p,ib) = 0._r8
sun_atot(p,ib) = 0._r8
sha_atot(p,ib) = 0._r8
sun_alf(p,ib) = 0._r8
sha_alf(p,ib) = 0._r8
sun_aperlai(p,ib) = 0._r8
sha_aperlai(p,ib) = 0._r8
end if
end if
end do ! end of pft loop
end do ! end nbands loop
! compute absorbed flux in each snow layer and top soil layer,
! based on flux factors computed in the radiative transfer portion of SNICAR.
do fp = 1,num_nourbanp
p = filter_nourbanp(fp)
if (pwtgcell(p)>0._r8) then
c = pcolumn(p)
sabg_snl_sum = 0._r8
! CASE1: No snow layers: all energy is absorbed in top soil layer
if (snl(c) == 0) then
sabg_lyr(p,:) = 0._r8
sabg_lyr(p,1) = sabg(p)
sabg_snl_sum = sabg_lyr(p,1)
! CASE 2: Snow layers present: absorbed radiation is scaled according to
! flux factors computed by SNICAR
else
do i = -nlevsno+1,1,1
sabg_lyr(p,i) = flx_absdv(c,i)*trd(p,1) + flx_absdn(c,i)*trd(p,2) + &
flx_absiv(c,i)*tri(p,1) + flx_absin(c,i)*tri(p,2)
! summed radiation in active snow layers:
if (i >= snl(c)+1) then
sabg_snl_sum = sabg_snl_sum + sabg_lyr(p,i)
endif
enddo
! Error handling: The situation below can occur when solar radiation is
! NOT computed every timestep.
! When the number of snow layers has changed in between computations of the
! absorbed solar energy in each layer, we must redistribute the absorbed energy
! to avoid physically unrealistic conditions. The assumptions made below are
! somewhat arbitrary, but this situation does not arise very frequently.
! This error handling is implemented to accomodate any value of the
! radiation frequency.
if (abs(sabg_snl_sum-sabg(p)) > 0.00001_r8) then
if (snl(c) == 0) then
sabg_lyr(p,-4:0) = 0._r8
sabg_lyr(p,1) = sabg(p)
elseif (snl(c) == -1) then
sabg_lyr(p,-4:-1) = 0._r8
sabg_lyr(p,0) = sabg(p)*0.6_r8
sabg_lyr(p,1) = sabg(p)*0.4_r8
else
sabg_lyr(p,:) = 0._r8
sabg_lyr(p,snl(c)+1) = sabg(p)*0.75_r8
sabg_lyr(p,snl(c)+2) = sabg(p)*0.25_r8
endif
endif
! If shallow snow depth, all solar radiation absorbed in top or top two snow layers
! to prevent unrealistic timestep soil warming
if (snowdp(c) < 0.10_r8) then
if (snl(c) == 0) then
sabg_lyr(p,-4:0) = 0._r8
sabg_lyr(p,1) = sabg(p)
elseif (snl(c) == -1) then
sabg_lyr(p,-4:-1) = 0._r8
sabg_lyr(p,0) = sabg(p)
sabg_lyr(p,1) = 0._r8
else
sabg_lyr(p,:) = 0._r8
sabg_lyr(p,snl(c)+1) = sabg(p)*0.75_r8
sabg_lyr(p,snl(c)+2) = sabg(p)*0.25_r8
endif
endif
endif
! This situation should not happen:
if (abs(sum(sabg_lyr(p,:))-sabg(p)) > 0.00001_r8) then
write(6,*) "SNICAR ERROR: Absorbed ground radiation not equal to summed snow layer radiation. pft = ", &
p," Col= ", c, " Diff= ",sum(sabg_lyr(p,:))-sabg(p), " sabg(p)= ", sabg(p), " sabg_sum(p)= ", &
sum(sabg_lyr(p,:)), " snl(c)= ", snl(c)
write(6,*) "flx_absdv1= ", trd(p,1)*(1.-albgrd(c,1)), "flx_absdv2= ", sum(flx_absdv(c,:))*trd(p,1)
write(6,*) "flx_absiv1= ", tri(p,1)*(1.-albgri(c,1))," flx_absiv2= ", sum(flx_absiv(c,:))*tri(p,1)
write(6,*) "flx_absdn1= ", trd(p,2)*(1.-albgrd(c,2))," flx_absdn2= ", sum(flx_absdn(c,:))*trd(p,2)
write(6,*) "flx_absin1= ", tri(p,2)*(1.-albgri(c,2))," flx_absin2= ", sum(flx_absin(c,:))*tri(p,2)
write(6,*) "albgrd_nir= ", albgrd(c,2)
write(6,*) "coszen= ", coszen(c)
call endrun()
endif
#if (defined SNICAR_FRC)
! BC aerosol forcing (pft-level):
sfc_frc_bc(p) = sabg(p) - sabg_bc(p)
! OC aerosol forcing (pft-level):
if (DO_SNO_OC) then
sfc_frc_oc(p) = sabg(p) - sabg_oc(p)
else
sfc_frc_oc(p) = 0._r8
endif
! dust aerosol forcing (pft-level):
sfc_frc_dst(p) = sabg(p) - sabg_dst(p)
! all-aerosol forcing (pft-level):
sfc_frc_aer(p) = sabg(p) - sabg_pur(p)
! forcings averaged only over snow:
if (frac_sno(c) > 0._r8) then
sfc_frc_bc_sno(p) = sfc_frc_bc(p)/frac_sno(c)
sfc_frc_oc_sno(p) = sfc_frc_oc(p)/frac_sno(c)
sfc_frc_dst_sno(p) = sfc_frc_dst(p)/frac_sno(c)
sfc_frc_aer_sno(p) = sfc_frc_aer(p)/frac_sno(c)
else
sfc_frc_bc_sno(p) = spval
sfc_frc_oc_sno(p) = spval
sfc_frc_dst_sno(p) = spval
sfc_frc_aer_sno(p) = spval
endif
#endif
endif
enddo
!dir$ concurrent
!cdir nodep
do fp = 1,num_nourbanp
p = filter_nourbanp(fp)
if (pwtgcell(p)>0._r8) then ! see comment with this line above
g = pgridcell(p)
! Final step of new sunlit/shaded canopy algorithm
! 8. calculate the total and per-unit-lai fluxes for PAR in the
! sunlit and shaded canopy leaf fractions
parsun(p) = sun_aperlai(p,1)
parsha(p) = sha_aperlai(p,1)
! The following code is duplicated from SurfaceRadiation
! NDVI and reflected solar radiation
rvis = albd(p,1)*forc_solad(g,1) + albi(p,1)*forc_solai(g,1)
rnir = albd(p,2)*forc_solad(g,2) + albi(p,2)*forc_solai(g,2)
fsr(p) = rvis + rnir
fsds_vis_d(p) = forc_solad(g,1)
fsds_nir_d(p) = forc_solad(g,2)
fsds_vis_i(p) = forc_solai(g,1)
fsds_nir_i(p) = forc_solai(g,2)
fsr_vis_d(p) = albd(p,1)*forc_solad(g,1)
fsr_nir_d(p) = albd(p,2)*forc_solad(g,2)
fsr_vis_i(p) = albi(p,1)*forc_solai(g,1)
fsr_nir_i(p) = albi(p,2)*forc_solai(g,2)
local_secp1 = secs + nint((londeg(g)/15._r8*3600._r8)/dtime)*dtime
local_secp1 = mod(local_secp1,86400)
if (local_secp1 == 43200) then
fsds_vis_d_ln(p) = forc_solad(g,1)
fsds_nir_d_ln(p) = forc_solad(g,2)
fsr_vis_d_ln(p) = albd(p,1)*forc_solad(g,1)
fsr_nir_d_ln(p) = albd(p,2)*forc_solad(g,2)
else
fsds_vis_d_ln(p) = spval
fsds_nir_d_ln(p) = spval
fsr_vis_d_ln(p) = spval
fsr_nir_d_ln(p) = spval
end if
! diagnostic variables (downwelling and absorbed radiation partitioning) for history files
! (OPTIONAL)
c = pcolumn(p)
if (snl(c) < 0) then
fsds_sno_vd(p) = forc_solad(g,1)
fsds_sno_nd(p) = forc_solad(g,2)
fsds_sno_vi(p) = forc_solai(g,1)
fsds_sno_ni(p) = forc_solai(g,2)
fsr_sno_vd(p) = fsds_vis_d(p)*albsnd_hst(c,1)
fsr_sno_nd(p) = fsds_nir_d(p)*albsnd_hst(c,2)
fsr_sno_vi(p) = fsds_vis_i(p)*albsni_hst(c,1)
fsr_sno_ni(p) = fsds_nir_i(p)*albsni_hst(c,2)
else
fsds_sno_vd(p) = spval
fsds_sno_nd(p) = spval
fsds_sno_vi(p) = spval
fsds_sno_ni(p) = spval
fsr_sno_vd(p) = spval
fsr_sno_nd(p) = spval
fsr_sno_vi(p) = spval
fsr_sno_ni(p) = spval
endif
end if
end do
end subroutine SurfaceRadiation
end module SurfaceRadiationMod
module SurfaceAlbedoMod 2,6
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: SurfaceAlbedoMod
!
! !DESCRIPTION:
! Performs surface albedo calculations
!
! !PUBLIC TYPES:
use clm_varcon , only : istsoil
#ifdef CROP
use clm_varcon , only : istcrop
#endif
use shr_kind_mod, only : r8 => shr_kind_r8
use clm_varpar , only : nlevsno
use SNICARMod , only : sno_nbr_aer, SNICAR_RT, DO_SNO_AER, DO_SNO_OC
use globals, only : nstep
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: SurfaceAlbedo ! Surface albedo and two-stream fluxes
!
! !PRIVATE MEMBER FUNCTIONS:
private :: SoilAlbedo ! Determine ground surface albedo
private :: TwoStream ! Two-stream fluxes for canopy radiative transfer
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SurfaceAlbedo
!
! !INTERFACE:
subroutine SurfaceAlbedo(lbg, ubg, lbc, ubc, lbp, ubp, & 2,15
num_nourbanc, filter_nourbanc, &
num_nourbanp, filter_nourbanp, &
nextsw_cday, declinp1)
!
! !DESCRIPTION:
! Surface albedo and two-stream fluxes
! Surface albedos. Also fluxes (per unit incoming direct and diffuse
! radiation) reflected, transmitted, and absorbed by vegetation.
! Also sunlit fraction of the canopy.
! The calling sequence is:
! -> SurfaceAlbedo: albedos for next time step
! -> SoilAlbedo: soil/lake/glacier/wetland albedos
! -> SNICAR_RT: snow albedos: direct beam (SNICAR)
! -> SNICAR_RT: snow albedos: diffuse (SNICAR)
! -> TwoStream: absorbed, reflected, transmitted solar fluxes (vis dir,vis dif, nir dir, nir dif)
!
! !USES:
use clmtype
use clm_varpar , only : numrad
use shr_orb_mod
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbg, ubg ! gridcell bounds
integer , intent(in) :: lbc, ubc ! column bounds
integer , intent(in) :: lbp, ubp ! pft bounds
integer , intent(in) :: num_nourbanc ! number of columns in non-urban filter
integer , intent(in) :: filter_nourbanc(ubc-lbc+1) ! column filter for non-urban points
integer , intent(in) :: num_nourbanp ! number of pfts in non-urban filter
integer , intent(in) :: filter_nourbanp(ubp-lbp+1) ! pft filter for non-urban points
real(r8), intent(in) :: nextsw_cday ! calendar day at Greenwich (1.00, ..., 365.99)
real(r8), intent(in) :: declinp1 ! declination angle (radians) for next time step
!
! !CALLED FROM:
! subroutine clm_driver1
! subroutine iniTimeVar
!
! !REVISION HISTORY:
! Author: Gordon Bonan
! 2/1/02, Peter Thornton: Migrate to new data structures
! 8/20/03, Mariana Vertenstein: Vectorized routine
! 11/3/03, Peter Thornton: added decl(c) output for use in CN code.
! 03/28/08, Mark Flanner: added SNICAR, which required reversing the
! order of calls to SNICAR_RT and SoilAlbedo and the location where
! ground albedo is calculated
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: pgridcell(:) ! gridcell of corresponding pft
integer , pointer :: plandunit(:) ! index into landunit level quantities
integer , pointer :: itypelun(:) ! landunit type
integer , pointer :: pcolumn(:) ! column of corresponding pft
integer , pointer :: cgridcell(:) ! gridcell of corresponding column
real(r8), pointer :: pwtgcell(:) ! weight of pft wrt corresponding gridcell
real(r8), pointer :: lat(:) ! gridcell latitude (radians)
real(r8), pointer :: lon(:) ! gridcell longitude (radians)
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) ! one-sided stem area index with burying by snow
real(r8), pointer :: h2osno(:) ! snow water (mm H2O)
real(r8), pointer :: rhol(:,:) ! leaf reflectance: 1=vis, 2=nir
real(r8), pointer :: rhos(:,:) ! stem reflectance: 1=vis, 2=nir
real(r8), pointer :: taul(:,:) ! leaf transmittance: 1=vis, 2=nir
real(r8), pointer :: taus(:,:) ! stem transmittance: 1=vis, 2=nir
integer , pointer :: ivt(:) ! pft vegetation type
!
! local pointers toimplicit out arguments
!
real(r8), pointer :: coszen(:) ! cosine of solar zenith angle
real(r8), pointer :: fsun(:) ! sunlit fraction of canopy
real(r8), pointer :: albgrd(:,:) ! ground albedo (direct)
real(r8), pointer :: albgri(:,:) ! ground albedo (diffuse)
real(r8), pointer :: albd(:,:) ! surface albedo (direct)
real(r8), pointer :: albi(:,:) ! surface albedo (diffuse)
real(r8), pointer :: fabd(:,:) ! flux absorbed by veg per unit direct flux
real(r8), pointer :: fabi(:,:) ! flux absorbed by veg per unit diffuse flux
real(r8), pointer :: ftdd(:,:) ! down direct flux below veg per unit dir flx
real(r8), pointer :: ftid(:,:) ! down diffuse flux below veg per unit dir flx
real(r8), pointer :: ftii(:,:) ! down diffuse flux below veg per unit dif flx
real(r8), pointer :: decl(:) ! solar declination angle (radians)
real(r8), pointer :: gdir(:) ! leaf projection in solar direction (0 to 1)
real(r8), pointer :: omega(:,:) ! fraction of intercepted radiation that is scattered (0 to 1)
real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water content (col,lyr) [kg/m2]
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens content (col,lyr) [kg/m2]
real(r8), pointer :: mss_cnc_bcphi(:,:) ! mass concentration of hydrophilic BC (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_bcpho(:,:) ! mass concentration of hydrophobic BC (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_ocphi(:,:) ! mass concentration of hydrophilic OC (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_ocpho(:,:) ! mass concentration of hydrophobic OC (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst1(:,:) ! mass concentration of dust aerosol species 1 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst2(:,:) ! mass concentration of dust aerosol species 2 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst3(:,:) ! mass concentration of dust aerosol species 3 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst4(:,:) ! mass concentration of dust aerosol species 4 (col,lyr) [kg/kg]
real(r8), pointer :: albsod(:,:) ! direct-beam soil albedo (col,bnd) [frc]
real(r8), pointer :: albsoi(:,:) ! diffuse soil albedo (col,bnd) [frc]
real(r8), pointer :: flx_absdv(:,:) ! direct flux absorption factor (col,lyr): VIS [frc]
real(r8), pointer :: flx_absdn(:,:) ! direct flux absorption factor (col,lyr): NIR [frc]
real(r8), pointer :: flx_absiv(:,:) ! diffuse flux absorption factor (col,lyr): VIS [frc]
real(r8), pointer :: flx_absin(:,:) ! diffuse flux absorption factor (col,lyr): NIR [frc]
real(r8), pointer :: snw_rds(:,:) ! snow grain radius (col,lyr) [microns]
real(r8), pointer :: albgrd_pur(:,:) ! pure snow ground albedo (direct)
real(r8), pointer :: albgri_pur(:,:) ! pure snow ground albedo (diffuse)
real(r8), pointer :: albgrd_bc(:,:) ! ground albedo without BC (direct)
real(r8), pointer :: albgri_bc(:,:) ! ground albedo without BC (diffuse)
real(r8), pointer :: albgrd_oc(:,:) ! ground albedo without OC (direct)
real(r8), pointer :: albgri_oc(:,:) ! ground albedo without OC (diffuse)
real(r8), pointer :: albgrd_dst(:,:) ! ground albedo without dust (direct)
real(r8), pointer :: albgri_dst(:,:) ! ground albedo without dust (diffuse)
real(r8), pointer :: albsnd_hst(:,:) ! snow albedo, direct, for history files (col,bnd) [frc]
real(r8), pointer :: albsni_hst(:,:) ! snow ground albedo, diffuse, for history files (col,bnd) [frc]
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
real(r8), parameter :: mpe = 1.e-06_r8 ! prevents overflow for division by zero
integer :: fp,fc,g,c,p ! indices
integer :: ib ! band index
integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse
real(r8) :: wl(lbp:ubp) ! fraction of LAI+SAI that is LAI
real(r8) :: ws(lbp:ubp) ! fraction of LAI+SAI that is SAI
real(r8) :: vai(lbp:ubp) ! elai+esai
real(r8) :: rho(lbp:ubp,numrad) ! leaf/stem refl weighted by fraction LAI and SAI
real(r8) :: tau(lbp:ubp,numrad) ! leaf/stem tran weighted by fraction LAI and SAI
real(r8) :: ftdi(lbp:ubp,numrad) ! down direct flux below veg per unit dif flux = 0
real(r8) :: albsnd(lbc:ubc,numrad) ! snow albedo (direct)
real(r8) :: albsni(lbc:ubc,numrad) ! snow albedo (diffuse)
real(r8) :: ext(lbp:ubp) ! optical depth direct beam per unit LAI+SAI
real(r8) :: coszen_gcell(lbg:ubg) ! cosine solar zenith angle for next time step (gridcell level)
real(r8) :: coszen_col(lbc:ubc) ! cosine solar zenith angle for next time step (pft level)
real(r8) :: coszen_pft(lbp:ubp) ! cosine solar zenith angle for next time step (pft level)
integer :: num_vegsol ! number of vegetated pfts where coszen>0
integer :: filter_vegsol(ubp-lbp+1) ! pft filter where vegetated and coszen>0
integer :: num_novegsol ! number of vegetated pfts where coszen>0
integer :: filter_novegsol(ubp-lbp+1) ! pft filter where vegetated and coszen>0
integer, parameter :: nband =numrad ! number of solar radiation waveband classes
integer :: flg_slr ! flag for SNICAR (=1 if direct, =2 if diffuse)
integer :: flg_snw_ice ! flag for SNICAR (=1 when called from CLM, =2 when called from sea-ice)
real(r8) :: albsnd_pur(lbc:ubc,numrad) ! direct pure snow albedo (radiative forcing)
real(r8) :: albsni_pur(lbc:ubc,numrad) ! diffuse pure snow albedo (radiative forcing)
real(r8) :: albsnd_bc(lbc:ubc,numrad) ! direct snow albedo without BC (radiative forcing)
real(r8) :: albsni_bc(lbc:ubc,numrad) ! diffuse snow albedo without BC (radiative forcing)
real(r8) :: albsnd_oc(lbc:ubc,numrad) ! direct snow albedo without OC (radiative forcing)
real(r8) :: albsni_oc(lbc:ubc,numrad) ! diffuse snow albedo without OC (radiative forcing)
real(r8) :: albsnd_dst(lbc:ubc,numrad) ! direct snow albedo without dust (radiative forcing)
real(r8) :: albsni_dst(lbc:ubc,numrad) ! diffuse snow albedo without dust (radiative forcing)
integer :: i ! index for layers [idx]
real(r8) :: flx_absd_snw(lbc:ubc,-nlevsno+1:1,numrad) ! flux absorption factor for just snow (direct) [frc]
real(r8) :: flx_absi_snw(lbc:ubc,-nlevsno+1:1,numrad) ! flux absorption factor for just snow (diffuse) [frc]
real(r8) :: foo_snw(lbc:ubc,-nlevsno+1:1,numrad) ! dummy array for forcing calls
real(r8) :: albsfc(lbc:ubc,numrad) ! albedo of surface underneath snow (col,bnd)
real(r8) :: h2osno_liq(lbc:ubc,-nlevsno+1:0) ! liquid snow content (col,lyr) [kg m-2]
real(r8) :: h2osno_ice(lbc:ubc,-nlevsno+1:0) ! ice content in snow (col,lyr) [kg m-2]
integer :: snw_rds_in(lbc:ubc,-nlevsno+1:0) ! snow grain size sent to SNICAR (col,lyr) [microns]
real(r8) :: mss_cnc_aer_in_frc_pur(lbc:ubc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of aerosol species for forcing calculation (zero) (col,lyr,aer) [kg kg-1]
real(r8) :: mss_cnc_aer_in_frc_bc(lbc:ubc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of aerosol species for BC forcing (col,lyr,aer) [kg kg-1]
real(r8) :: mss_cnc_aer_in_frc_oc(lbc:ubc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of aerosol species for OC forcing (col,lyr,aer) [kg kg-1]
real(r8) :: mss_cnc_aer_in_frc_dst(lbc:ubc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of aerosol species for dust forcing (col,lyr,aer) [kg kg-1]
real(r8) :: mss_cnc_aer_in_fdb(lbc:ubc,-nlevsno+1:0,sno_nbr_aer) ! mass concentration of all aerosol species for feedback calculation (col,lyr,aer) [kg kg-1]
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (gridcell-level)
lat => clm3%g%lat_a
lon => clm3%g%lon_a
! Assign local pointers to derived subtypes components (landunit level)
itypelun => clm3%g%l%itype
! Assign local pointers to derived subtypes components (column-level)
cgridcell => clm3%g%l%c%gridcell
h2osno => clm3%g%l%c%cws%h2osno
albgrd => clm3%g%l%c%cps%albgrd
albgri => clm3%g%l%c%cps%albgri
decl => clm3%g%l%c%cps%decl
coszen => clm3%g%l%c%cps%coszen
albsod => clm3%g%l%c%cps%albsod
albsoi => clm3%g%l%c%cps%albsoi
frac_sno => clm3%g%l%c%cps%frac_sno
flx_absdv => clm3%g%l%c%cps%flx_absdv
flx_absdn => clm3%g%l%c%cps%flx_absdn
flx_absiv => clm3%g%l%c%cps%flx_absiv
flx_absin => clm3%g%l%c%cps%flx_absin
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
snw_rds => clm3%g%l%c%cps%snw_rds
albgrd_pur => clm3%g%l%c%cps%albgrd_pur
albgri_pur => clm3%g%l%c%cps%albgri_pur
albgrd_bc => clm3%g%l%c%cps%albgrd_bc
albgri_bc => clm3%g%l%c%cps%albgri_bc
albgrd_oc => clm3%g%l%c%cps%albgrd_oc
albgri_oc => clm3%g%l%c%cps%albgri_oc
albgrd_dst => clm3%g%l%c%cps%albgrd_dst
albgri_dst => clm3%g%l%c%cps%albgri_dst
mss_cnc_bcphi => clm3%g%l%c%cps%mss_cnc_bcphi
mss_cnc_bcpho => clm3%g%l%c%cps%mss_cnc_bcpho
mss_cnc_ocphi => clm3%g%l%c%cps%mss_cnc_ocphi
mss_cnc_ocpho => clm3%g%l%c%cps%mss_cnc_ocpho
mss_cnc_dst1 => clm3%g%l%c%cps%mss_cnc_dst1
mss_cnc_dst2 => clm3%g%l%c%cps%mss_cnc_dst2
mss_cnc_dst3 => clm3%g%l%c%cps%mss_cnc_dst3
mss_cnc_dst4 => clm3%g%l%c%cps%mss_cnc_dst4
albsnd_hst => clm3%g%l%c%cps%albsnd_hst
albsni_hst => clm3%g%l%c%cps%albsni_hst
! Assign local pointers to derived subtypes components (pft-level)
plandunit => clm3%g%l%c%p%landunit
pgridcell => clm3%g%l%c%p%gridcell
pcolumn => clm3%g%l%c%p%column
pwtgcell => clm3%g%l%c%p%wtgcell
albd => clm3%g%l%c%p%pps%albd
albi => clm3%g%l%c%p%pps%albi
fabd => clm3%g%l%c%p%pps%fabd
fabi => clm3%g%l%c%p%pps%fabi
ftdd => clm3%g%l%c%p%pps%ftdd
ftid => clm3%g%l%c%p%pps%ftid
ftii => clm3%g%l%c%p%pps%ftii
fsun => clm3%g%l%c%p%pps%fsun
elai => clm3%g%l%c%p%pps%elai
esai => clm3%g%l%c%p%pps%esai
gdir => clm3%g%l%c%p%pps%gdir
omega => clm3%g%l%c%p%pps%omega
ivt => clm3%g%l%c%p%itype
rhol => pftcon%rhol
rhos => pftcon%rhos
taul => pftcon%taul
taus => pftcon%taus
! Cosine solar zenith angle for next time step
do g = lbg, ubg
coszen_gcell(g) = shr_orb_cosz (nextsw_cday, lat(g), lon(g), declinp1)
end do
! Save coszen and declination values to clm3 data structures for
! use in other places in the CN and urban code
do c = lbc,ubc
g = cgridcell(c)
coszen_col(c) = coszen_gcell(g)
coszen(c) = coszen_col(c)
decl(c) = declinp1
end do
do fp = 1,num_nourbanp
p = filter_nourbanp(fp)
! if (pwtgcell(p)>0._r8) then ! "if" added due to chg in filter definition
g = pgridcell(p)
coszen_pft(p) = coszen_gcell(g)
! end if ! then removed for CNDV (and dyn. landuse?) cases to work
end do
! Initialize output because solar radiation only done if coszen > 0
do ib = 1, numrad
do fc = 1,num_nourbanc
c = filter_nourbanc(fc)
albgrd(c,ib) = 0._r8
albgri(c,ib) = 0._r8
albgrd_pur(c,ib) = 0._r8
albgri_pur(c,ib) = 0._r8
albgrd_bc(c,ib) = 0._r8
albgri_bc(c,ib) = 0._r8
albgrd_oc(c,ib) = 0._r8
albgri_oc(c,ib) = 0._r8
albgrd_dst(c,ib) = 0._r8
albgri_dst(c,ib) = 0._r8
do i=-nlevsno+1,1,1
flx_absdv(c,i) = 0._r8
flx_absdn(c,i) = 0._r8
flx_absiv(c,i) = 0._r8
flx_absin(c,i) = 0._r8
enddo
end do
do fp = 1,num_nourbanp
p = filter_nourbanp(fp)
! if (pwtgcell(p)>0._r8) then ! "if" added due to chg in filter definition
albd(p,ib) = 0.999_r8
albi(p,ib) = 0.999_r8
fabd(p,ib) = 0._r8
fabi(p,ib) = 0._r8
ftdd(p,ib) = 0._r8
ftid(p,ib) = 0._r8
ftii(p,ib) = 0._r8
omega(p,ib)= 0._r8
if (ib==1) then
gdir(p) = 0._r8
end if
! end if ! then removed for CNDV (and dyn. landuse?) cases to work
end do
end do
! SoilAlbedo called before SNICAR_RT
! so that reflectance of soil beneath snow column is known
! ahead of time for snow RT calculation.
! Snow albedos
! Note that snow albedo routine will only compute nonzero snow albedos
! where h2osno> 0 and coszen > 0
! Ground surface albedos
! Note that ground albedo routine will only compute nonzero snow albedos
! where coszen > 0
call SoilAlbedo(lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, albsnd, albsni)
! set variables to pass to SNICAR.
flg_snw_ice = 1 ! calling from CLM, not CSIM
do c=lbc,ubc
albsfc(c,:) = albsoi(c,:)
h2osno_liq(c,:) = h2osoi_liq(c,-nlevsno+1:0)
h2osno_ice(c,:) = h2osoi_ice(c,-nlevsno+1:0)
snw_rds_in(c,:) = nint(snw_rds(c,:))
! zero aerosol input arrays
mss_cnc_aer_in_frc_pur(c,:,:) = 0._r8
mss_cnc_aer_in_frc_bc(c,:,:) = 0._r8
mss_cnc_aer_in_frc_oc(c,:,:) = 0._r8
mss_cnc_aer_in_frc_dst(c,:,:) = 0._r8
mss_cnc_aer_in_fdb(c,:,:) = 0._r8
end do
! Set aerosol input arrays
! feedback input arrays have been zeroed
! set soot and dust aerosol concentrations:
if (DO_SNO_AER) then
mss_cnc_aer_in_fdb(lbc:ubc,:,1) = mss_cnc_bcphi(lbc:ubc,:)
mss_cnc_aer_in_fdb(lbc:ubc,:,2) = mss_cnc_bcpho(lbc:ubc,:)
! DO_SNO_OC is set in SNICAR_varpar. Default case is to ignore OC concentrations because:
! 1) Knowledge of their optical properties is primitive
! 2) When 'water-soluble' OPAC optical properties are applied to OC in snow,
! it has a negligible darkening effect.
if (DO_SNO_OC) then
mss_cnc_aer_in_fdb(lbc:ubc,:,3) = mss_cnc_ocphi(lbc:ubc,:)
mss_cnc_aer_in_fdb(lbc:ubc,:,4) = mss_cnc_ocpho(lbc:ubc,:)
endif
mss_cnc_aer_in_fdb(lbc:ubc,:,5) = mss_cnc_dst1(lbc:ubc,:)
mss_cnc_aer_in_fdb(lbc:ubc,:,6) = mss_cnc_dst2(lbc:ubc,:)
mss_cnc_aer_in_fdb(lbc:ubc,:,7) = mss_cnc_dst3(lbc:ubc,:)
mss_cnc_aer_in_fdb(lbc:ubc,:,8) = mss_cnc_dst4(lbc:ubc,:)
endif
! If radiative forcing is being calculated, first estimate clean-snow albedo
! NOTE: To invoke radiative forcing, user must define #SNICAR_FRC in misc.h or cpp
#if (defined SNICAR_FRC)
! 1. BC input array:
! set dust and (optionally) OC concentrations, so BC_FRC=[(BC+OC+dust)-(OC+dust)]
mss_cnc_aer_in_frc_bc(lbc:ubc,:,5) = mss_cnc_dst1(lbc:ubc,:)
mss_cnc_aer_in_frc_bc(lbc:ubc,:,6) = mss_cnc_dst2(lbc:ubc,:)
mss_cnc_aer_in_frc_bc(lbc:ubc,:,7) = mss_cnc_dst3(lbc:ubc,:)
mss_cnc_aer_in_frc_bc(lbc:ubc,:,8) = mss_cnc_dst4(lbc:ubc,:)
if (DO_SNO_OC) then
mss_cnc_aer_in_frc_bc(lbc:ubc,:,3) = mss_cnc_ocphi(lbc:ubc,:)
mss_cnc_aer_in_frc_bc(lbc:ubc,:,4) = mss_cnc_ocpho(lbc:ubc,:)
endif
! BC FORCING CALCULATIONS
flg_slr = 1; ! direct-beam
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_frc_bc, albsfc, albsnd_bc, foo_snw)
flg_slr = 2; ! diffuse
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_frc_bc, albsfc, albsni_bc, foo_snw)
! 2. OC input array:
! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)]
if (DO_SNO_OC) then
mss_cnc_aer_in_frc_oc(lbc:ubc,:,1) = mss_cnc_bcphi(lbc:ubc,:)
mss_cnc_aer_in_frc_oc(lbc:ubc,:,2) = mss_cnc_bcpho(lbc:ubc,:)
mss_cnc_aer_in_frc_oc(lbc:ubc,:,5) = mss_cnc_dst1(lbc:ubc,:)
mss_cnc_aer_in_frc_oc(lbc:ubc,:,6) = mss_cnc_dst2(lbc:ubc,:)
mss_cnc_aer_in_frc_oc(lbc:ubc,:,7) = mss_cnc_dst3(lbc:ubc,:)
mss_cnc_aer_in_frc_oc(lbc:ubc,:,8) = mss_cnc_dst4(lbc:ubc,:)
! OC FORCING CALCULATIONS
flg_slr = 1; ! direct-beam
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_frc_oc, albsfc, albsnd_oc, foo_snw)
flg_slr = 2; ! diffuse
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_frc_oc, albsfc, albsni_oc, foo_snw)
endif
! 3. DUST input array:
! set BC and OC concentrations, so DST_FRC=[(BC+OC+dust)-(BC+OC)]
mss_cnc_aer_in_frc_dst(lbc:ubc,:,1) = mss_cnc_bcphi(lbc:ubc,:)
mss_cnc_aer_in_frc_dst(lbc:ubc,:,2) = mss_cnc_bcpho(lbc:ubc,:)
if (DO_SNO_OC) then
mss_cnc_aer_in_frc_dst(lbc:ubc,:,3) = mss_cnc_ocphi(lbc:ubc,:)
mss_cnc_aer_in_frc_dst(lbc:ubc,:,4) = mss_cnc_ocpho(lbc:ubc,:)
endif
! DUST FORCING CALCULATIONS
flg_slr = 1; ! direct-beam
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_frc_dst, albsfc, albsnd_dst, foo_snw)
flg_slr = 2; ! diffuse
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_frc_dst, albsfc, albsni_dst, foo_snw)
! 4. ALL AEROSOL FORCING CALCULATION
! (pure snow albedo)
flg_slr = 1; ! direct-beam
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_frc_pur, albsfc, albsnd_pur, foo_snw)
flg_slr = 2; ! diffuse
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_frc_pur, albsfc, albsni_pur, foo_snw)
#endif
! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS:
flg_slr = 1; ! direct-beam
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_fdb, albsfc, albsnd, flx_absd_snw)
flg_slr = 2; ! diffuse
call SNICAR_RT(flg_snw_ice, lbc, ubc, num_nourbanc, filter_nourbanc, &
coszen_col, flg_slr, h2osno_liq, h2osno_ice, snw_rds_in, &
mss_cnc_aer_in_fdb, albsfc, albsni, flx_absi_snw)
! ground albedos and snow-fraction weighting of snow absorption factors
do ib = 1, nband
do fc = 1,num_nourbanc
c = filter_nourbanc(fc)
if (coszen(c) > 0._r8) then
! ground albedo was originally computed in SoilAlbedo, but is now computed here
! because the order of SoilAlbedo and SNICAR_RT was switched for SNICAR.
albgrd(c,ib) = albsod(c,ib)*(1._r8-frac_sno(c)) + albsnd(c,ib)*frac_sno(c)
albgri(c,ib) = albsoi(c,ib)*(1._r8-frac_sno(c)) + albsni(c,ib)*frac_sno(c)
! albedos for radiative forcing calculations:
#if (defined SNICAR_FRC)
! BC forcing albedo
albgrd_bc(c,ib) = albsod(c,ib)*(1.-frac_sno(c)) + albsnd_bc(c,ib)*frac_sno(c)
albgri_bc(c,ib) = albsoi(c,ib)*(1.-frac_sno(c)) + albsni_bc(c,ib)*frac_sno(c)
if (DO_SNO_OC) then
! OC forcing albedo
albgrd_oc(c,ib) = albsod(c,ib)*(1.-frac_sno(c)) + albsnd_oc(c,ib)*frac_sno(c)
albgri_oc(c,ib) = albsoi(c,ib)*(1.-frac_sno(c)) + albsni_oc(c,ib)*frac_sno(c)
endif
! dust forcing albedo
albgrd_dst(c,ib) = albsod(c,ib)*(1.-frac_sno(c)) + albsnd_dst(c,ib)*frac_sno(c)
albgri_dst(c,ib) = albsoi(c,ib)*(1.-frac_sno(c)) + albsni_dst(c,ib)*frac_sno(c)
! pure snow albedo for all-aerosol radiative forcing
albgrd_pur(c,ib) = albsod(c,ib)*(1.-frac_sno(c)) + albsnd_pur(c,ib)*frac_sno(c)
albgri_pur(c,ib) = albsoi(c,ib)*(1.-frac_sno(c)) + albsni_pur(c,ib)*frac_sno(c)
#endif
! also in this loop (but optionally in a different loop for vectorized code)
! weight snow layer radiative absorption factors based on snow fraction and soil albedo
! (NEEDED FOR ENERGY CONSERVATION)
do i = -nlevsno+1,1,1
if (ib == 1) then
flx_absdv(c,i) = flx_absd_snw(c,i,ib)*frac_sno(c) + &
((1.-frac_sno(c))*(1-albsod(c,ib))*(flx_absd_snw(c,i,ib)/(1.-albsnd(c,ib))))
flx_absiv(c,i) = flx_absi_snw(c,i,ib)*frac_sno(c) + &
((1.-frac_sno(c))*(1-albsoi(c,ib))*(flx_absi_snw(c,i,ib)/(1.-albsni(c,ib))))
elseif (ib == 2) then
flx_absdn(c,i) = flx_absd_snw(c,i,ib)*frac_sno(c) + &
((1.-frac_sno(c))*(1-albsod(c,ib))*(flx_absd_snw(c,i,ib)/(1.-albsnd(c,ib))))
flx_absin(c,i) = flx_absi_snw(c,i,ib)*frac_sno(c) + &
((1.-frac_sno(c))*(1-albsoi(c,ib))*(flx_absi_snw(c,i,ib)/(1.-albsni(c,ib))))
endif
enddo
endif
enddo
enddo
! for diagnostics, set snow albedo to spval over non-snow points
! so that it is not averaged in history buffer
! (OPTIONAL)
do ib = 1, nband
do fc = 1,num_nourbanc
c = filter_nourbanc(fc)
if ((coszen(c) > 0._r8) .and. (h2osno(c) > 0._r8)) then
albsnd_hst(c,ib) = albsnd(c,ib)
albsni_hst(c,ib) = albsni(c,ib)
else
albsnd_hst(c,ib) = 0._r8
albsni_hst(c,ib) = 0._r8
endif
enddo
enddo
! Create solar-vegetated filter for the following calculations
num_vegsol = 0
num_novegsol = 0
do fp = 1,num_nourbanp
p = filter_nourbanp(fp)
if (coszen_pft(p) > 0._r8) then
#ifndef CROP
if (itypelun(plandunit(p)) == istsoil &
.and. (elai(p) + esai(p)) > 0._r8 &
.and. pwtgcell(p) > 0._r8) then
#else
if ((itypelun(plandunit(p)) == istsoil .or. &
itypelun(plandunit(p)) == istcrop ) &
.and. (elai(p) + esai(p)) > 0._r8 &
.and. pwtgcell(p) > 0._r8) then
#endif
num_vegsol = num_vegsol + 1
filter_vegsol(num_vegsol) = p
else
num_novegsol = num_novegsol + 1
filter_novegsol(num_novegsol) = p
end if
end if
end do
! Weight reflectance/transmittance by lai and sai
! Only perform on vegetated pfts where coszen > 0
do fp = 1,num_vegsol
p = filter_vegsol(fp)
vai(p) = elai(p) + esai(p)
wl(p) = elai(p) / max( vai(p), mpe )
ws(p) = esai(p) / max( vai(p), mpe )
end do
do ib = 1, numrad
do fp = 1,num_vegsol
p = filter_vegsol(fp)
rho(p,ib) = max( rhol(ivt(p),ib)*wl(p) + rhos(ivt(p),ib)*ws(p), mpe )
tau(p,ib) = max( taul(ivt(p),ib)*wl(p) + taus(ivt(p),ib)*ws(p), mpe )
end do
end do
! Calculate surface albedos and fluxes
! Only perform on vegetated pfts where coszen > 0
call TwoStream (lbc, ubc, lbp, ubp, filter_vegsol, num_vegsol, &
coszen_pft, vai, rho, tau)
! Determine values for non-vegetated pfts where coszen > 0
do ib = 1,numrad
do fp = 1,num_novegsol
p = filter_novegsol(fp)
c = pcolumn(p)
fabd(p,ib) = 0._r8
fabi(p,ib) = 0._r8
ftdd(p,ib) = 1._r8
ftid(p,ib) = 0._r8
ftii(p,ib) = 1._r8
albd(p,ib) = albgrd(c,ib)
albi(p,ib) = albgri(c,ib)
gdir(p) = 0._r8
end do
end do
end subroutine SurfaceAlbedo
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SoilAlbedo
!
! !INTERFACE:
subroutine SoilAlbedo (lbc, ubc, num_nourbanc, filter_nourbanc, coszen, albsnd, albsni) 1,3
!
! !DESCRIPTION:
! Determine ground surface albedo, accounting for snow
!
! !USES:
use clmtype
use clm_varpar, only : numrad
use clm_varcon, only : albsat, albdry, alblak, albice, tfrz, istice
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! column bounds
integer , intent(in) :: num_nourbanc ! number of columns in non-urban points in column filter
integer , intent(in) :: filter_nourbanc(ubc-lbc+1) ! column filter for non-urban points
real(r8), intent(in) :: coszen(lbc:ubc) ! cos solar zenith angle next time step (column-level)
real(r8), intent(in) :: albsnd(lbc:ubc,numrad) ! snow albedo (direct)
real(r8), intent(in) :: albsni(lbc:ubc,numrad) ! snow albedo (diffuse)
!
! !CALLED FROM:
! subroutine SurfaceAlbedo in this module
!
! !REVISION HISTORY:
! Author: Gordon Bonan
! 2/5/02, Peter Thornton: Migrated to new data structures.
! 8/20/03, Mariana Vertenstein: Vectorized routine
! 03/28/08, Mark Flanner: changes for SNICAR
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in arguments
!
integer , pointer :: clandunit(:) ! landunit of corresponding column
integer , pointer :: ltype(:) ! landunit type
integer , pointer :: isoicol(:) ! soil color class
real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin)
real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1)
real(r8), pointer :: h2osoi_vol(:,:) ! volumetric soil water [m3/m3]
!
! local pointers to original implicit out arguments
!
real(r8), pointer:: albgrd(:,:) ! ground albedo (direct)
real(r8), pointer:: albgri(:,:) ! ground albedo (diffuse)
! albsod and albsoi are now clm_type variables so they can be used by SNICAR.
real(r8), pointer :: albsod(:,:) ! soil albedo (direct)
real(r8), pointer :: albsoi(:,:) ! soil albedo (diffuse)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer, parameter :: nband =numrad ! number of solar radiation waveband classes
integer :: fc ! non-urban filter column index
integer :: c,l ! indices
integer :: ib ! waveband number (1=vis, 2=nir)
real(r8) :: inc ! soil water correction factor for soil albedo
! albsod and albsoi are now clm_type variables so they can be used by SNICAR.
!real(r8) :: albsod ! soil albedo (direct)
!real(r8) :: albsoi ! soil albedo (diffuse)
integer :: soilcol ! soilcolor
!-----------------------------------------------------------------------
!dir$ inlinenever SoilAlbedo
! Assign local pointers to derived subtypes components (column-level)
clandunit => clm3%g%l%c%landunit
isoicol => clm3%g%l%c%cps%isoicol
t_grnd => clm3%g%l%c%ces%t_grnd
frac_sno => clm3%g%l%c%cps%frac_sno
h2osoi_vol => clm3%g%l%c%cws%h2osoi_vol
albgrd => clm3%g%l%c%cps%albgrd
albgri => clm3%g%l%c%cps%albgri
albsod => clm3%g%l%c%cps%albsod
albsoi => clm3%g%l%c%cps%albsoi
! Assign local pointers to derived subtypes components (landunit-level)
ltype => clm3%g%l%itype
! Compute soil albedos
do ib = 1, nband
do fc = 1,num_nourbanc
c = filter_nourbanc(fc)
if (coszen(c) > 0._r8) then
l = clandunit(c)
#ifndef CROP
if (ltype(l) == istsoil) then ! soil
#else
if (ltype(l) == istsoil .or. ltype(l) == istcrop) then ! soil
#endif
inc = max(0.11_r8-0.40_r8*h2osoi_vol(c,1), 0._r8)
soilcol = isoicol(c)
! changed from local variable to clm_type:
!albsod = min(albsat(soilcol,ib)+inc, albdry(soilcol,ib))
!albsoi = albsod
albsod(c,ib) = min(albsat(soilcol,ib)+inc, albdry(soilcol,ib))
albsoi(c,ib) = albsod(c,ib)
else if (ltype(l) == istice) then ! land ice
! changed from local variable to clm_type:
!albsod = albice(ib)
!albsoi = albsod
albsod(c,ib) = albice(ib)
albsoi(c,ib) = albsod(c,ib)
else if (t_grnd(c) > tfrz) then ! unfrozen lake, wetland
! changed from local variable to clm_type:
!albsod = 0.05_r8/(max(0.001_r8,coszen(c)) + 0.15_r8)
!albsoi = albsod
albsod(c,ib) = 0.05_r8/(max(0.001_r8,coszen(c)) + 0.15_r8)
albsoi(c,ib) = albsod(c,ib)
else ! frozen lake, wetland
! changed from local variable to clm_type:
!albsod = alblak(ib)
!albsoi = albsod
albsod(c,ib) = alblak(ib)
albsoi(c,ib) = albsod(c,ib)
end if
! Weighting is done in SurfaceAlbedo, after the call to SNICAR_RT
! This had to be done, because SoilAlbedo is called before SNICAR_RT, so at
! this point, snow albedo is not yet known.
end if
end do
end do
end subroutine SoilAlbedo
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: TwoStream
!
! !INTERFACE:
subroutine TwoStream (lbc, ubc, lbp, ubp, filter_vegsol, num_vegsol, & 3,5
coszen, vai, rho, tau)
!
! !DESCRIPTION:
! Two-stream fluxes for canopy radiative transfer
! Use two-stream approximation of Dickinson (1983) Adv Geophysics
! 25:305-353 and Sellers (1985) Int J Remote Sensing 6:1335-1372
! to calculate fluxes absorbed by vegetation, reflected by vegetation,
! and transmitted through vegetation for unit incoming direct or diffuse
! flux given an underlying surface with known albedo.
!
! !USES:
use clmtype
use clm_varpar, only : numrad
use clm_varcon, only : omegas, tfrz, betads, betais
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! column bounds
integer , intent(in) :: lbp, ubp ! pft bounds
integer , intent(in) :: filter_vegsol(ubp-lbp+1) ! filter for vegetated pfts with coszen>0
integer , intent(in) :: num_vegsol ! number of vegetated pfts where coszen>0
real(r8), intent(in) :: coszen(lbp:ubp) ! cosine solar zenith angle for next time step
real(r8), intent(in) :: vai(lbp:ubp) ! elai+esai
real(r8), intent(in) :: rho(lbp:ubp,numrad) ! leaf/stem refl weighted by fraction LAI and SAI
real(r8), intent(in) :: tau(lbp:ubp,numrad) ! leaf/stem tran weighted by fraction LAI and SAI
!
! !CALLED FROM:
! subroutine SurfaceAlbedo in this module
!
! !REVISION HISTORY:
! Author: Gordon Bonan
! Modified for speedup: Mariana Vertenstein, 8/26/02
! Vectorized routine: Mariana Vertenstein: 8/20/03
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in scalars
!
integer , pointer :: pcolumn(:) ! column of corresponding pft
real(r8), pointer :: albgrd(:,:) ! ground albedo (direct) (column-level)
real(r8), pointer :: albgri(:,:) ! ground albedo (diffuse)(column-level)
real(r8), pointer :: t_veg(:) ! vegetation temperature (Kelvin)
real(r8), pointer :: fwet(:) ! fraction of canopy that is wet (0 to 1)
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: xl(:) ! ecophys const - leaf/stem orientation index
!
! local pointers to implicit out scalars
!
real(r8), pointer :: albd(:,:) ! surface albedo (direct)
real(r8), pointer :: albi(:,:) ! surface albedo (diffuse)
real(r8), pointer :: fabd(:,:) ! flux absorbed by veg per unit direct flux
real(r8), pointer :: fabi(:,:) ! flux absorbed by veg per unit diffuse flux
real(r8), pointer :: ftdd(:,:) ! down direct flux below veg per unit dir flx
real(r8), pointer :: ftid(:,:) ! down diffuse flux below veg per unit dir flx
real(r8), pointer :: ftii(:,:) ! down diffuse flux below veg per unit dif flx
real(r8), pointer :: gdir(:) ! leaf projection in solar direction (0 to 1)
real(r8), pointer :: omega(:,:) ! fraction of intercepted radiation that is scattered (0 to 1)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: fp,p,c ! array indices
!integer :: ic ! 0=unit incoming direct; 1=unit incoming diffuse
integer :: ib ! waveband number
real(r8) :: cosz ! 0.001 <= coszen <= 1.000
real(r8) :: asu ! single scattering albedo
real(r8) :: chil(lbp:ubp) ! -0.4 <= xl <= 0.6
real(r8) :: twostext(lbp:ubp)! optical depth of direct beam per unit leaf area
real(r8) :: avmu(lbp:ubp) ! average diffuse optical depth
real(r8) :: omegal ! omega for leaves
real(r8) :: betai ! upscatter parameter for diffuse radiation
real(r8) :: betail ! betai for leaves
real(r8) :: betad ! upscatter parameter for direct beam radiation
real(r8) :: betadl ! betad for leaves
real(r8) :: tmp0,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7,tmp8,tmp9 ! temporary
real(r8) :: p1,p2,p3,p4,s1,s2,u1,u2,u3 ! temporary
real(r8) :: b,c1,d,d1,d2,f,h,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10 ! temporary
real(r8) :: phi1,phi2,sigma ! temporary
real(r8) :: temp0(lbp:ubp),temp1,temp2(lbp:ubp) ! temporary
real(r8) :: t1
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (column-level)
albgrd => clm3%g%l%c%cps%albgrd
albgri => clm3%g%l%c%cps%albgri
! Assign local pointers to derived subtypes components (pft-level)
pcolumn => clm3%g%l%c%p%column
fwet => clm3%g%l%c%p%pps%fwet
t_veg => clm3%g%l%c%p%pes%t_veg
ivt => clm3%g%l%c%p%itype
albd => clm3%g%l%c%p%pps%albd
albi => clm3%g%l%c%p%pps%albi
fabd => clm3%g%l%c%p%pps%fabd
fabi => clm3%g%l%c%p%pps%fabi
ftdd => clm3%g%l%c%p%pps%ftdd
ftid => clm3%g%l%c%p%pps%ftid
ftii => clm3%g%l%c%p%pps%ftii
gdir => clm3%g%l%c%p%pps%gdir
omega => clm3%g%l%c%p%pps%omega
xl => pftcon%xl
! Calculate two-stream parameters omega, betad, betai, avmu, gdir, twostext.
! Omega, betad, betai are adjusted for snow. Values for omega*betad
! and omega*betai are calculated and then divided by the new omega
! because the product omega*betai, omega*betad is used in solution.
! Also, the transmittances and reflectances (tau, rho) are linear
! weights of leaf and stem values.
do fp = 1,num_vegsol
p = filter_vegsol(fp)
! note that the following limit only acts on cosz values > 0 and less than
! 0.001, not on values cosz = 0, since these zero have already been filtered
! out in filter_vegsol
cosz = max(0.001_r8, coszen(p))
chil(p) = min( max(xl(ivt(p)), -0.4_r8), 0.6_r8 )
if (abs(chil(p)) <= 0.01_r8) chil(p) = 0.01_r8
phi1 = 0.5_r8 - 0.633_r8*chil(p) - 0.330_r8*chil(p)*chil(p)
phi2 = 0.877_r8 * (1._r8-2._r8*phi1)
gdir(p) = phi1 + phi2*cosz
twostext(p) = gdir(p)/cosz
avmu(p) = ( 1._r8 - phi1/phi2 * log((phi1+phi2)/phi1) ) / phi2
temp0(p) = gdir(p) + phi2*cosz
temp1 = phi1*cosz
temp2(p) = ( 1._r8 - temp1/temp0(p) * log((temp1+temp0(p))/temp1) )
end do
do ib = 1, numrad
do fp = 1,num_vegsol
p = filter_vegsol(fp)
c = pcolumn(p)
omegal = rho(p,ib) + tau(p,ib)
asu = 0.5_r8*omegal*gdir(p)/temp0(p) *temp2(p)
betadl = (1._r8+avmu(p)*twostext(p))/(omegal*avmu(p)*twostext(p))*asu
betail = 0.5_r8 * ((rho(p,ib)+tau(p,ib)) + (rho(p,ib)-tau(p,ib)) &
* ((1._r8+chil(p))/2._r8)**2) / omegal
! Adjust omega, betad, and betai for intercepted snow
if (t_veg(p) > tfrz) then !no snow
tmp0 = omegal
tmp1 = betadl
tmp2 = betail
else
tmp0 = (1._r8-fwet(p))*omegal + fwet(p)*omegas(ib)
tmp1 = ( (1._r8-fwet(p))*omegal*betadl + fwet(p)*omegas(ib)*betads ) / tmp0
tmp2 = ( (1._r8-fwet(p))*omegal*betail + fwet(p)*omegas(ib)*betais ) / tmp0
end if
omega(p,ib) = tmp0
betad = tmp1
betai = tmp2
! Absorbed, reflected, transmitted fluxes per unit incoming radiation
b = 1._r8 - omega(p,ib) + omega(p,ib)*betai
c1 = omega(p,ib)*betai
tmp0 = avmu(p)*twostext(p)
d = tmp0 * omega(p,ib)*betad
f = tmp0 * omega(p,ib)*(1._r8-betad)
tmp1 = b*b - c1*c1
h = sqrt(tmp1) / avmu(p)
sigma = tmp0*tmp0 - tmp1
p1 = b + avmu(p)*h
p2 = b - avmu(p)*h
p3 = b + tmp0
p4 = b - tmp0
! PET, 03/01/04: added this test to avoid floating point errors in exp()
! EBK, 04/15/08: always do this for all modes -- not just CN
t1 = min(h*vai(p), 40._r8)
s1 = exp(-t1)
t1 = min(twostext(p)*vai(p), 40._r8)
s2 = exp(-t1)
! Determine fluxes for vegetated pft for unit incoming direct
! Loop over incoming direct and incoming diffuse
! 0=unit incoming direct; 1=unit incoming diffuse
! ic = 0 unit incoming direct flux
! ========================================
u1 = b - c1/albgrd(c,ib)
u2 = b - c1*albgrd(c,ib)
u3 = f + c1*albgrd(c,ib)
tmp2 = u1 - avmu(p)*h
tmp3 = u1 + avmu(p)*h
d1 = p1*tmp2/s1 - p2*tmp3*s1
tmp4 = u2 + avmu(p)*h
tmp5 = u2 - avmu(p)*h
d2 = tmp4/s1 - tmp5*s1
h1 = -d*p4 - c1*f
tmp6 = d - h1*p3/sigma
tmp7 = ( d - c1 - h1/sigma*(u1+tmp0) ) * s2
h2 = ( tmp6*tmp2/s1 - p2*tmp7 ) / d1
h3 = - ( tmp6*tmp3*s1 - p1*tmp7 ) / d1
h4 = -f*p3 - c1*d
tmp8 = h4/sigma
tmp9 = ( u3 - tmp8*(u2-tmp0) ) * s2
h5 = - ( tmp8*tmp4/s1 + tmp9 ) / d2
h6 = ( tmp8*tmp5*s1 + tmp9 ) / d2
h7 = (c1*tmp2) / (d1*s1)
h8 = (-c1*tmp3*s1) / d1
h9 = tmp4 / (d2*s1)
h10 = (-tmp5*s1) / d2
! Downward direct and diffuse fluxes below vegetation (ic = 0)
ftdd(p,ib) = s2
ftid(p,ib) = h4*s2/sigma + h5*s1 + h6/s1
! Flux reflected by vegetation (ic = 0)
albd(p,ib) = h1/sigma + h2 + h3
! Flux absorbed by vegetation (ic = 0)
fabd(p,ib) = 1._r8 - albd(p,ib) &
- (1._r8-albgrd(c,ib))*ftdd(p,ib) - (1._r8-albgri(c,ib))*ftid(p,ib)
! ic = 1 unit incoming diffuse
! ========================================
u1 = b - c1/albgri(c,ib)
u2 = b - c1*albgri(c,ib)
u3 = f + c1*albgri(c,ib)
tmp2 = u1 - avmu(p)*h
tmp3 = u1 + avmu(p)*h
d1 = p1*tmp2/s1 - p2*tmp3*s1
tmp4 = u2 + avmu(p)*h
tmp5 = u2 - avmu(p)*h
d2 = tmp4/s1 - tmp5*s1
h1 = -d*p4 - c1*f
tmp6 = d - h1*p3/sigma
tmp7 = ( d - c1 - h1/sigma*(u1+tmp0) ) * s2
h2 = ( tmp6*tmp2/s1 - p2*tmp7 ) / d1
h3 = - ( tmp6*tmp3*s1 - p1*tmp7 ) / d1
h4 = -f*p3 - c1*d
tmp8 = h4/sigma
tmp9 = ( u3 - tmp8*(u2-tmp0) ) * s2
h5 = - ( tmp8*tmp4/s1 + tmp9 ) / d2
h6 = ( tmp8*tmp5*s1 + tmp9 ) / d2
h7 = (c1*tmp2) / (d1*s1)
h8 = (-c1*tmp3*s1) / d1
h9 = tmp4 / (d2*s1)
h10 = (-tmp5*s1) / d2
! Downward direct and diffuse fluxes below vegetation
ftii(p,ib) = h9*s1 + h10/s1
! Flux reflected by vegetation
albi(p,ib) = h7 + h8
! Flux absorbed by vegetation
fabi(p,ib) = 1._r8 - albi(p,ib) - (1._r8-albgri(c,ib))*ftii(p,ib)
end do ! end of pft loop
end do ! end of radiation band loop
end subroutine TwoStream
end module SurfaceAlbedoMod
module SoilTemperatureMod 1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: SoilTemperatureMod
!
! !DESCRIPTION:
! Calculates snow and soil temperatures including phase change
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: SoilTemperature ! Snow and soil temperatures including phase change
!
! !PRIVATE MEMBER FUNCTIONS:
private :: SoilThermProp ! Set therm conductivities and heat cap of snow/soil layers
private :: PhaseChange ! Calculation of the phase change within snow and soil layers
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SoilTemperature
!
! !INTERFACE:
subroutine SoilTemperature(lbl, ubl, lbc, ubc, num_urbanl, filter_urbanl, & 1,9
num_nolakec, filter_nolakec, xmf, fact)
!
! !DESCRIPTION:
! Snow and soil temperatures including phase change
! o The volumetric heat capacity is calculated as a linear combination
! in terms of the volumetric fraction of the constituent phases.
! o The thermal conductivity of soil is computed from
! the algorithm of Johansen (as reported by Farouki 1981), and the
! conductivity of snow is from the formulation used in
! SNTHERM (Jordan 1991).
! o Boundary conditions:
! F = Rnet - Hg - LEg (top), F= 0 (base of the soil column).
! o Soil / snow temperature is predicted from heat conduction
! in 10 soil layers and up to 5 snow layers.
! The thermal conductivities at the interfaces between two
! neighboring layers (j, j+1) are derived from an assumption that
! the flux across the interface is equal to that from the node j
! to the interface and the flux from the interface to the node j+1.
! The equation is solved using the Crank-Nicholson method and
! results in a tridiagonal system equation.
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use clm_varcon , only : sb, capr, cnfac, hvap, isturb, &
icol_roof, icol_sunwall, icol_shadewall, &
icol_road_perv, icol_road_imperv, istwet
use clm_varpar , only : nlevsno, nlevgrnd, max_pft_per_col, nlevurb
use TridiagonalMod, only : Tridiagonal
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! column bounds
integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer , intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
integer , intent(in) :: lbl, ubl ! landunit-index bounds
integer , intent(in) :: num_urbanl ! number of urban landunits in clump
integer , intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter
real(r8), intent(out) :: xmf(lbc:ubc) ! total latent heat of phase change of ground water
real(r8), intent(out) :: fact(lbc:ubc, -nlevsno+1:nlevgrnd) ! used in computing tridiagonal matrix
!
! !CALLED FROM:
! subroutine Biogeophysics2 in module Biogeophysics2Mod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 12/19/01, Peter Thornton
! Changed references for tg to t_grnd, for consistency with the
! rest of the code (tg eliminated as redundant)
! 2/14/02, Peter Thornton: Migrated to new data structures. Added pft loop
! in calculation of net ground heat flux.
! 3/18/08, David Lawrence: Change nlevsoi to nlevgrnd for deep soil
! 03/28/08, Mark Flanner: Changes to allow solar radiative absorption in all snow layers and top soil layer
! !LOCAL VARIABLES:
!
! local pointers to original implicit in arguments
!
integer , pointer :: pgridcell(:) ! pft's gridcell index
integer , pointer :: plandunit(:) ! pft's landunit index
integer , pointer :: clandunit(:) ! column's landunit
integer , pointer :: ltype(:) ! landunit type
integer , pointer :: ctype(:) ! column type
integer , pointer :: npfts(:) ! column's number of pfts
integer , pointer :: pfti(:) ! column's beginning pft index
real(r8), pointer :: pwtcol(:) ! weight of pft relative to column
real(r8), pointer :: pwtgcell(:) ! weight of pft relative to corresponding gridcell
real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2)
integer , pointer :: snl(:) ! number of snow layers
real(r8), pointer :: htvp(:) ! latent heat of vapor of water (or sublimation) [j/kg]
real(r8), pointer :: emg(:) ! ground emissivity
real(r8), pointer :: cgrnd(:) ! deriv. of soil energy flux wrt to soil temp [w/m2/k]
real(r8), pointer :: dlrad(:) ! downward longwave radiation blow the canopy [W/m2]
real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2)
integer , pointer :: frac_veg_nosno(:) ! fraction of vegetation not covered by snow (0 OR 1 now) [-] (new)
real(r8), pointer :: eflx_sh_grnd(:) ! sensible heat flux from ground (W/m**2) [+ to atm]
real(r8), pointer :: qflx_evap_soi(:) ! soil evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_tran_veg(:) ! vegetation transpiration (mm H2O/s) (+ = to atm)
real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m)
real(r8), pointer :: dz(:,:) ! layer depth (m)
real(r8), pointer :: z(:,:) ! layer thickness (m)
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin)
real(r8), pointer :: eflx_lwrad_net(:) ! net infrared (longwave) rad (W/m**2) [+ = to atm]
real(r8), pointer :: tssbef(:,:) ! temperature at previous time step [K]
real(r8), pointer :: t_building(:) ! internal building temperature (K)
real(r8), pointer :: t_building_max(:) ! maximum internal building temperature (K)
real(r8), pointer :: t_building_min(:) ! minimum internal building temperature (K)
real(r8), pointer :: hc_soi(:) ! soil heat content (MJ/m2)
real(r8), pointer :: hc_soisno(:) ! soil plus snow plus lake heat content (MJ/m2)
real(r8), pointer :: eflx_fgr12(:) ! heat flux between soil layer 1 and 2 (W/m2)
real(r8), pointer :: eflx_traffic(:) ! traffic sensible heat flux (W/m**2)
real(r8), pointer :: eflx_wasteheat(:) ! sensible heat flux from urban heating/cooling sources of waste heat (W/m**2)
real(r8), pointer :: eflx_wasteheat_pft(:) ! sensible heat flux from urban heating/cooling sources of waste heat (W/m**2)
real(r8), pointer :: eflx_heat_from_ac(:) !sensible heat flux put back into canyon due to removal by AC (W/m**2)
real(r8), pointer :: eflx_heat_from_ac_pft(:) !sensible heat flux put back into canyon due to removal by AC (W/m**2)
real(r8), pointer :: eflx_traffic_pft(:) ! traffic sensible heat flux (W/m**2)
real(r8), pointer :: eflx_anthro(:) ! total anthropogenic heat flux (W/m**2)
real(r8), pointer :: canyon_hwr(:) ! urban canyon height to width ratio
real(r8), pointer :: wtlunit_roof(:) ! weight of roof with respect to landunit
!
! local pointers to original implicit inout arguments
!
real(r8), pointer :: t_grnd(:) ! ground surface temperature [K]
!
! local pointers to original implicit out arguments
!
real(r8), pointer :: eflx_gnet(:) ! net ground heat flux into the surface (W/m**2)
real(r8), pointer :: dgnetdT(:) ! temperature derivative of ground net heat flux
real(r8), pointer :: eflx_building_heat(:) ! heat flux from urban building interior to walls, roof (W/m**2)
! variables needed for SNICAR
real(r8), pointer :: sabg_lyr(:,:) ! absorbed solar radiation (pft,lyr) [W/m2]
real(r8), pointer :: h2osno(:) ! total snow water (col) [kg/m2]
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (col,lyr) [kg/m2]
real(r8), pointer :: h2osoi_ice(:,:) ! ice content (col,lyr) [kg/m2]
! Urban building HAC fluxes
real(r8), pointer :: eflx_urban_ac(:) ! urban air conditioning flux (W/m**2)
real(r8), pointer :: eflx_urban_heat(:) ! urban heating flux (W/m**2)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: j,c,p,l,g,pi ! indices
integer :: fc ! lake filtered column indices
integer :: fl ! urban filtered landunit indices
integer :: jtop(lbc:ubc) ! top level at each column
real(r8) :: at (lbc:ubc,-nlevsno+1:nlevgrnd) ! "a" vector for tridiagonal matrix
real(r8) :: bt (lbc:ubc,-nlevsno+1:nlevgrnd) ! "b" vector for tridiagonal matrix
real(r8) :: ct (lbc:ubc,-nlevsno+1:nlevgrnd) ! "c" vector for tridiagonal matrix
real(r8) :: rt (lbc:ubc,-nlevsno+1:nlevgrnd) ! "r" vector for tridiagonal solution
real(r8) :: cv (lbc:ubc,-nlevsno+1:nlevgrnd) ! heat capacity [J/(m2 K)]
real(r8) :: tk (lbc:ubc,-nlevsno+1:nlevgrnd) ! thermal conductivity [W/(m K)]
real(r8) :: fn (lbc:ubc,-nlevsno+1:nlevgrnd) ! heat diffusion through the layer interface [W/m2]
real(r8) :: fn1(lbc:ubc,-nlevsno+1:nlevgrnd) ! heat diffusion through the layer interface [W/m2]
real(r8) :: brr(lbc:ubc,-nlevsno+1:nlevgrnd) ! temporary
real(r8) :: dzm ! used in computing tridiagonal matrix
real(r8) :: dzp ! used in computing tridiagonal matrix
real(r8) :: hs(lbc:ubc) ! net energy flux into the surface (w/m2)
real(r8) :: dhsdT(lbc:ubc) ! d(hs)/dT
real(r8) :: lwrad_emit(lbc:ubc) ! emitted longwave radiation
real(r8) :: dlwrad_emit(lbc:ubc) ! time derivative of emitted longwave radiation
integer :: lyr_top ! index of top layer of snowpack (-4 to 0) [idx]
real(r8) :: sabg_lyr_col(lbc:ubc,-nlevsno+1:1) ! absorbed solar radiation (col,lyr) [W/m2]
real(r8) :: eflx_gnet_top ! net energy flux into surface layer, pft-level [W/m2]
real(r8) :: hs_top(lbc:ubc) ! net energy flux into surface layer (col) [W/m2]
logical :: cool_on(lbl:ubl) ! is urban air conditioning on?
logical :: heat_on(lbl:ubl) ! is urban heating on?
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (gridcell-level)
forc_lwrad => clm_a2l%forc_lwrad
! Assign local pointers to derived subtypes components (landunit-level)
ltype => clm3%g%l%itype
t_building => clm3%g%l%lps%t_building
t_building_max => clm3%g%l%lps%t_building_max
t_building_min => clm3%g%l%lps%t_building_min
eflx_traffic => clm3%g%l%lef%eflx_traffic
canyon_hwr => clm3%g%l%canyon_hwr
eflx_wasteheat => clm3%g%l%lef%eflx_wasteheat
eflx_heat_from_ac => clm3%g%l%lef%eflx_heat_from_ac
wtlunit_roof => clm3%g%l%wtlunit_roof
! Assign local pointers to derived subtypes components (column-level)
ctype => clm3%g%l%c%itype
clandunit => clm3%g%l%c%landunit
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
snl => clm3%g%l%c%cps%snl
htvp => clm3%g%l%c%cps%htvp
emg => clm3%g%l%c%cps%emg
t_grnd => clm3%g%l%c%ces%t_grnd
hc_soi => clm3%g%l%c%ces%hc_soi
hc_soisno => clm3%g%l%c%ces%hc_soisno
eflx_fgr12 => clm3%g%l%c%cef%eflx_fgr12
zi => clm3%g%l%c%cps%zi
dz => clm3%g%l%c%cps%dz
z => clm3%g%l%c%cps%z
t_soisno => clm3%g%l%c%ces%t_soisno
eflx_building_heat => clm3%g%l%c%cef%eflx_building_heat
tssbef => clm3%g%l%c%ces%tssbef
eflx_urban_ac => clm3%g%l%c%cef%eflx_urban_ac
eflx_urban_heat => clm3%g%l%c%cef%eflx_urban_heat
! Assign local pointers to derived subtypes components (pft-level)
pgridcell => clm3%g%l%c%p%gridcell
plandunit => clm3%g%l%c%p%landunit
pwtcol => clm3%g%l%c%p%wtcol
pwtgcell => clm3%g%l%c%p%wtgcell
frac_veg_nosno => clm3%g%l%c%p%pps%frac_veg_nosno
cgrnd => clm3%g%l%c%p%pef%cgrnd
dlrad => clm3%g%l%c%p%pef%dlrad
sabg => clm3%g%l%c%p%pef%sabg
eflx_sh_grnd => clm3%g%l%c%p%pef%eflx_sh_grnd
qflx_evap_soi => clm3%g%l%c%p%pwf%qflx_evap_soi
qflx_tran_veg => clm3%g%l%c%p%pwf%qflx_tran_veg
eflx_gnet => clm3%g%l%c%p%pef%eflx_gnet
dgnetdT => clm3%g%l%c%p%pef%dgnetdT
eflx_lwrad_net => clm3%g%l%c%p%pef%eflx_lwrad_net
eflx_wasteheat_pft => clm3%g%l%c%p%pef%eflx_wasteheat_pft
eflx_heat_from_ac_pft => clm3%g%l%c%p%pef%eflx_heat_from_ac_pft
eflx_traffic_pft => clm3%g%l%c%p%pef%eflx_traffic_pft
eflx_anthro => clm3%g%l%c%p%pef%eflx_anthro
sabg_lyr => clm3%g%l%c%p%pef%sabg_lyr
h2osno => clm3%g%l%c%cws%h2osno
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
! Compute ground surface and soil temperatures
! Thermal conductivity and Heat capacity
call SoilThermProp(lbc, ubc, num_nolakec, filter_nolakec, tk, cv)
! Net ground heat flux into the surface and its temperature derivative
! Added a pfts loop here to get the average of hs and dhsdT over
! all PFTs on the column. Precalculate the terms that do not depend on PFT.
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
lwrad_emit(c) = emg(c) * sb * t_grnd(c)**4
dlwrad_emit(c) = 4._r8*emg(c) * sb * t_grnd(c)**3
end do
hs(lbc:ubc) = 0._r8
dhsdT(lbc:ubc) = 0._r8
do pi = 1,max_pft_per_col
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
if ( pi <= npfts(c) ) then
p = pfti(c) + pi - 1
l = plandunit(p)
g = pgridcell(p)
if (pwtgcell(p)>0._r8) then
if (ltype(l) /= isturb) then
eflx_gnet(p) = sabg(p) + dlrad(p) &
+ (1-frac_veg_nosno(p))*emg(c)*forc_lwrad(g) - lwrad_emit(c) &
- (eflx_sh_grnd(p)+qflx_evap_soi(p)*htvp(c))
else
! For urban columns we use the net longwave radiation (eflx_lwrad_net) because of
! interactions between urban columns.
! All wasteheat and traffic flux goes into canyon floor
if (ctype(c) == icol_road_perv .or. ctype(c) == icol_road_imperv) then
eflx_wasteheat_pft(p) = eflx_wasteheat(l)/(1._r8-wtlunit_roof(l))
eflx_heat_from_ac_pft(p) = eflx_heat_from_ac(l)/(1._r8-wtlunit_roof(l))
eflx_traffic_pft(p) = eflx_traffic(l)/(1._r8-wtlunit_roof(l))
else
eflx_wasteheat_pft(p) = 0._r8
eflx_heat_from_ac_pft(p) = 0._r8
eflx_traffic_pft(p) = 0._r8
end if
! Include transpiration term because needed for pervious road
! and include wasteheat and traffic flux
eflx_gnet(p) = sabg(p) + dlrad(p) &
- eflx_lwrad_net(p) &
- (eflx_sh_grnd(p) + qflx_evap_soi(p)*htvp(c) + qflx_tran_veg(p)*hvap) &
+ eflx_wasteheat_pft(p) + eflx_heat_from_ac_pft(p) + eflx_traffic_pft(p)
eflx_anthro(p) = eflx_wasteheat_pft(p) + eflx_traffic_pft(p)
end if
dgnetdT(p) = - cgrnd(p) - dlwrad_emit(c)
hs(c) = hs(c) + eflx_gnet(p) * pwtcol(p)
dhsdT(c) = dhsdT(c) + dgnetdT(p) * pwtcol(p)
end if
end if
end do
end do
! Additional calculations with SNICAR:
! Set up tridiagonal matrix in a new manner. There is now
! absorbed solar radiation in each snow layer, instead of
! only the surface. Following the current implementation,
! absorbed solar flux should be: S + ((delS/delT)*dT),
! where S is absorbed radiation, and T is temperature. Now,
! assume delS/delT is zero, then it is OK to just add S
! to each layer
! Initialize:
sabg_lyr_col(lbc:ubc,-nlevsno+1:1) = 0._r8
hs_top(lbc:ubc) = 0._r8
do pi = 1,max_pft_per_col
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
lyr_top = snl(c) + 1
if ( pi <= npfts(c) ) then
p = pfti(c) + pi - 1
l = plandunit(p)
if (pwtgcell(p)>0._r8) then
g = pgridcell(p)
if (ltype(l) /= isturb )then
eflx_gnet_top = sabg_lyr(p,lyr_top) + dlrad(p) + (1-frac_veg_nosno(p))*emg(c)*forc_lwrad(g) &
- lwrad_emit(c) - (eflx_sh_grnd(p)+qflx_evap_soi(p)*htvp(c))
hs_top(c) = hs_top(c) + eflx_gnet_top*pwtcol(p)
do j = lyr_top,1,1
sabg_lyr_col(c,j) = sabg_lyr_col(c,j) + sabg_lyr(p,j) * pwtcol(p)
enddo
else
hs_top(c) = hs_top(c) + eflx_gnet(p)*pwtcol(p)
sabg_lyr_col(c,lyr_top) = sabg_lyr_col(c,lyr_top) + sabg(p) * pwtcol(p)
endif
endif
endif
enddo
enddo
! Restrict internal building temperature to between min and max
! and determine if heating or air conditioning is on
do fl = 1,num_urbanl
l = filter_urbanl(fl)
if (ltype(l) == isturb) then
cool_on(l) = .false.
heat_on(l) = .false.
if (t_building(l) > t_building_max(l)) then
t_building(l) = t_building_max(l)
cool_on(l) = .true.
heat_on(l) = .false.
else if (t_building(l) < t_building_min(l)) then
t_building(l) = t_building_min(l)
cool_on(l) = .false.
heat_on(l) = .true.
end if
end if
end do
! Determine heat diffusion through the layer interface and factor used in computing
! tridiagonal matrix and set up vector r and vectors a, b, c that define tridiagonal
! matrix and solve system
do j = -nlevsno+1,nlevgrnd
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (j >= snl(c)+1) then
if (j == snl(c)+1) then
if (ctype(c)==icol_sunwall .or. ctype(c)==icol_shadewall .or. ctype(c)==icol_roof) then
fact(c,j) = dtime/cv(c,j)
else
fact(c,j) = dtime/cv(c,j) * dz(c,j) / (0.5_r8*(z(c,j)-zi(c,j-1)+capr*(z(c,j+1)-zi(c,j-1))))
end if
fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j))
else if (j <= nlevgrnd-1) then
fact(c,j) = dtime/cv(c,j)
fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j))
dzm = (z(c,j)-z(c,j-1))
else if (j == nlevgrnd) then
fact(c,j) = dtime/cv(c,j)
! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across
! the bottom "soil" layer and the equations are derived assuming a prescribed internal
! building temperature. (See Oleson urban notes of 6/18/03).
if (ctype(c)==icol_sunwall .or. ctype(c)==icol_shadewall .or. ctype(c)==icol_roof) then
fn(c,j) = tk(c,j) * (t_building(l) - cnfac*t_soisno(c,j))/(zi(c,j) - z(c,j))
else
fn(c,j) = 0._r8
end if
end if
end if
enddo
end do
do j = -nlevsno+1,nlevgrnd
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (j >= snl(c)+1) then
if (j == snl(c)+1) then
dzp = z(c,j+1)-z(c,j)
at(c,j) = 0._r8
bt(c,j) = 1+(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp-fact(c,j)*dhsdT(c)
ct(c,j) = -(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp
! changed hs to hs_top
rt(c,j) = t_soisno(c,j) + fact(c,j)*( hs_top(c) - dhsdT(c)*t_soisno(c,j) + cnfac*fn(c,j) )
else if (j <= nlevgrnd-1) then
dzm = (z(c,j)-z(c,j-1))
dzp = (z(c,j+1)-z(c,j))
at(c,j) = - (1._r8-cnfac)*fact(c,j)* tk(c,j-1)/dzm
bt(c,j) = 1._r8+ (1._r8-cnfac)*fact(c,j)*(tk(c,j)/dzp + tk(c,j-1)/dzm)
ct(c,j) = - (1._r8-cnfac)*fact(c,j)* tk(c,j)/dzp
! if this is a snow layer or the top soil layer,
! add absorbed solar flux to factor 'rt'
if (j <= 1) then
rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) + (fact(c,j)*sabg_lyr_col(c,j))
else
rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) )
endif
else if (j == nlevgrnd) then
! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across
! the bottom "soil" layer and the equations are derived assuming a prescribed internal
! building temperature. (See Oleson urban notes of 6/18/03).
if (ctype(c)==icol_sunwall .or. ctype(c)==icol_shadewall .or. ctype(c)==icol_roof) then
dzm = ( z(c,j)-z(c,j-1))
dzp = (zi(c,j)-z(c,j))
at(c,j) = - (1._r8-cnfac)*fact(c,j)*(tk(c,j-1)/dzm)
bt(c,j) = 1._r8+ (1._r8-cnfac)*fact(c,j)*(tk(c,j-1)/dzm + tk(c,j)/dzp)
ct(c,j) = 0._r8
rt(c,j) = t_soisno(c,j) + fact(c,j)*( fn(c,j) - cnfac*fn(c,j-1) )
else
dzm = (z(c,j)-z(c,j-1))
at(c,j) = - (1._r8-cnfac)*fact(c,j)*tk(c,j-1)/dzm
bt(c,j) = 1._r8+ (1._r8-cnfac)*fact(c,j)*tk(c,j-1)/dzm
ct(c,j) = 0._r8
rt(c,j) = t_soisno(c,j) - cnfac*fact(c,j)*fn(c,j-1)
end if
end if
end if
enddo
end do
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
jtop(c) = snl(c) + 1
end do
call Tridiagonal(lbc, ubc, -nlevsno+1, nlevgrnd, jtop, num_nolakec, filter_nolakec, &
at, bt, ct, rt, t_soisno(lbc:ubc,-nlevsno+1:nlevgrnd))
! Melting or Freezing
do j = -nlevsno+1,nlevgrnd
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (j >= snl(c)+1) then
if (j <= nlevgrnd-1) then
fn1(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j))
else if (j == nlevgrnd) then
! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across
! the bottom "soil" layer and the equations are derived assuming a prescribed internal
! building temperature. (See Oleson urban notes of 6/18/03).
! Note new formulation for fn, this will be used below in brr computation
if (ctype(c)==icol_sunwall .or. ctype(c)==icol_shadewall .or. ctype(c)==icol_roof) then
fn1(c,j) = tk(c,j) * (t_building(l) - t_soisno(c,j))/(zi(c,j) - z(c,j))
fn(c,j) = tk(c,j) * (t_building(l) - tssbef(c,j))/(zi(c,j) - z(c,j))
else
fn1(c,j) = 0._r8
end if
end if
end if
end do
end do
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (ltype(l) == isturb) then
eflx_building_heat(c) = cnfac*fn(c,nlevurb) + (1-cnfac)*fn1(c,nlevurb)
if (cool_on(l)) then
eflx_urban_ac(c) = abs(eflx_building_heat(c))
eflx_urban_heat(c) = 0._r8
else if (heat_on(l)) then
eflx_urban_ac(c) = 0._r8
eflx_urban_heat(c) = abs(eflx_building_heat(c))
else
eflx_urban_ac(c) = 0._r8
eflx_urban_heat(c) = 0._r8
end if
end if
end do
do j = -nlevsno+1,nlevgrnd
!dir$ prefervector
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (j >= snl(c)+1) then
if (j == snl(c)+1) then
brr(c,j) = cnfac*fn(c,j) + (1._r8-cnfac)*fn1(c,j)
else
brr(c,j) = cnfac*(fn(c,j)-fn(c,j-1)) + (1._r8-cnfac)*(fn1(c,j)-fn1(c,j-1))
end if
end if
end do
end do
call PhaseChange (lbc, ubc, num_nolakec, filter_nolakec, fact, brr, hs, dhsdT, xmf, hs_top, sabg_lyr_col)
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
t_grnd(c) = t_soisno(c,snl(c)+1)
end do
! Initialize soil heat content
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (ltype(l) /= isturb) then
hc_soisno(c) = 0._r8
hc_soi(c) = 0._r8
end if
eflx_fgr12(c)= 0._r8
end do
! Calculate soil heat content and soil plus snow heat content
do j = -nlevsno+1,nlevgrnd
!dir$ prefervector
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
eflx_fgr12(c) = -cnfac*fn(c,1) - (1._r8-cnfac)*fn1(c,1)
if (ltype(l) /= isturb) then
if (j >= snl(c)+1) then
hc_soisno(c) = hc_soisno(c) + cv(c,j)*t_soisno(c,j) / 1.e6_r8
endif
if (j >= 1) then
hc_soi(c) = hc_soi(c) + cv(c,j)*t_soisno(c,j) / 1.e6_r8
end if
end if
end do
end do
end subroutine SoilTemperature
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SoilThermProp
!
! !INTERFACE:
subroutine SoilThermProp (lbc, ubc, num_nolakec, filter_nolakec, tk, cv) 1,4
!
! !DESCRIPTION:
! Calculation of thermal conductivities and heat capacities of
! snow/soil layers
! (1) The volumetric heat capacity is calculated as a linear combination
! in terms of the volumetric fraction of the constituent phases.
!
! (2) The thermal conductivity of soil is computed from the algorithm of
! Johansen (as reported by Farouki 1981), and of snow is from the
! formulation used in SNTHERM (Jordan 1991).
! The thermal conductivities at the interfaces between two neighboring
! layers (j, j+1) are derived from an assumption that the flux across
! the interface is equal to that from the node j to the interface and the
! flux from the interface to the node j+1.
!
! !USES:
use shr_kind_mod, only : r8 => shr_kind_r8
use clmtype
use clm_varcon , only : denh2o, denice, tfrz, tkwat, tkice, tkair, &
cpice, cpliq, istice, istwet, &
icol_roof, icol_sunwall, icol_shadewall, &
icol_road_perv, icol_road_imperv
use clm_varpar , only : nlevsno, nlevgrnd, nlevurb, nlevsoi
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! column bounds
integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer , intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
real(r8), intent(out) :: cv(lbc:ubc,-nlevsno+1:nlevgrnd)! heat capacity [J/(m2 K)]
real(r8), intent(out) :: tk(lbc:ubc,-nlevsno+1:nlevgrnd)! thermal conductivity [W/(m K)]
!
! !CALLED FROM:
! subroutine SoilTemperature in this module
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 2/13/02, Peter Thornton: migrated to new data structures
! 7/01/03, Mariana Vertenstein: migrated to vector code
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in scalars
!
integer , pointer :: ctype(:) ! column type
integer , pointer :: clandunit(:) ! column's landunit
integer , pointer :: ltype(:) ! landunit type
integer , pointer :: snl(:) ! number of snow layers
real(r8), pointer :: h2osno(:) ! snow water (mm H2O)
!
! local pointers to original implicit in arrays
!
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity)
real(r8), pointer :: tksatu(:,:) ! thermal conductivity, saturated soil [W/m-K]
real(r8), pointer :: tkmg(:,:) ! thermal conductivity, soil minerals [W/m-K]
real(r8), pointer :: tkdry(:,:) ! thermal conductivity, dry soil (W/m/Kelvin)
real(r8), pointer :: csol(:,:) ! heat capacity, soil solids (J/m**3/Kelvin)
real(r8), pointer :: dz(:,:) ! layer depth (m)
real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m)
real(r8), pointer :: z(:,:) ! layer thickness (m)
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2)
real(r8), pointer :: tk_wall(:,:) ! thermal conductivity of urban wall
real(r8), pointer :: tk_roof(:,:) ! thermal conductivity of urban roof
real(r8), pointer :: tk_improad(:,:) ! thermal conductivity of urban impervious road
real(r8), pointer :: cv_wall(:,:) ! thermal conductivity of urban wall
real(r8), pointer :: cv_roof(:,:) ! thermal conductivity of urban roof
real(r8), pointer :: cv_improad(:,:) ! thermal conductivity of urban impervious road
integer, pointer :: nlev_improad(:) ! number of impervious road layers
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: l,c,j ! indices
integer :: fc ! lake filtered column indices
real(r8) :: bw ! partial density of water (ice + liquid)
real(r8) :: dksat ! thermal conductivity for saturated soil (j/(k s m))
real(r8) :: dke ! kersten number
real(r8) :: fl ! fraction of liquid or unfrozen water to total water
real(r8) :: satw ! relative total water content of soil.
real(r8) :: thk(lbc:ubc,-nlevsno+1:nlevgrnd) ! thermal conductivity of layer
real(r8) :: thk_bedrock = 3.0_r8 ! thermal conductivity of 'typical' saturated granitic rock
! (Clauser and Huenges, 1995)(W/m/K)
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (landunit-level)
ltype => clm3%g%l%itype
! Assign local pointers to derived subtypes components (column-level)
ctype => clm3%g%l%c%itype
clandunit => clm3%g%l%c%landunit
snl => clm3%g%l%c%cps%snl
h2osno => clm3%g%l%c%cws%h2osno
watsat => clm3%g%l%c%cps%watsat
tksatu => clm3%g%l%c%cps%tksatu
tkmg => clm3%g%l%c%cps%tkmg
tkdry => clm3%g%l%c%cps%tkdry
csol => clm3%g%l%c%cps%csol
dz => clm3%g%l%c%cps%dz
zi => clm3%g%l%c%cps%zi
z => clm3%g%l%c%cps%z
t_soisno => clm3%g%l%c%ces%t_soisno
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
tk_wall => clm3%g%l%lps%tk_wall
tk_roof => clm3%g%l%lps%tk_roof
tk_improad => clm3%g%l%lps%tk_improad
cv_wall => clm3%g%l%lps%cv_wall
cv_roof => clm3%g%l%lps%cv_roof
cv_improad => clm3%g%l%lps%cv_improad
nlev_improad => clm3%g%l%lps%nlev_improad
! Thermal conductivity of soil from Farouki (1981)
! Urban values are from Masson et al. 2002, Evaluation of the Town Energy Balance (TEB)
! scheme with direct measurements from dry districts in two cities, J. Appl. Meteorol.,
! 41, 1011-1026.
do j = -nlevsno+1,nlevgrnd
!dir$ concurrent
!cdir nodep
do fc = 1, num_nolakec
c = filter_nolakec(fc)
! Only examine levels from 1->nlevgrnd
if (j >= 1) then
l = clandunit(c)
if (ctype(c) == icol_sunwall .OR. ctype(c) == icol_shadewall) then
thk(c,j) = tk_wall(l,j)
else if (ctype(c) == icol_roof) then
thk(c,j) = tk_roof(l,j)
else if (ctype(c) == icol_road_imperv .and. j >= 1 .and. j <= nlev_improad(l)) then
thk(c,j) = tk_improad(l,j)
else if (ltype(l) /= istwet .AND. ltype(l) /= istice) then
satw = (h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice)/(dz(c,j)*watsat(c,j))
satw = min(1._r8, satw)
if (satw > .1e-6_r8) then
fl = h2osoi_liq(c,j)/(h2osoi_ice(c,j)+h2osoi_liq(c,j))
if (t_soisno(c,j) >= tfrz) then ! Unfrozen soil
dke = max(0._r8, log10(satw) + 1.0_r8)
dksat = tksatu(c,j)
else ! Frozen soil
dke = satw
dksat = tkmg(c,j)*0.249_r8**(fl*watsat(c,j))*2.29_r8**watsat(c,j)
endif
thk(c,j) = dke*dksat + (1._r8-dke)*tkdry(c,j)
else
thk(c,j) = tkdry(c,j)
endif
if (j > nlevsoi) thk(c,j) = thk_bedrock
else if (ltype(l) == istice) then
thk(c,j) = tkwat
if (t_soisno(c,j) < tfrz) thk(c,j) = tkice
else if (ltype(l) == istwet) then
if (j > nlevsoi) then
thk(c,j) = thk_bedrock
else
thk(c,j) = tkwat
if (t_soisno(c,j) < tfrz) thk(c,j) = tkice
endif
endif
endif
! Thermal conductivity of snow, which from Jordan (1991) pp. 18
! Only examine levels from snl(c)+1 -> 0 where snl(c) < 1
if (snl(c)+1 < 1 .AND. (j >= snl(c)+1) .AND. (j <= 0)) then
bw = (h2osoi_ice(c,j)+h2osoi_liq(c,j))/dz(c,j)
thk(c,j) = tkair + (7.75e-5_r8 *bw + 1.105e-6_r8*bw*bw)*(tkice-tkair)
end if
end do
end do
! Thermal conductivity at the layer interface
do j = -nlevsno+1,nlevgrnd
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
if (j >= snl(c)+1 .AND. j <= nlevgrnd-1) then
tk(c,j) = thk(c,j)*thk(c,j+1)*(z(c,j+1)-z(c,j)) &
/(thk(c,j)*(z(c,j+1)-zi(c,j))+thk(c,j+1)*(zi(c,j)-z(c,j)))
else if (j == nlevgrnd) then
! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across
! the bottom "soil" layer and the equations are derived assuming a prescribed internal
! building temperature. (See Oleson urban notes of 6/18/03).
if (ctype(c)==icol_sunwall .OR. ctype(c)==icol_shadewall .OR. ctype(c)==icol_roof) then
tk(c,j) = thk(c,j)
else
tk(c,j) = 0._r8
end if
end if
end do
end do
! Soil heat capacity, from de Vires (1963)
! Urban values are from Masson et al. 2002, Evaluation of the Town Energy Balance (TEB)
! scheme with direct measurements from dry districts in two cities, J. Appl. Meteorol.,
! 41, 1011-1026.
do j = 1, nlevgrnd
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (ctype(c)==icol_sunwall .OR. ctype(c)==icol_shadewall) then
cv(c,j) = cv_wall(l,j) * dz(c,j)
else if (ctype(c) == icol_roof) then
cv(c,j) = cv_roof(l,j) * dz(c,j)
else if (ctype(c) == icol_road_imperv .and. j >= 1 .and. j <= nlev_improad(l)) then
cv(c,j) = cv_improad(l,j) * dz(c,j)
else if (ltype(l) /= istwet .AND. ltype(l) /= istice) then
cv(c,j) = csol(c,j)*(1-watsat(c,j))*dz(c,j) + (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq)
else if (ltype(l) == istwet) then
cv(c,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq)
if (j > nlevsoi) cv(c,j) = csol(c,j)*dz(c,j)
else if (ltype(l) == istice) then
cv(c,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq)
endif
if (j == 1) then
if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8) then
cv(c,j) = cv(c,j) + cpice*h2osno(c)
end if
end if
enddo
end do
! Snow heat capacity
do j = -nlevsno+1,0
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
if (snl(c)+1 < 1 .and. j >= snl(c)+1) then
cv(c,j) = cpliq*h2osoi_liq(c,j) + cpice*h2osoi_ice(c,j)
end if
end do
end do
end subroutine SoilThermProp
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: PhaseChange
!
! !INTERFACE:
subroutine PhaseChange (lbc, ubc, num_nolakec, filter_nolakec, fact, & 2,7
brr, hs, dhsdT, xmf, hs_top, sabg_lyr_col)
!
! !DESCRIPTION:
! Calculation of the phase change within snow and soil layers:
! (1) Check the conditions for which the phase change may take place,
! i.e., the layer temperature is great than the freezing point
! and the ice mass is not equal to zero (i.e. melting),
! or the layer temperature is less than the freezing point
! and the liquid water mass is greater than the allowable supercooled
! liquid water calculated from freezing point depression (i.e. freezing).
! (2) Assess the rate of phase change from the energy excess (or deficit)
! after setting the layer temperature to freezing point.
! (3) Re-adjust the ice and liquid mass, and the layer temperature
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use clm_varcon , only : tfrz, hfus, grav, istsoil, isturb, icol_road_perv
#ifdef CROP
use clm_varcon , only : istcrop
#endif
use clm_varpar , only : nlevsno, nlevgrnd
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! column bounds
integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer , intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
real(r8), intent(in) :: brr (lbc:ubc, -nlevsno+1:nlevgrnd) ! temporary
real(r8), intent(in) :: fact (lbc:ubc, -nlevsno+1:nlevgrnd) ! temporary
real(r8), intent(in) :: hs (lbc:ubc) ! net ground heat flux into the surface
real(r8), intent(in) :: dhsdT (lbc:ubc) ! temperature derivative of "hs"
real(r8), intent(out):: xmf (lbc:ubc) ! total latent heat of phase change
real(r8), intent(in) :: hs_top(lbc:ubc) ! net heat flux into the top snow layer [W/m2]
real(r8), intent(in) :: sabg_lyr_col(lbc:ubc,-nlevsno+1:1) ! absorbed solar radiation (col,lyr) [W/m2]
!
! !CALLED FROM:
! subroutine SoilTemperature in this module
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 2/14/02, Peter Thornton: Migrated to new data structures.
! 7/01/03, Mariana Vertenstein: Migrated to vector code
! 04/25/07 Keith Oleson: CLM3.5 Hydrology
! 03/28/08 Mark Flanner: accept new arguments and calculate freezing rate of h2o in snow
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in scalars
!
integer , pointer :: snl(:) !number of snow layers
real(r8), pointer :: h2osno(:) !snow water (mm H2O)
integer , pointer :: ltype(:) !landunit type
integer , pointer :: clandunit(:) !column's landunit
integer , pointer :: ctype(:) !column type
!
! local pointers to original implicit inout scalars
!
real(r8), pointer :: snowdp(:) !snow height (m)
!
! local pointers to original implicit out scalars
!
real(r8), pointer :: qflx_snomelt(:) !snow melt (mm H2O /s)
real(r8), pointer :: eflx_snomelt(:) !snow melt heat flux (W/m**2)
real(r8), pointer :: eflx_snomelt_u(:)!urban snow melt heat flux (W/m**2)
real(r8), pointer :: eflx_snomelt_r(:)!rural snow melt heat flux (W/m**2)
real(r8), pointer :: qflx_snofrz_lyr(:,:) !snow freezing rate (positive definite) (col,lyr) [kg m-2 s-1]
!
! local pointers to original implicit in arrays
!
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2) (new)
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2) (new)
real(r8), pointer :: tssbef(:,:) !temperature at previous time step [K]
real(r8), pointer :: sucsat(:,:) !minimum soil suction (mm)
real(r8), pointer :: watsat(:,:) !volumetric soil water at saturation (porosity)
real(r8), pointer :: bsw(:,:) !Clapp and Hornberger "b"
real(r8), pointer :: dz(:,:) !layer thickness (m)
!
! local pointers to original implicit inout arrays
!
real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin)
!
! local pointers to original implicit out arrays
!
integer, pointer :: imelt(:,:) !flag for melting (=1), freezing (=2), Not=0 (new)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: j,c,g,l !do loop index
integer :: fc !lake filtered column indices
real(r8) :: heatr !energy residual or loss after melting or freezing
real(r8) :: temp1 !temporary variables [kg/m2]
real(r8) :: hm(lbc:ubc,-nlevsno+1:nlevgrnd) !energy residual [W/m2]
real(r8) :: xm(lbc:ubc,-nlevsno+1:nlevgrnd) !melting or freezing within a time step [kg/m2]
real(r8) :: wmass0(lbc:ubc,-nlevsno+1:nlevgrnd)!initial mass of ice and liquid (kg/m2)
real(r8) :: wice0 (lbc:ubc,-nlevsno+1:nlevgrnd)!initial mass of ice (kg/m2)
real(r8) :: wliq0 (lbc:ubc,-nlevsno+1:nlevgrnd)!initial mass of liquid (kg/m2)
real(r8) :: supercool(lbc:ubc,nlevgrnd) !supercooled water in soil (kg/m2)
real(r8) :: propor !proportionality constant (-)
real(r8) :: tinc !t(n+1)-t(n) (K)
real(r8) :: smp !frozen water potential (mm)
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (column-level)
snl => clm3%g%l%c%cps%snl
h2osno => clm3%g%l%c%cws%h2osno
snowdp => clm3%g%l%c%cps%snowdp
qflx_snomelt => clm3%g%l%c%cwf%qflx_snomelt
eflx_snomelt => clm3%g%l%c%cef%eflx_snomelt
eflx_snomelt_u => clm3%g%l%c%cef%eflx_snomelt_u
eflx_snomelt_r => clm3%g%l%c%cef%eflx_snomelt_r
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
imelt => clm3%g%l%c%cps%imelt
t_soisno => clm3%g%l%c%ces%t_soisno
tssbef => clm3%g%l%c%ces%tssbef
bsw => clm3%g%l%c%cps%bsw
sucsat => clm3%g%l%c%cps%sucsat
watsat => clm3%g%l%c%cps%watsat
dz => clm3%g%l%c%cps%dz
ctype => clm3%g%l%c%itype
clandunit => clm3%g%l%c%landunit
ltype => clm3%g%l%itype
qflx_snofrz_lyr => clm3%g%l%c%cwf%qflx_snofrz_lyr
! Initialization
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
qflx_snomelt(c) = 0._r8
xmf(c) = 0._r8
qflx_snofrz_lyr(c,-nlevsno+1:0) = 0._r8
end do
do j = -nlevsno+1,nlevgrnd ! all layers
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
if (j >= snl(c)+1) then
! Initialization
imelt(c,j) = 0
hm(c,j) = 0._r8
xm(c,j) = 0._r8
wice0(c,j) = h2osoi_ice(c,j)
wliq0(c,j) = h2osoi_liq(c,j)
wmass0(c,j) = h2osoi_ice(c,j) + h2osoi_liq(c,j)
endif ! end of snow layer if-block
end do ! end of column-loop
enddo ! end of level-loop
do j = -nlevsno+1,0 ! snow layers
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
if (j >= snl(c)+1) then
! Melting identification
! If ice exists above melt point, melt some to liquid.
if (h2osoi_ice(c,j) > 0._r8 .AND. t_soisno(c,j) > tfrz) then
imelt(c,j) = 1
t_soisno(c,j) = tfrz
endif
! Freezing identification
! If liquid exists below melt point, freeze some to ice.
if (h2osoi_liq(c,j) > 0._r8 .AND. t_soisno(c,j) < tfrz) then
imelt(c,j) = 2
t_soisno(c,j) = tfrz
endif
endif ! end of snow layer if-block
end do ! end of column-loop
enddo ! end of level-loop
do j = 1,nlevgrnd ! soil layers
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (h2osoi_ice(c,j) > 0. .AND. t_soisno(c,j) > tfrz) then
imelt(c,j) = 1
t_soisno(c,j) = tfrz
endif
! from Zhao (1997) and Koren (1999)
supercool(c,j) = 0.0_r8
#ifndef CROP
if (ltype(l) == istsoil .or. ctype(c) == icol_road_perv) then
#else
if (ltype(l) == istsoil .or. ltype(l) == istcrop .or. ctype(c) == icol_road_perv) then
#endif
if(t_soisno(c,j) < tfrz) then
smp = hfus*(tfrz-t_soisno(c,j))/(grav*t_soisno(c,j)) * 1000._r8 !(mm)
supercool(c,j) = watsat(c,j)*(smp/sucsat(c,j))**(-1._r8/bsw(c,j))
supercool(c,j) = supercool(c,j)*dz(c,j)*1000._r8 ! (mm)
endif
endif
if (h2osoi_liq(c,j) > supercool(c,j) .AND. t_soisno(c,j) < tfrz) then
imelt(c,j) = 2
t_soisno(c,j) = tfrz
endif
! If snow exists, but its thickness is less than the critical value (0.01 m)
if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8 .AND. j == 1) then
if (t_soisno(c,j) > tfrz) then
imelt(c,j) = 1
t_soisno(c,j) = tfrz
endif
endif
end do
enddo
do j = -nlevsno+1,nlevgrnd ! all layers
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
if (j >= snl(c)+1) then
! Calculate the energy surplus and loss for melting and freezing
if (imelt(c,j) > 0) then
tinc = t_soisno(c,j)-tssbef(c,j)
! added unique cases for this calculation,
! to account for absorbed solar radiation in each layer
if (j == snl(c)+1) then
! top layer
hm(c,j) = hs_top(c) + dhsdT(c)*tinc + brr(c,j) - tinc/fact(c,j)
elseif (j <= 1) then
! snow layer or top soil layer (where sabg_lyr_col is defined)
hm(c,j) = brr(c,j) - tinc/fact(c,j) + sabg_lyr_col(c,j)
else
! soil layer
hm(c,j) = brr(c,j) - tinc/fact(c,j)
endif
endif
! These two errors were checked carefully (Y. Dai). They result from the
! computed error of "Tridiagonal-Matrix" in subroutine "thermal".
if (imelt(c,j) == 1 .AND. hm(c,j) < 0._r8) then
hm(c,j) = 0._r8
imelt(c,j) = 0
endif
if (imelt(c,j) == 2 .AND. hm(c,j) > 0._r8) then
hm(c,j) = 0._r8
imelt(c,j) = 0
endif
! The rate of melting and freezing
if (imelt(c,j) > 0 .and. abs(hm(c,j)) > 0._r8) then
xm(c,j) = hm(c,j)*dtime/hfus ! kg/m2
! If snow exists, but its thickness is less than the critical value
! (1 cm). Note: more work is needed to determine how to tune the
! snow depth for this case
if (j == 1) then
if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8 .AND. xm(c,j) > 0._r8) then
temp1 = h2osno(c) ! kg/m2
h2osno(c) = max(0._r8,temp1-xm(c,j))
propor = h2osno(c)/temp1
snowdp(c) = propor * snowdp(c)
heatr = hm(c,j) - hfus*(temp1-h2osno(c))/dtime ! W/m2
if (heatr > 0._r8) then
xm(c,j) = heatr*dtime/hfus ! kg/m2
hm(c,j) = heatr ! W/m2
else
xm(c,j) = 0._r8
hm(c,j) = 0._r8
endif
qflx_snomelt(c) = max(0._r8,(temp1-h2osno(c)))/dtime ! kg/(m2 s)
xmf(c) = hfus*qflx_snomelt(c)
endif
endif
heatr = 0._r8
if (xm(c,j) > 0._r8) then
h2osoi_ice(c,j) = max(0._r8, wice0(c,j)-xm(c,j))
heatr = hm(c,j) - hfus*(wice0(c,j)-h2osoi_ice(c,j))/dtime
else if (xm(c,j) < 0._r8) then
if (j <= 0) then
h2osoi_ice(c,j) = min(wmass0(c,j), wice0(c,j)-xm(c,j)) ! snow
else
if (wmass0(c,j) < supercool(c,j)) then
h2osoi_ice(c,j) = 0._r8
else
h2osoi_ice(c,j) = min(wmass0(c,j) - supercool(c,j),wice0(c,j)-xm(c,j))
endif
endif
heatr = hm(c,j) - hfus*(wice0(c,j)-h2osoi_ice(c,j))/dtime
endif
h2osoi_liq(c,j) = max(0._r8,wmass0(c,j)-h2osoi_ice(c,j))
if (abs(heatr) > 0._r8) then
if (j > snl(c)+1) then
t_soisno(c,j) = t_soisno(c,j) + fact(c,j)*heatr
else
t_soisno(c,j) = t_soisno(c,j) + fact(c,j)*heatr/(1._r8-fact(c,j)*dhsdT(c))
endif
if (j <= 0) then ! snow
if (h2osoi_liq(c,j)*h2osoi_ice(c,j)>0._r8) t_soisno(c,j) = tfrz
end if
endif
xmf(c) = xmf(c) + hfus * (wice0(c,j)-h2osoi_ice(c,j))/dtime
if (imelt(c,j) == 1 .AND. j < 1) then
qflx_snomelt(c) = qflx_snomelt(c) + max(0._r8,(wice0(c,j)-h2osoi_ice(c,j)))/dtime
endif
! layer freezing mass flux (positive):
if (imelt(c,j) == 2 .AND. j < 1) then
qflx_snofrz_lyr(c,j) = max(0._r8,(h2osoi_ice(c,j)-wice0(c,j)))/dtime
endif
endif
endif ! end of snow layer if-block
end do ! end of column-loop
enddo ! end of level-loop
! Needed for history file output
!dir$ concurrent
!cdir nodep
do fc = 1,num_nolakec
c = filter_nolakec(fc)
eflx_snomelt(c) = qflx_snomelt(c) * hfus
l = clandunit(c)
if (ltype(l) == isturb) then
eflx_snomelt_u(c) = eflx_snomelt(c)
#ifndef CROP
else if (ltype(l) == istsoil) then
#else
else if (ltype(l) == istsoil .or. ltype(l) == istcrop) then
#endif
eflx_snomelt_r(c) = eflx_snomelt(c)
end if
end do
end subroutine PhaseChange
end module SoilTemperatureMod
module SoilHydrologyMod 1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: SoilHydrologyMod
!
! !DESCRIPTION:
! Calculate soil hydrology
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: SurfaceRunoff ! Calculate surface runoff
public :: Infiltration ! Calculate infiltration into surface soil layer
public :: SoilWater ! Calculate soil hydrology
public :: Drainage ! Calculate subsurface drainage
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! 04/25/07 Keith Oleson: CLM3.5 hydrology
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SurfaceRunoff
!
! !INTERFACE:
subroutine SurfaceRunoff (lbc, ubc, lbp, ubp, num_hydrologyc, filter_hydrologyc, & 1,5
num_urbanc, filter_urbanc, vol_liq, icefrac)
!
! !DESCRIPTION:
! Calculate surface runoff
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use clm_varcon , only : denice, denh2o, wimp, pondmx_urban, &
icol_roof, icol_sunwall, icol_shadewall, &
icol_road_imperv, icol_road_perv
use clm_varpar , only : nlevsoi, maxpatch_pft
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! column bounds
integer , intent(in) :: lbp, ubp ! pft bounds
integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter
integer , intent(in) :: filter_hydrologyc(ubc-lbc+1) ! column filter for soil points
integer , intent(in) :: num_urbanc ! number of column urban points in column filter
integer , intent(in) :: filter_urbanc(ubc-lbc+1) ! column filter for urban points
real(r8), intent(out) :: vol_liq(lbc:ubc,1:nlevsoi) ! partial volume of liquid water in layer
real(r8), intent(out) :: icefrac(lbc:ubc,1:nlevsoi) ! fraction of ice in layer (-)
!
! !CALLED FROM:
! subroutine Hydrology2 in module Hydrology2Mod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 12 November 1999: Z.-L. Yang and G.-Y. Niu
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 2/26/02, Peter Thornton: Migrated to new data structures.
! 4/26/05, David Lawrence: Made surface runoff for dry soils a function
! of rooting fraction in top three soil layers.
! 04/25/07 Keith Oleson: Completely new routine for CLM3.5 hydrology
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in arguments
!
integer , pointer :: cgridcell(:) ! gridcell index for each column
integer , pointer :: ctype(:) ! column type index
real(r8), pointer :: qflx_top_soil(:) !net water input into soil from top (mm/s)
real(r8), pointer :: watsat(:,:) !volumetric soil water at saturation (porosity)
real(r8), pointer :: hkdepth(:) !decay factor (m)
real(r8), pointer :: zwt(:) !water table depth (m)
real(r8), pointer :: fcov(:) !fractional impermeable area
real(r8), pointer :: fsat(:) !fractional area with water table at surface
real(r8), pointer :: dz(:,:) !layer depth (m)
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2)
real(r8), pointer :: wtfact(:) !maximum saturated fraction for a gridcell
real(r8), pointer :: hksat(:,:) ! hydraulic conductivity at saturation (mm H2O /s)
real(r8), pointer :: bsw(:,:) ! Clapp and Hornberger "b"
real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm)
integer , pointer :: snl(:) ! minus number of snow layers
real(r8), pointer :: qflx_evap_grnd(:) ! ground surface evaporation rate (mm H2O/s) [+]
real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m)
!
! local pointers to original implicit out arguments
!
real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s)
real(r8), pointer :: eff_porosity(:,:) ! effective porosity = porosity - vol_ice
real(r8), pointer :: fracice(:,:) !fractional impermeability (-)
!
!EOP
!
! !OTHER LOCAL VARIABLES:
!
integer :: c,j,fc,g !indices
real(r8) :: xs(lbc:ubc) ! excess soil water above urban ponding limit
real(r8) :: vol_ice(lbc:ubc,1:nlevsoi) !partial volume of ice lens in layer
real(r8) :: fff(lbc:ubc) !decay factor (m-1)
real(r8) :: s1 !variable to calculate qinmax
real(r8) :: su !variable to calculate qinmax
real(r8) :: v !variable to calculate qinmax
real(r8) :: qinmax !maximum infiltration capacity (mm/s)
!-----------------------------------------------------------------------
! Assign local pointers to derived subtype components (column-level)
ctype => clm3%g%l%c%itype
qflx_top_soil => clm3%g%l%c%cwf%qflx_top_soil
qflx_surf => clm3%g%l%c%cwf%qflx_surf
watsat => clm3%g%l%c%cps%watsat
hkdepth => clm3%g%l%c%cps%hkdepth
dz => clm3%g%l%c%cps%dz
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
fcov => clm3%g%l%c%cws%fcov
fsat => clm3%g%l%c%cws%fsat
eff_porosity => clm3%g%l%c%cps%eff_porosity
wtfact => clm3%g%l%c%cps%wtfact
zwt => clm3%g%l%c%cws%zwt
fracice => clm3%g%l%c%cps%fracice
hksat => clm3%g%l%c%cps%hksat
bsw => clm3%g%l%c%cps%bsw
sucsat => clm3%g%l%c%cps%sucsat
snl => clm3%g%l%c%cps%snl
qflx_evap_grnd => clm3%g%l%c%cwf%pwf_a%qflx_evap_grnd
zi => clm3%g%l%c%cps%zi
do j = 1,nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
! Porosity of soil, partial volume of ice and liquid, fraction of ice in each layer,
! fractional impermeability
vol_ice(c,j) = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice))
eff_porosity(c,j) = max(0.01_r8,watsat(c,j)-vol_ice(c,j))
vol_liq(c,j) = min(eff_porosity(c,j), h2osoi_liq(c,j)/(dz(c,j)*denh2o))
icefrac(c,j) = min(1._r8,h2osoi_ice(c,j)/(h2osoi_ice(c,j)+h2osoi_liq(c,j)))
fracice(c,j) = max(0._r8,exp(-3._r8*(1._r8-icefrac(c,j)))- exp(-3._r8))/(1.0_r8-exp(-3._r8))
end do
end do
! Saturated fraction
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
fff(c) = 0.5_r8
fsat(c) = wtfact(c) * exp(-0.5_r8*fff(c)*zwt(c))
fcov(c) = (1._r8 - fracice(c,1)) * fsat(c) + fracice(c,1)
end do
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
! Maximum infiltration capacity
s1 = max(0.01_r8,vol_liq(c,1)/max(wimp,eff_porosity(c,1)))
su = max(0._r8,(s1-fcov(c)) / (max(0.01_r8,1._r8-fcov(c))))
v = -bsw(c,1)*sucsat(c,1)/(0.5_r8*dz(c,1)*1000._r8)
qinmax = (1._r8+v*(su-1._r8))*hksat(c,1)
! Surface runoff
qflx_surf(c) = fcov(c) * qflx_top_soil(c) + &
(1._r8-fcov(c)) * max(0._r8, qflx_top_soil(c)-qinmax)
end do
! Determine water in excess of ponding limit for urban roof and impervious road.
! Excess goes to surface runoff. No surface runoff for sunwall and shadewall.
!dir$ concurrent
!cdir nodep
do fc = 1, num_urbanc
c = filter_urbanc(fc)
if (ctype(c) == icol_roof .or. ctype(c) == icol_road_imperv) then
! If there are snow layers then all qflx_top_soil goes to surface runoff
if (snl(c) < 0) then
qflx_surf(c) = max(0._r8,qflx_top_soil(c))
else
xs(c) = max(0._r8, &
h2osoi_liq(c,1)/dtime + qflx_top_soil(c) - qflx_evap_grnd(c) - &
pondmx_urban/dtime)
if (xs(c) > 0.) then
h2osoi_liq(c,1) = pondmx_urban
else
h2osoi_liq(c,1) = max(0._r8,h2osoi_liq(c,1)+ &
(qflx_top_soil(c)-qflx_evap_grnd(c))*dtime)
end if
qflx_surf(c) = xs(c)
end if
else if (ctype(c) == icol_sunwall .or. ctype(c) == icol_shadewall) then
qflx_surf(c) = 0._r8
end if
end do
end subroutine SurfaceRunoff
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: Infiltration
!
! !INTERFACE:
subroutine Infiltration(lbc, ubc, num_hydrologyc, filter_hydrologyc, & 1,3
num_urbanc, filter_urbanc)
!
! !DESCRIPTION:
! Calculate infiltration into surface soil layer (minus the evaporation)
!
! !USES:
use shr_kind_mod, only : r8 => shr_kind_r8
use clm_varcon , only : icol_roof, icol_road_imperv, icol_sunwall, icol_shadewall, &
icol_road_perv
use clmtype
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_hydrologyc ! number of column soil points in column filter
integer, intent(in) :: filter_hydrologyc(ubc-lbc+1) ! column filter for soil points
integer, intent(in) :: num_urbanc ! number of column urban points in column filter
integer, intent(in) :: filter_urbanc(ubc-lbc+1) ! column filter for urban points
!
! !CALLED FROM:
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 12 November 1999: Z.-L. Yang and G.-Y. Niu
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 2/27/02, Peter Thornton: Migrated to new data structures.
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in arguments
!
integer , pointer :: ctype(:) ! column type index
integer , pointer :: snl(:) ! minus number of snow layers
real(r8), pointer :: qflx_top_soil(:) ! net water input into soil from top (mm/s)
real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s)
real(r8), pointer :: qflx_evap_grnd(:)! ground surface evaporation rate (mm H2O/s) [+]
!
! local pointers to original implicit out arguments
!
real(r8), pointer :: qflx_infl(:) !infiltration (mm H2O /s)
!
!EOP
!
! !OTHER LOCAL VARIABLES:
!
integer :: c, fc !indices
!-----------------------------------------------------------------------
! Assign local pointers to derived type members (column-level)
ctype => clm3%g%l%c%itype
snl => clm3%g%l%c%cps%snl
qflx_top_soil => clm3%g%l%c%cwf%qflx_top_soil
qflx_surf => clm3%g%l%c%cwf%qflx_surf
qflx_infl => clm3%g%l%c%cwf%qflx_infl
qflx_evap_grnd => clm3%g%l%c%cwf%pwf_a%qflx_evap_grnd
! Infiltration into surface soil layer (minus the evaporation)
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
if (snl(c) >= 0) then
qflx_infl(c) = qflx_top_soil(c) - qflx_surf(c) - qflx_evap_grnd(c)
else
qflx_infl(c) = qflx_top_soil(c) - qflx_surf(c)
end if
end do
! No infiltration for impervious urban surfaces
!dir$ concurrent
!cdir nodep
do fc = 1, num_urbanc
c = filter_urbanc(fc)
if (ctype(c) /= icol_road_perv) then
qflx_infl(c) = 0._r8
end if
end do
end subroutine Infiltration
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SoilWater
!
! !INTERFACE:
subroutine SoilWater(lbc, ubc, num_hydrologyc, filter_hydrologyc, & 2,12
num_urbanc, filter_urbanc, &
vol_liq, dwat, hk, dhkdw)
!
! !DESCRIPTION:
! Soil hydrology
! Soil moisture is predicted from a 10-layer model (as with soil
! temperature), in which the vertical soil moisture transport is governed
! by infiltration, runoff, gradient diffusion, gravity, and root
! extraction through canopy transpiration. The net water applied to the
! surface layer is the snowmelt plus precipitation plus the throughfall
! of canopy dew minus surface runoff and evaporation.
! CLM3.5 uses a zero-flow bottom boundary condition.
!
! The vertical water flow in an unsaturated porous media is described by
! Darcy's law, and the hydraulic conductivity and the soil negative
! potential vary with soil water content and soil texture based on the work
! of Clapp and Hornberger (1978) and Cosby et al. (1984). The equation is
! integrated over the layer thickness, in which the time rate of change in
! water mass must equal the net flow across the bounding interface, plus the
! rate of internal source or sink. The terms of water flow across the layer
! interfaces are linearly expanded by using first-order Taylor expansion.
! The equations result in a tridiagonal system equation.
!
! Note: length units here are all millimeter
! (in temperature subroutine uses same soil layer
! structure required but lengths are m)
!
! Richards equation:
!
! d wat d d wat d psi
! ----- = - -- [ k(----- ----- - 1) ] + S
! dt dz dz d wat
!
! where: wat = volume of water per volume of soil (mm**3/mm**3)
! psi = soil matrix potential (mm)
! dt = time step (s)
! z = depth (mm)
! dz = thickness (mm)
! qin = inflow at top (mm h2o /s)
! qout= outflow at bottom (mm h2o /s)
! s = source/sink flux (mm h2o /s)
! k = hydraulic conductivity (mm h2o /s)
!
! d qin d qin
! qin[n+1] = qin[n] + -------- d wat(j-1) + --------- d wat(j)
! d wat(j-1) d wat(j)
! ==================|=================
! < qin
!
! d wat(j)/dt * dz = qin[n+1] - qout[n+1] + S(j)
!
! > qout
! ==================|=================
! d qout d qout
! qout[n+1] = qout[n] + --------- d wat(j) + --------- d wat(j+1)
! d wat(j) d wat(j+1)
!
!
! Solution: linearize k and psi about d wat and use tridiagonal
! system of equations to solve for d wat,
! where for layer j
!
!
! r_j = a_j [d wat_j-1] + b_j [d wat_j] + c_j [d wat_j+1]
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype
use clm_varcon , only : wimp, icol_roof, icol_road_imperv
use clm_varpar , only : nlevsoi, max_pft_per_col
use shr_const_mod , only : SHR_CONST_TKFRZ, SHR_CONST_LATICE, SHR_CONST_G
use TridiagonalMod, only : Tridiagonal
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! column bounds
integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter
integer , intent(in) :: filter_hydrologyc(ubc-lbc+1) ! column filter for soil points
integer , intent(in) :: num_urbanc ! number of column urban points in column filter
integer , intent(in) :: filter_urbanc(ubc-lbc+1) ! column filter for urban points
real(r8), intent(in) :: vol_liq(lbc:ubc,1:nlevsoi) ! soil water per unit volume [mm/mm]
real(r8), intent(out) :: dwat(lbc:ubc,1:nlevsoi) ! change of soil water [m3/m3]
real(r8), intent(out) :: hk(lbc:ubc,1:nlevsoi) ! hydraulic conductivity [mm h2o/s]
real(r8), intent(out) :: dhkdw(lbc:ubc,1:nlevsoi) ! d(hk)/d(vol_liq)
!
! !CALLED FROM:
! subroutine Hydrology2 in module Hydrology2Mod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 2/27/02, Peter Thornton: Migrated to new data structures. Includes
! treatment of multiple PFTs on a single soil column.
! 04/25/07 Keith Oleson: CLM3.5 hydrology
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in arguments
!
integer , pointer :: ctype(:) ! column type index
integer , pointer :: npfts(:) ! column's number of pfts - ADD
real(r8), pointer :: pwtcol(:) ! weight relative to column for each pft
real(r8), pointer :: pwtgcell(:) ! weight relative to gridcell for each pft
real(r8), pointer :: z(:,:) ! layer depth (m)
real(r8), pointer :: dz(:,:) ! layer thickness (m)
real(r8), pointer :: smpmin(:) ! restriction for min of soil potential (mm)
real(r8), pointer :: qflx_infl(:) ! infiltration (mm H2O /s)
real(r8), pointer :: qflx_tran_veg_pft(:) ! vegetation transpiration (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_tran_veg_col(:) ! vegetation transpiration (mm H2O/s) (+ = to atm)
real(r8), pointer :: eff_porosity(:,:) ! effective porosity = porosity - vol_ice
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity)
real(r8), pointer :: hksat(:,:) ! hydraulic conductivity at saturation (mm H2O /s)
real(r8), pointer :: bsw(:,:) ! Clapp and Hornberger "b"
real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm)
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin)
real(r8), pointer :: rootr_pft(:,:) ! effective fraction of roots in each soil layer
integer , pointer :: pfti(:) ! beginning pft index for each column
real(r8), pointer :: fracice(:,:) ! fractional impermeability (-)
real(r8), pointer :: h2osoi_vol(:,:) ! volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3]
real(r8), pointer :: qcharge(:) ! aquifer recharge rate (mm/s)
real(r8), pointer :: hkdepth(:) ! decay factor (m)
real(r8), pointer :: zwt(:) ! water table depth (m)
real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m)
!
! local pointers to original implicit inout arguments
!
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
!
! local pointer s to original implicit out arguments
!
real(r8), pointer :: rootr_col(:,:) ! effective fraction of roots in each soil layer
real(r8), pointer :: smp_l(:,:) ! soil matrix potential [mm]
real(r8), pointer :: hk_l(:,:) ! hydraulic conductivity (mm/s)
!
!EOP
!
! !OTHER LOCAL VARIABLES:
!
integer :: p,c,fc,j ! do loop indices
integer :: jtop(lbc:ubc) ! top level at each column
real(r8) :: amx(lbc:ubc,1:nlevsoi+1) ! "a" left off diagonal of tridiagonal matrix
real(r8) :: bmx(lbc:ubc,1:nlevsoi+1) ! "b" diagonal column for tridiagonal matrix
real(r8) :: cmx(lbc:ubc,1:nlevsoi+1) ! "c" right off diagonal tridiagonal matrix
real(r8) :: rmx(lbc:ubc,1:nlevsoi+1) ! "r" forcing term of tridiagonal matrix
real(r8) :: zmm(lbc:ubc,1:nlevsoi+1) ! layer depth [mm]
real(r8) :: dzmm(lbc:ubc,1:nlevsoi+1) ! layer thickness [mm]
real(r8) :: den ! used in calculating qin, qout
real(r8) :: dqidw0(lbc:ubc,1:nlevsoi+1) ! d(qin)/d(vol_liq(i-1))
real(r8) :: dqidw1(lbc:ubc,1:nlevsoi+1) ! d(qin)/d(vol_liq(i))
real(r8) :: dqodw1(lbc:ubc,1:nlevsoi+1) ! d(qout)/d(vol_liq(i))
real(r8) :: dqodw2(lbc:ubc,1:nlevsoi+1) ! d(qout)/d(vol_liq(i+1))
real(r8) :: dsmpdw(lbc:ubc,1:nlevsoi+1) ! d(smp)/d(vol_liq)
real(r8) :: num ! used in calculating qin, qout
real(r8) :: qin(lbc:ubc,1:nlevsoi+1) ! flux of water into soil layer [mm h2o/s]
real(r8) :: qout(lbc:ubc,1:nlevsoi+1) ! flux of water out of soil layer [mm h2o/s]
real(r8) :: s_node ! soil wetness
real(r8) :: s1 ! "s" at interface of layer
real(r8) :: s2 ! k*s**(2b+2)
real(r8) :: smp(lbc:ubc,1:nlevsoi) ! soil matrix potential [mm]
real(r8) :: sdamp ! extrapolates soiwat dependence of evaporation
integer :: pi ! pft index
real(r8) :: temp(lbc:ubc) ! accumulator for rootr weighting
integer :: jwt(lbc:ubc) ! index of the soil layer right above the water table (-)
real(r8) :: smp1,dsmpdw1,wh,wh_zwt,ka
real(r8) :: dwat2(lbc:ubc,1:nlevsoi+1)
real(r8) :: dzq ! used in calculating qin, qout (difference in equilbirium matric potential)
real(r8) :: zimm(lbc:ubc,0:nlevsoi) ! layer interface depth [mm]
real(r8) :: zq(lbc:ubc,1:nlevsoi+1) ! equilibrium matric potential for each layer [mm]
real(r8) :: vol_eq(lbc:ubc,1:nlevsoi+1) ! equilibrium volumetric water content
real(r8) :: tempi ! temp variable for calculating vol_eq
real(r8) :: temp0 ! temp variable for calculating vol_eq
real(r8) :: voleq1 ! temp variable for calculating vol_eq
real(r8) :: zwtmm(lbc:ubc) ! water table depth [mm]
!-----------------------------------------------------------------------
! Assign local pointers to derived type members (column-level)
qcharge => clm3%g%l%c%cws%qcharge
hkdepth => clm3%g%l%c%cps%hkdepth
zi => clm3%g%l%c%cps%zi
zwt => clm3%g%l%c%cws%zwt
ctype => clm3%g%l%c%itype
npfts => clm3%g%l%c%npfts
z => clm3%g%l%c%cps%z
dz => clm3%g%l%c%cps%dz
smpmin => clm3%g%l%c%cps%smpmin
watsat => clm3%g%l%c%cps%watsat
hksat => clm3%g%l%c%cps%hksat
bsw => clm3%g%l%c%cps%bsw
sucsat => clm3%g%l%c%cps%sucsat
eff_porosity => clm3%g%l%c%cps%eff_porosity
rootr_col => clm3%g%l%c%cps%rootr_column
t_soisno => clm3%g%l%c%ces%t_soisno
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_vol => clm3%g%l%c%cws%h2osoi_vol
qflx_infl => clm3%g%l%c%cwf%qflx_infl
fracice => clm3%g%l%c%cps%fracice
qflx_tran_veg_col => clm3%g%l%c%cwf%pwf_a%qflx_tran_veg
pfti => clm3%g%l%c%pfti
smp_l => clm3%g%l%c%cws%smp_l
hk_l => clm3%g%l%c%cws%hk_l
! Assign local pointers to derived type members (pft-level)
qflx_tran_veg_pft => clm3%g%l%c%p%pwf%qflx_tran_veg
rootr_pft => clm3%g%l%c%p%pps%rootr
pwtcol => clm3%g%l%c%p%wtcol
pwtgcell => clm3%g%l%c%p%wtgcell
! Because the depths in this routine are in mm, use local
! variable arrays instead of pointers
do j = 1, nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
zmm(c,j) = z(c,j)*1.e3_r8
dzmm(c,j) = dz(c,j)*1.e3_r8
zimm(c,j) = zi(c,j)*1.e3_r8
end do
end do
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
zimm(c,0) = 0.0_r8
zwtmm(c) = zwt(c)*1.e3_r8
end do
! First step is to calculate the column-level effective rooting
! fraction in each soil layer. This is done outside the usual
! PFT-to-column averaging routines because it is not a simple
! weighted average of the PFT level rootr arrays. Instead, the
! weighting depends on both the per-unit-area transpiration
! of the PFT and the PFTs area relative to all PFTs.
temp(:) = 0._r8
do j = 1, nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
rootr_col(c,j) = 0._r8
end do
end do
do pi = 1,max_pft_per_col
do j = 1,nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
if (pi <= npfts(c)) then
p = pfti(c) + pi - 1
if (pwtgcell(p)>0._r8) then
rootr_col(c,j) = rootr_col(c,j) + rootr_pft(p,j) * qflx_tran_veg_pft(p) * pwtcol(p)
end if
end if
end do
end do
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
if (pi <= npfts(c)) then
p = pfti(c) + pi - 1
if (pwtgcell(p)>0._r8) then
temp(c) = temp(c) + qflx_tran_veg_pft(p) * pwtcol(p)
end if
end if
end do
end do
do j = 1, nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
if (temp(c) /= 0._r8) then
rootr_col(c,j) = rootr_col(c,j)/temp(c)
end if
end do
end do
!compute jwt index
! The layer index of the first unsaturated layer, i.e., the layer right above
! the water table
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
jwt(c) = nlevsoi
do j = 2,nlevsoi
if(zwt(c) <= zi(c,j)) then
jwt(c) = j-1
exit
end if
enddo
end do
! calculate the equilibrium water content based on the water table depth
do j=1,nlevsoi
do fc=1, num_hydrologyc
c = filter_hydrologyc(fc)
if ((zwtmm(c) .lt. zimm(c,j-1))) then !fully saturated when wtd is less than the layer top
vol_eq(c,j) = watsat(c,j)
! use the weighted average from the saturated part (depth > wtd) and the equilibrium solution for the
! rest of the layer
else if ((zwtmm(c) .lt. zimm(c,j)) .and. (zwtmm(c) .gt. zimm(c,j-1))) then
tempi = 1.0_r8
temp0 = (((sucsat(c,j)+zwtmm(c)-zimm(c,j-1))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j))
voleq1 = -sucsat(c,j)*watsat(c,j)/(1._r8-1._r8/bsw(c,j))/(zwtmm(c)-zimm(c,j-1))*(tempi-temp0)
vol_eq(c,j) = (voleq1*(zwtmm(c)-zimm(c,j-1)) + watsat(c,j)*(zimm(c,j)-zwtmm(c)))/(zimm(c,j)-zimm(c,j-1))
vol_eq(c,j) = min(watsat(c,j),vol_eq(c,j))
vol_eq(c,j) = max(vol_eq(c,j),0.0_r8)
else
tempi = (((sucsat(c,j)+zwtmm(c)-zimm(c,j))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j))
temp0 = (((sucsat(c,j)+zwtmm(c)-zimm(c,j-1))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j))
vol_eq(c,j) = -sucsat(c,j)*watsat(c,j)/(1._r8-1._r8/bsw(c,j))/(zimm(c,j)-zimm(c,j-1))*(tempi-temp0)
vol_eq(c,j) = max(vol_eq(c,j),0.0_r8)
vol_eq(c,j) = min(watsat(c,j),vol_eq(c,j))
endif
zq(c,j) = -sucsat(c,j)*(max(vol_eq(c,j)/watsat(c,j),0.01_r8))**(-bsw(c,j))
zq(c,j) = max(smpmin(c), zq(c,j))
end do
end do
! If water table is below soil column calculate zq for the 11th layer
j = nlevsoi
do fc=1, num_hydrologyc
c = filter_hydrologyc(fc)
if(jwt(c) == nlevsoi) then
tempi = 1._r8
temp0 = (((sucsat(c,j)+zwtmm(c)-zimm(c,j))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j))
vol_eq(c,j+1) = -sucsat(c,j)*watsat(c,j)/(1._r8-1._r8/bsw(c,j))/(zwtmm(c)-zimm(c,j))*(tempi-temp0)
vol_eq(c,j+1) = max(vol_eq(c,j+1),0.0_r8)
vol_eq(c,j+1) = min(watsat(c,j),vol_eq(c,j+1))
zq(c,j+1) = -sucsat(c,j)*(max(vol_eq(c,j+1)/watsat(c,j),0.01_r8))**(-bsw(c,j))
zq(c,j+1) = max(smpmin(c), zq(c,j+1))
end if
end do
! Hydraulic conductivity and soil matric potential and their derivatives
sdamp = 0._r8
do j = 1, nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
s1 = 0.5_r8*(h2osoi_vol(c,j) + h2osoi_vol(c,min(nlevsoi, j+1))) / &
(0.5_r8*(watsat(c,j)+watsat(c,min(nlevsoi, j+1))))
s1 = min(1._r8, s1)
s2 = hksat(c,j)*s1**(2._r8*bsw(c,j)+2._r8)
hk(c,j) = (1._r8-0.5_r8*(fracice(c,j)+fracice(c,min(nlevsoi, j+1))))*s1*s2
dhkdw(c,j) = (1._r8-0.5_r8*(fracice(c,j)+fracice(c,min(nlevsoi, j+1))))* &
(2._r8*bsw(c,j)+3._r8)*s2*0.5_r8/watsat(c,j)
s_node = max(h2osoi_vol(c,j)/watsat(c,j), 0.01_r8)
s_node = min(1.0_r8, s_node)
smp(c,j) = -sucsat(c,j)*s_node**(-bsw(c,j))
smp(c,j) = max(smpmin(c), smp(c,j))
dsmpdw(c,j) = -bsw(c,j)*smp(c,j)/(s_node*watsat(c,j))
smp_l(c,j) = smp(c,j)
hk_l(c,j) = hk(c,j)
end do
end do
! aquifer (11th) layer
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
zmm(c,nlevsoi+1) = 0.5*(1.e3_r8*zwt(c) + zmm(c,nlevsoi))
if(jwt(c) < nlevsoi) then
dzmm(c,nlevsoi+1) = dzmm(c,nlevsoi)
else
dzmm(c,nlevsoi+1) = (1.e3_r8*zwt(c) - zmm(c,nlevsoi))
end if
end do
! Set up r, a, b, and c vectors for tridiagonal solution
! Node j=1 (top)
j = 1
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
qin(c,j) = qflx_infl(c)
den = (zmm(c,j+1)-zmm(c,j))
dzq = (zq(c,j+1)-zq(c,j))
num = (smp(c,j+1)-smp(c,j)) - dzq
qout(c,j) = -hk(c,j)*num/den
dqodw1(c,j) = -(-hk(c,j)*dsmpdw(c,j) + num*dhkdw(c,j))/den
dqodw2(c,j) = -( hk(c,j)*dsmpdw(c,j+1) + num*dhkdw(c,j))/den
rmx(c,j) = qin(c,j) - qout(c,j) - qflx_tran_veg_col(c) * rootr_col(c,j)
amx(c,j) = 0._r8
bmx(c,j) = dzmm(c,j)*(sdamp+1._r8/dtime) + dqodw1(c,j)
cmx(c,j) = dqodw2(c,j)
end do
! Nodes j=2 to j=nlevsoi-1
do j = 2, nlevsoi - 1
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
den = (zmm(c,j) - zmm(c,j-1))
dzq = (zq(c,j)-zq(c,j-1))
num = (smp(c,j)-smp(c,j-1)) - dzq
qin(c,j) = -hk(c,j-1)*num/den
dqidw0(c,j) = -(-hk(c,j-1)*dsmpdw(c,j-1) + num*dhkdw(c,j-1))/den
dqidw1(c,j) = -( hk(c,j-1)*dsmpdw(c,j) + num*dhkdw(c,j-1))/den
den = (zmm(c,j+1)-zmm(c,j))
dzq = (zq(c,j+1)-zq(c,j))
num = (smp(c,j+1)-smp(c,j)) - dzq
qout(c,j) = -hk(c,j)*num/den
dqodw1(c,j) = -(-hk(c,j)*dsmpdw(c,j) + num*dhkdw(c,j))/den
dqodw2(c,j) = -( hk(c,j)*dsmpdw(c,j+1) + num*dhkdw(c,j))/den
rmx(c,j) = qin(c,j) - qout(c,j) - qflx_tran_veg_col(c)*rootr_col(c,j)
amx(c,j) = -dqidw0(c,j)
bmx(c,j) = dzmm(c,j)/dtime - dqidw1(c,j) + dqodw1(c,j)
cmx(c,j) = dqodw2(c,j)
end do
end do
! Node j=nlevsoi (bottom)
j = nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
if(j > jwt(c)) then !water table is in soil column
den = (zmm(c,j) - zmm(c,j-1))
dzq = (zq(c,j)-zq(c,j-1))
num = (smp(c,j)-smp(c,j-1)) - dzq
qin(c,j) = -hk(c,j-1)*num/den
dqidw0(c,j) = -(-hk(c,j-1)*dsmpdw(c,j-1) + num*dhkdw(c,j-1))/den
dqidw1(c,j) = -( hk(c,j-1)*dsmpdw(c,j) + num*dhkdw(c,j-1))/den
qout(c,j) = 0._r8
dqodw1(c,j) = 0._r8
rmx(c,j) = qin(c,j) - qout(c,j) - qflx_tran_veg_col(c)*rootr_col(c,j)
amx(c,j) = -dqidw0(c,j)
bmx(c,j) = dzmm(c,j)/dtime - dqidw1(c,j) + dqodw1(c,j)
cmx(c,j) = 0._r8
!scs: next set up aquifer layer; hydrologically inactive
rmx(c,j+1) = 0._r8
amx(c,j+1) = 0._r8
bmx(c,j+1) = dzmm(c,j+1)/dtime
cmx(c,j+1) = 0._r8
else ! water table is below soil column
!scs: compute aquifer soil moisture as average of layer 10 and saturation
s_node = max(0.5*(1.0_r8+h2osoi_vol(c,j)/watsat(c,j)), 0.01_r8)
s_node = min(1.0_r8, s_node)
!scs: compute smp for aquifer layer
smp1 = -sucsat(c,j)*s_node**(-bsw(c,j))
smp1 = max(smpmin(c), smp1)
!scs: compute dsmpdw for aquifer layer
dsmpdw1 = -bsw(c,j)*smp1/(s_node*watsat(c,j))
!scs: first set up bottom layer of soil column
den = (zmm(c,j) - zmm(c,j-1))
dzq = (zq(c,j)-zq(c,j-1))
num = (smp(c,j)-smp(c,j-1)) - dzq
qin(c,j) = -hk(c,j-1)*num/den
dqidw0(c,j) = -(-hk(c,j-1)*dsmpdw(c,j-1) + num*dhkdw(c,j-1))/den
dqidw1(c,j) = -( hk(c,j-1)*dsmpdw(c,j) + num*dhkdw(c,j-1))/den
den = (zmm(c,j+1)-zmm(c,j))
dzq = (zq(c,j+1)-zq(c,j))
num = (smp1-smp(c,j)) - dzq
qout(c,j) = -hk(c,j)*num/den
dqodw1(c,j) = -(-hk(c,j)*dsmpdw(c,j) + num*dhkdw(c,j))/den
dqodw2(c,j) = -( hk(c,j)*dsmpdw1 + num*dhkdw(c,j))/den
rmx(c,j) = qin(c,j) - qout(c,j) - qflx_tran_veg_col(c)*rootr_col(c,j)
amx(c,j) = -dqidw0(c,j)
bmx(c,j) = dzmm(c,j)/dtime - dqidw1(c,j) + dqodw1(c,j)
cmx(c,j) = dqodw2(c,j)
!scs: next set up aquifer layer; den/num unchanged, qin=qout
qin(c,j+1) = qout(c,j)
dqidw0(c,j+1) = -(-hk(c,j)*dsmpdw(c,j) + num*dhkdw(c,j))/den
dqidw1(c,j+1) = -( hk(c,j)*dsmpdw1 + num*dhkdw(c,j))/den
qout(c,j+1) = 0._r8 ! zero-flow bottom boundary condition
dqodw1(c,j+1) = 0._r8 ! zero-flow bottom boundary condition
rmx(c,j+1) = qin(c,j+1) - qout(c,j+1)
amx(c,j+1) = -dqidw0(c,j+1)
bmx(c,j+1) = dzmm(c,j+1)/dtime - dqidw1(c,j+1) + dqodw1(c,j+1)
cmx(c,j+1) = 0._r8
endif
end do
! Solve for dwat
jtop(:) = 1
call Tridiagonal(lbc, ubc, 1, nlevsoi+1, jtop, num_hydrologyc, filter_hydrologyc, &
amx, bmx, cmx, rmx, dwat2 )
!scs: set dwat
do fc = 1,num_hydrologyc
c = filter_hydrologyc(fc)
do j = 1, nlevsoi
dwat(c,j)=dwat2(c,j)
end do
end do
! Renew the mass of liquid water
!scs: also compute qcharge from dwat in aquifer layer
!scs: update in drainage for case jwt < nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1,num_hydrologyc
c = filter_hydrologyc(fc)
do j = 1, nlevsoi
h2osoi_liq(c,j) = h2osoi_liq(c,j) + dwat2(c,j)*dzmm(c,j)
end do
!scs: calculate qcharge for case jwt < nlevsoi
if(jwt(c) < nlevsoi) then
wh_zwt = 0._r8 !since wh_zwt = -sucsat - zq_zwt, where zq_zwt = -sucsat
s_node = max(h2osoi_vol(c,jwt(c))/watsat(c,jwt(c)), 0.01_r8)
s_node = min(1.0_r8, s_node)
!scs: use average moisture between water table and layer jwt
s1 = 0.5_r8*(1.0+s_node)
s1 = min(1._r8, s1)
!scs: this is the expression for unsaturated hk
ka = hksat(c,jwt(c))*s1**(2._r8*bsw(c,jwt(c))+3._r8)
! Recharge rate qcharge to groundwater (positive to aquifer)
smp1 = -sucsat(c,jwt(c))*s_node**(-bsw(c,jwt(c)))
smp1 = max(smpmin(c), smp(c,jwt(c)))
wh = smp1 - zq(c,jwt(c))
qcharge(c) = -ka * (wh_zwt-wh) /((zwt(c)-z(c,jwt(c)))*1000._r8)
! To limit qcharge (for the first several timesteps)
qcharge(c) = max(-10.0_r8/dtime,qcharge(c))
qcharge(c) = min( 10.0_r8/dtime,qcharge(c))
else
!scs: if water table is below soil column, compute qcharge from dwat2(11)
qcharge(c) = dwat2(c,nlevsoi+1)*dzmm(c,nlevsoi+1)/dtime
endif
end do
end subroutine SoilWater
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: Drainage
!
! !INTERFACE:
subroutine Drainage(lbc, ubc, num_hydrologyc, filter_hydrologyc, & 1,5
num_urbanc, filter_urbanc, vol_liq, hk, &
icefrac)
!
! !DESCRIPTION:
! Calculate subsurface drainage
!
! !USES:
use shr_kind_mod, only : r8 => shr_kind_r8
use clmtype
use clm_varcon , only : pondmx, tfrz, icol_roof, icol_road_imperv, icol_road_perv, watmin
use clm_varpar , only : nlevsoi
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: lbc, ubc ! column bounds
integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter
integer , intent(in) :: num_urbanc ! number of column urban points in column filter
integer , intent(in) :: filter_urbanc(ubc-lbc+1) ! column filter for urban points
integer , intent(in) :: filter_hydrologyc(ubc-lbc+1) ! column filter for soil points
real(r8), intent(in) :: vol_liq(lbc:ubc,1:nlevsoi) ! partial volume of liquid water in layer
real(r8), intent(in) :: hk(lbc:ubc,1:nlevsoi) ! hydraulic conductivity (mm h2o/s)
real(r8), intent(in) :: icefrac(lbc:ubc,1:nlevsoi) ! fraction of ice in layer
!
! !CALLED FROM:
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 12 November 1999: Z.-L. Yang and G.-Y. Niu
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 4/26/05, Peter Thornton and David Lawrence: Turned off drainage from
! middle soil layers for both wet and dry fractions.
! 04/25/07 Keith Oleson: Completely new routine for CLM3.5 hydrology
! 27 February 2008: Keith Oleson; Saturation excess modification
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in arguments
!
integer , pointer :: ctype(:) !column type index
integer , pointer :: snl(:) !number of snow layers
real(r8), pointer :: qflx_snwcp_liq(:) !excess rainfall due to snow capping (mm H2O /s) [+]
real(r8), pointer :: qflx_dew_grnd(:) !ground surface dew formation (mm H2O /s) [+]
real(r8), pointer :: qflx_dew_snow(:) !surface dew added to snow pack (mm H2O /s) [+]
real(r8), pointer :: qflx_sub_snow(:) !sublimation rate from snow pack (mm H2O /s) [+]
real(r8), pointer :: dz(:,:) !layer depth (m)
real(r8), pointer :: bsw(:,:) !Clapp and Hornberger "b"
real(r8), pointer :: eff_porosity(:,:) !effective porosity = porosity - vol_ice
real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin)
real(r8), pointer :: hksat(:,:) !hydraulic conductivity at saturation (mm H2O /s)
real(r8), pointer :: sucsat(:,:) !minimum soil suction (mm)
real(r8), pointer :: z(:,:) !layer depth (m)
real(r8), pointer :: zi(:,:) !interface level below a "z" level (m)
real(r8), pointer :: watsat(:,:) !volumetric soil water at saturation (porosity)
real(r8), pointer :: hkdepth(:) !decay factor (m)
real(r8), pointer :: zwt(:) !water table depth (m)
real(r8), pointer :: wa(:) !water in the unconfined aquifer (mm)
real(r8), pointer :: wt(:) !total water storage (unsaturated soil water + groundwater) (mm)
real(r8), pointer :: qcharge(:) !aquifer recharge rate (mm/s)
!
! local pointers to original implicit inout arguments
!
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2)
!
! local pointers to original implicit out arguments
!
real(r8), pointer :: qflx_drain(:) !sub-surface runoff (mm H2O /s)
real(r8), pointer :: qflx_qrgwl(:) !qflx_surf at glaciers, wetlands, lakes (mm H2O /s)
real(r8), pointer :: eflx_impsoil(:) !implicit evaporation for soil temperature equation
real(r8), pointer :: qflx_rsub_sat(:) !soil saturation excess [mm h2o/s]
!
!EOP
!
! !OTHER LOCAL VARIABLES:
!
!KO integer :: c,j,fc !indices
!KO
integer :: c,j,fc,i !indices
!KO
real(r8) :: xs(lbc:ubc) !water needed to bring soil moisture to watmin (mm)
real(r8) :: dzmm(lbc:ubc,1:nlevsoi) !layer thickness (mm)
integer :: jwt(lbc:ubc) !index of the soil layer right above the water table (-)
real(r8) :: rsub_bot(lbc:ubc) !subsurface runoff - bottom drainage (mm/s)
real(r8) :: rsub_top(lbc:ubc) !subsurface runoff - topographic control (mm/s)
real(r8) :: fff(lbc:ubc) !decay factor (m-1)
real(r8) :: xsi(lbc:ubc) !excess soil water above saturation at layer i (mm)
real(r8) :: xsia(lbc:ubc) !available pore space at layer i (mm)
real(r8) :: xs1(lbc:ubc) !excess soil water above saturation at layer 1 (mm)
real(r8) :: smpfz(1:nlevsoi) !matric potential of layer right above water table (mm)
real(r8) :: wtsub !summation of hk*dzmm for layers below water table (mm**2/s)
real(r8) :: rous !aquifer yield (-)
real(r8) :: wh !smpfz(jwt)-z(jwt) (mm)
real(r8) :: wh_zwt !water head at the water table depth (mm)
real(r8) :: ws !summation of pore space of layers below water table (mm)
real(r8) :: s_node !soil wetness (-)
real(r8) :: dzsum !summation of dzmm of layers below water table (mm)
real(r8) :: icefracsum !summation of icefrac*dzmm of layers below water table (-)
real(r8) :: fracice_rsub(lbc:ubc) !fractional impermeability of soil layers (-)
real(r8) :: ka !hydraulic conductivity of the aquifer (mm/s)
real(r8) :: dza !fff*(zwt-z(jwt)) (-)
!KO
real(r8) :: available_h2osoi_liq !available soil liquid water in a layer
!KO
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (column-level)
ctype => clm3%g%l%c%itype
! cgridcell => clm3%g%l%c%gridcell
snl => clm3%g%l%c%cps%snl
dz => clm3%g%l%c%cps%dz
bsw => clm3%g%l%c%cps%bsw
t_soisno => clm3%g%l%c%ces%t_soisno
hksat => clm3%g%l%c%cps%hksat
sucsat => clm3%g%l%c%cps%sucsat
z => clm3%g%l%c%cps%z
zi => clm3%g%l%c%cps%zi
watsat => clm3%g%l%c%cps%watsat
hkdepth => clm3%g%l%c%cps%hkdepth
zwt => clm3%g%l%c%cws%zwt
wa => clm3%g%l%c%cws%wa
wt => clm3%g%l%c%cws%wt
qcharge => clm3%g%l%c%cws%qcharge
eff_porosity => clm3%g%l%c%cps%eff_porosity
qflx_snwcp_liq => clm3%g%l%c%cwf%pwf_a%qflx_snwcp_liq
qflx_dew_grnd => clm3%g%l%c%cwf%pwf_a%qflx_dew_grnd
qflx_dew_snow => clm3%g%l%c%cwf%pwf_a%qflx_dew_snow
qflx_sub_snow => clm3%g%l%c%cwf%pwf_a%qflx_sub_snow
qflx_drain => clm3%g%l%c%cwf%qflx_drain
qflx_qrgwl => clm3%g%l%c%cwf%qflx_qrgwl
qflx_rsub_sat => clm3%g%l%c%cwf%qflx_rsub_sat
eflx_impsoil => clm3%g%l%c%cef%eflx_impsoil
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
! Convert layer thicknesses from m to mm
do j = 1,nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
dzmm(c,j) = dz(c,j)*1.e3_r8
end do
end do
! Initial set
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
qflx_drain(c) = 0._r8
rsub_bot(c) = 0._r8
qflx_rsub_sat(c) = 0._r8
rsub_top(c) = 0._r8
fracice_rsub(c) = 0._r8
end do
! The layer index of the first unsaturated layer, i.e., the layer right above
! the water table
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
jwt(c) = nlevsoi
do j = 2,nlevsoi
if(zwt(c) <= zi(c,j)) then
jwt(c) = j-1
exit
end if
enddo
end do
! Topographic runoff
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
fff(c) = 1._r8/ hkdepth(c)
dzsum = 0._r8
icefracsum = 0._r8
do j = jwt(c), nlevsoi
dzsum = dzsum + dzmm(c,j)
icefracsum = icefracsum + icefrac(c,j) * dzmm(c,j)
end do
fracice_rsub(c) = max(0._r8,exp(-3._r8*(1._r8-(icefracsum/dzsum)))- exp(-3._r8))/(1.0_r8-exp(-3._r8))
rsub_top(c) = (1._r8 - fracice_rsub(c)) * 5.5e-3_r8 * exp(-fff(c)*zwt(c))
end do
rous = 0.2_r8
! Water table calculation
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
! Water storage in aquifer + soil
wt(c) = wt(c) + (qcharge(c) - rsub_top(c)) * dtime
if(jwt(c) == nlevsoi) then ! water table is below the soil column
wa(c) = wa(c) + (qcharge(c) -rsub_top(c)) * dtime
wt(c) = wa(c)
zwt(c) = (zi(c,nlevsoi) + 25._r8) - wa(c)/1000._r8/rous
h2osoi_liq(c,nlevsoi) = h2osoi_liq(c,nlevsoi) + max(0._r8,(wa(c)-5000._r8))
wa(c) = min(wa(c), 5000._r8)
else ! water table within soil layers
if (jwt(c) == nlevsoi-1) then ! water table within bottom soil layer
zwt(c) = zi(c,nlevsoi)- (wt(c)-rous*1000._r8*25._r8) /eff_porosity(c,nlevsoi)/1000._r8
else ! water table within soil layers 1-9
ws = 0._r8 ! water used to fill soil air pores regardless of water content
do j = jwt(c)+2,nlevsoi
ws = ws + eff_porosity(c,j) * 1000._r8 * dz(c,j)
enddo
zwt(c) = zi(c,jwt(c)+1)-(wt(c)-rous*1000_r8*25._r8-ws) /eff_porosity(c,jwt(c)+1)/1000._r8
endif
wtsub = 0._r8
do j = jwt(c)+1, nlevsoi
wtsub = wtsub + hk(c,j)*dzmm(c,j)
end do
! Remove subsurface runoff
do j = jwt(c)+1, nlevsoi
h2osoi_liq(c,j) = h2osoi_liq(c,j) - rsub_top(c)*dtime*hk(c,j)*dzmm(c,j)/wtsub
end do
end if
zwt(c) = max(0.05_r8,zwt(c))
zwt(c) = min(80._r8,zwt(c))
end do
! excessive water above saturation added to the above unsaturated layer like a bucket
! if column fully saturated, excess water goes to runoff
do j = nlevsoi,2,-1
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
xsi(c) = max(h2osoi_liq(c,j)-eff_porosity(c,j)*dzmm(c,j),0._r8)
h2osoi_liq(c,j) = min(eff_porosity(c,j)*dzmm(c,j), h2osoi_liq(c,j))
h2osoi_liq(c,j-1) = h2osoi_liq(c,j-1) + xsi(c)
end do
end do
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
xs1(c) = max(max(h2osoi_liq(c,1),0._r8)-max(0._r8,(pondmx+watsat(c,1)*dzmm(c,1)-h2osoi_ice(c,1))),0._r8)
h2osoi_liq(c,1) = min(max(0._r8,pondmx+watsat(c,1)*dzmm(c,1)-h2osoi_ice(c,1)), h2osoi_liq(c,1))
qflx_rsub_sat(c) = xs1(c) / dtime
end do
! Limit h2osoi_liq to be greater than or equal to watmin.
! Get water needed to bring h2osoi_liq equal watmin from lower layer.
! If insufficient water in soil layers, get from aquifer water
do j = 1, nlevsoi-1
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
!KO if (h2osoi_liq(c,j) < 0._r8) then
!KO
if (h2osoi_liq(c,j) < watmin) then
!KO
xs(c) = watmin - h2osoi_liq(c,j)
else
xs(c) = 0._r8
end if
h2osoi_liq(c,j ) = h2osoi_liq(c,j ) + xs(c)
h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) - xs(c)
end do
end do
!KO j = nlevsoi
!KO!dir$ concurrent
!KO!cdir nodep
!KO do fc = 1, num_hydrologyc
!KO c = filter_hydrologyc(fc)
!KO if (h2osoi_liq(c,j) < watmin) then
!KO xs(c) = watmin-h2osoi_liq(c,j)
!KO else
!KO xs(c) = 0._r8
!KO end if
!KO h2osoi_liq(c,j) = h2osoi_liq(c,j) + xs(c)
!KO wa(c) = wa(c) - xs(c)
!KO wt(c) = wt(c) - xs(c)
!KO end do
!KO
! Get water for bottom layer from layers above if possible
j = nlevsoi
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
if (h2osoi_liq(c,j) < watmin) then
xs(c) = watmin-h2osoi_liq(c,j)
searchforwater: do i = nlevsoi-1, 1, -1
available_h2osoi_liq = max(h2osoi_liq(c,i)-watmin-xs(c),0._r8)
if (available_h2osoi_liq .ge. xs(c)) then
h2osoi_liq(c,j) = h2osoi_liq(c,j) + xs(c)
h2osoi_liq(c,i) = h2osoi_liq(c,i) - xs(c)
xs(c) = 0._r8
exit searchforwater
else
h2osoi_liq(c,j) = h2osoi_liq(c,j) + available_h2osoi_liq
h2osoi_liq(c,i) = h2osoi_liq(c,i) - available_h2osoi_liq
xs(c) = xs(c) - available_h2osoi_liq
end if
end do searchforwater
else
xs(c) = 0._r8
end if
! Needed in case there is no water to be found
h2osoi_liq(c,j) = h2osoi_liq(c,j) + xs(c)
wt(c) = wt(c) - xs(c)
! Instead of removing water from aquifer where it eventually
! shows up as excess drainage to the ocean, take it back out of
! drainage
rsub_top(c) = rsub_top(c) - xs(c)/dtime
end do
!KO
!dir$ concurrent
!cdir nodep
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
! Sub-surface runoff and drainage
qflx_drain(c) = qflx_rsub_sat(c) + rsub_top(c)
! Set imbalance for snow capping
qflx_qrgwl(c) = qflx_snwcp_liq(c)
! Implicit evaporation term is now zero
eflx_impsoil(c) = 0._r8
! Renew the ice and liquid mass due to condensation
if (snl(c)+1 >= 1) then
h2osoi_liq(c,1) = h2osoi_liq(c,1) + qflx_dew_grnd(c) * dtime
h2osoi_ice(c,1) = h2osoi_ice(c,1) + (qflx_dew_snow(c) * dtime)
if (qflx_sub_snow(c)*dtime > h2osoi_ice(c,1)) then
qflx_sub_snow(c) = h2osoi_ice(c,1)/dtime
h2osoi_ice(c,1) = 0._r8
else
h2osoi_ice(c,1) = h2osoi_ice(c,1) - (qflx_sub_snow(c) * dtime)
end if
end if
end do
! No drainage for urban columns (except for pervious road as computed above)
!dir$ concurrent
!cdir nodep
do fc = 1, num_urbanc
c = filter_urbanc(fc)
if (ctype(c) /= icol_road_perv) then
qflx_drain(c) = 0._r8
! This must be done for roofs and impervious road (walls will be zero)
qflx_qrgwl(c) = qflx_snwcp_liq(c)
eflx_impsoil(c) = 0._r8
end if
! Renew the ice and liquid mass due to condensation for urban roof and impervious road
if (ctype(c) == icol_roof .or. ctype(c) == icol_road_imperv) then
if (snl(c)+1 >= 1) then
h2osoi_liq(c,1) = h2osoi_liq(c,1) + qflx_dew_grnd(c) * dtime
h2osoi_ice(c,1) = h2osoi_ice(c,1) + (qflx_dew_snow(c) * dtime)
if (qflx_sub_snow(c)*dtime > h2osoi_ice(c,1)) then
qflx_sub_snow(c) = h2osoi_ice(c,1)/dtime
h2osoi_ice(c,1) = 0._r8
else
h2osoi_ice(c,1) = h2osoi_ice(c,1) - (qflx_sub_snow(c) * dtime)
end if
end if
end if
end do
end subroutine Drainage
end module SoilHydrologyMod
module SnowHydrologyMod 1,2
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: SnowHydrologyMod
!
! !DESCRIPTION:
! Calculate snow hydrology.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varpar , only : nlevsno
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: SnowWater ! Change of snow mass and the snow water onto soil
public :: SnowCompaction ! Change in snow layer thickness due to compaction
public :: CombineSnowLayers ! Combine snow layers less than a min thickness
public :: DivideSnowLayers ! Subdivide snow layers if they exceed maximum thickness
public :: BuildSnowFilter ! Construct snow/no-snow filters
!
! !PRIVATE MEMBER FUNCTIONS:
private :: Combo ! Returns the combined variables: dz, t, wliq, wice.
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SnowWater
!
! !INTERFACE:
subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & 2,9
num_nosnowc, filter_nosnowc)
!
! !DESCRIPTION:
! Evaluate the change of snow mass and the snow water onto soil.
! Water flow within snow is computed by an explicit and non-physical
! based scheme, which permits a part of liquid water over the holding
! capacity (a tentative value is used, i.e. equal to 0.033*porosity) to
! percolate into the underlying layer. Except for cases where the
! porosity of one of the two neighboring layers is less than 0.05, zero
! flow is assumed. The water flow out of the bottom of the snow pack will
! participate as the input of the soil water and runoff. This subroutine
! uses a filter for columns containing snow which must be constructed prior
! to being called.
!
! !USES:
use clmtype
use clm_varcon , only : denh2o, denice, wimp, ssi
use SNICARMod , only : scvng_fct_mlt_bcphi, scvng_fct_mlt_bcpho, &
scvng_fct_mlt_ocphi, scvng_fct_mlt_ocpho, &
scvng_fct_mlt_dst1, scvng_fct_mlt_dst2, &
scvng_fct_mlt_dst3, scvng_fct_mlt_dst4
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_snowc ! number of snow points in column filter
integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points
integer, intent(in) :: num_nosnowc ! number of non-snow points in column filter
integer, intent(in) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points
!
! !CALLED FROM:
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 15 November 2000: Mariana Vertenstein
! 2/26/02, Peter Thornton: Migrated to new data structures.
! 03/28/08, Mark Flanner: Added aerosol deposition and flushing with meltwater
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: snl(:) !number of snow layers
logical , pointer :: do_capsnow(:) !true => do snow capping
real(r8), pointer :: qflx_snomelt(:) !snow melt (mm H2O /s)
real(r8), pointer :: qflx_rain_grnd(:) !rain on ground after interception (mm H2O/s) [+]
real(r8), pointer :: qflx_sub_snow(:) !sublimation rate from snow pack (mm H2O /s) [+]
real(r8), pointer :: qflx_evap_grnd(:) !ground surface evaporation rate (mm H2O/s) [+]
real(r8), pointer :: qflx_dew_snow(:) !surface dew added to snow pack (mm H2O /s) [+]
real(r8), pointer :: qflx_dew_grnd(:) !ground surface dew formation (mm H2O /s) [+]
real(r8), pointer :: dz(:,:) !layer depth (m)
!
! local pointers to implicit out arguments
!
real(r8), pointer :: qflx_top_soil(:) !net water input into soil from top (mm/s)
!
! local pointers to implicit inout arguments
!
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2)
integer , pointer :: cgridcell(:) ! columns's gridcell (col)
real(r8), pointer :: mss_bcphi(:,:) ! hydrophillic BC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocphi(:,:) ! hydrophillic OC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg]
real(r8), pointer :: flx_bc_dep_dry(:) ! dry BC deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_bc_dep_wet(:) ! wet BC deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_bc_dep(:) ! total BC deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_bc_dep_pho(:) ! hydrophobic BC deposition (col) [kg m-1 s-1]
real(r8), pointer :: flx_bc_dep_phi(:) ! hydrophillic BC deposition (col) [kg m-1 s-1]
real(r8), pointer :: flx_oc_dep_dry(:) ! dry OC deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_oc_dep_wet(:) ! wet OC deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_oc_dep(:) ! total OC deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_oc_dep_pho(:) ! hydrophobic OC deposition (col) [kg m-1 s-1]
real(r8), pointer :: flx_oc_dep_phi(:) ! hydrophillic OC deposition (col) [kg m-1 s-1]
real(r8), pointer :: flx_dst_dep_dry1(:) ! dry dust (species 1) deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_dst_dep_wet1(:) ! wet dust (species 1) deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_dst_dep_dry2(:) ! dry dust (species 2) deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_dst_dep_wet2(:) ! wet dust (species 2) deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_dst_dep_dry3(:) ! dry dust (species 3) deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_dst_dep_wet3(:) ! wet dust (species 3) deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_dst_dep_dry4(:) ! dry dust (species 4) deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_dst_dep_wet4(:) ! wet dust (species 4) deposition (col) [kg m-2 s-1]
real(r8), pointer :: flx_dst_dep(:) ! total dust deposition (col) [kg m-2 s-1]
real(r8), pointer :: forc_aer(:,:) ! aerosol deposition from atmosphere model (grd,aer) [kg m-1 s-1]
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: c, j, fc !do loop/array indices
real(r8) :: qin(lbc:ubc) !water flow into the elmement (mm/s)
real(r8) :: qout(lbc:ubc) !water flow out of the elmement (mm/s)
real(r8) :: wgdif !ice mass after minus sublimation
real(r8) :: vol_liq(lbc:ubc,-nlevsno+1:0) !partial volume of liquid water in layer
real(r8) :: vol_ice(lbc:ubc,-nlevsno+1:0) !partial volume of ice lens in layer
real(r8) :: eff_porosity(lbc:ubc,-nlevsno+1:0) !effective porosity = porosity - vol_ice
integer :: g ! gridcell loop index
real(r8) :: qin_bc_phi(lbc:ubc) ! flux of hydrophilic BC into layer [kg]
real(r8) :: qout_bc_phi(lbc:ubc) ! flux of hydrophilic BC out of layer [kg]
real(r8) :: qin_bc_pho(lbc:ubc) ! flux of hydrophobic BC into layer [kg]
real(r8) :: qout_bc_pho(lbc:ubc) ! flux of hydrophobic BC out of layer [kg]
real(r8) :: qin_oc_phi(lbc:ubc) ! flux of hydrophilic OC into layer [kg]
real(r8) :: qout_oc_phi(lbc:ubc) ! flux of hydrophilic OC out of layer [kg]
real(r8) :: qin_oc_pho(lbc:ubc) ! flux of hydrophobic OC into layer [kg]
real(r8) :: qout_oc_pho(lbc:ubc) ! flux of hydrophobic OC out of layer [kg]
real(r8) :: qin_dst1(lbc:ubc) ! flux of dust species 1 into layer [kg]
real(r8) :: qout_dst1(lbc:ubc) ! flux of dust species 1 out of layer [kg]
real(r8) :: qin_dst2(lbc:ubc) ! flux of dust species 2 into layer [kg]
real(r8) :: qout_dst2(lbc:ubc) ! flux of dust species 2 out of layer [kg]
real(r8) :: qin_dst3(lbc:ubc) ! flux of dust species 3 into layer [kg]
real(r8) :: qout_dst3(lbc:ubc) ! flux of dust species 3 out of layer [kg]
real(r8) :: qin_dst4(lbc:ubc) ! flux of dust species 4 into layer [kg]
real(r8) :: qout_dst4(lbc:ubc) ! flux of dust species 4 out of layer [kg]
real(r8) :: mss_liqice ! mass of liquid+ice in a layer
!-----------------------------------------------------------------------
! Assign local pointers to derived subtype components (column-level)
snl => clm3%g%l%c%cps%snl
do_capsnow => clm3%g%l%c%cps%do_capsnow
qflx_snomelt => clm3%g%l%c%cwf%qflx_snomelt
qflx_rain_grnd => clm3%g%l%c%cwf%pwf_a%qflx_rain_grnd
qflx_sub_snow => clm3%g%l%c%cwf%pwf_a%qflx_sub_snow
qflx_evap_grnd => clm3%g%l%c%cwf%pwf_a%qflx_evap_grnd
qflx_dew_snow => clm3%g%l%c%cwf%pwf_a%qflx_dew_snow
qflx_dew_grnd => clm3%g%l%c%cwf%pwf_a%qflx_dew_grnd
qflx_top_soil => clm3%g%l%c%cwf%qflx_top_soil
dz => clm3%g%l%c%cps%dz
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
cgridcell => clm3%g%l%c%gridcell
mss_bcphi => clm3%g%l%c%cps%mss_bcphi
mss_bcpho => clm3%g%l%c%cps%mss_bcpho
mss_ocphi => clm3%g%l%c%cps%mss_ocphi
mss_ocpho => clm3%g%l%c%cps%mss_ocpho
mss_dst1 => clm3%g%l%c%cps%mss_dst1
mss_dst2 => clm3%g%l%c%cps%mss_dst2
mss_dst3 => clm3%g%l%c%cps%mss_dst3
mss_dst4 => clm3%g%l%c%cps%mss_dst4
flx_bc_dep => clm3%g%l%c%cwf%flx_bc_dep
flx_bc_dep_wet => clm3%g%l%c%cwf%flx_bc_dep_wet
flx_bc_dep_dry => clm3%g%l%c%cwf%flx_bc_dep_dry
flx_bc_dep_phi => clm3%g%l%c%cwf%flx_bc_dep_phi
flx_bc_dep_pho => clm3%g%l%c%cwf%flx_bc_dep_pho
flx_oc_dep => clm3%g%l%c%cwf%flx_oc_dep
flx_oc_dep_wet => clm3%g%l%c%cwf%flx_oc_dep_wet
flx_oc_dep_dry => clm3%g%l%c%cwf%flx_oc_dep_dry
flx_oc_dep_phi => clm3%g%l%c%cwf%flx_oc_dep_phi
flx_oc_dep_pho => clm3%g%l%c%cwf%flx_oc_dep_pho
flx_dst_dep => clm3%g%l%c%cwf%flx_dst_dep
flx_dst_dep_wet1 => clm3%g%l%c%cwf%flx_dst_dep_wet1
flx_dst_dep_dry1 => clm3%g%l%c%cwf%flx_dst_dep_dry1
flx_dst_dep_wet2 => clm3%g%l%c%cwf%flx_dst_dep_wet2
flx_dst_dep_dry2 => clm3%g%l%c%cwf%flx_dst_dep_dry2
flx_dst_dep_wet3 => clm3%g%l%c%cwf%flx_dst_dep_wet3
flx_dst_dep_dry3 => clm3%g%l%c%cwf%flx_dst_dep_dry3
flx_dst_dep_wet4 => clm3%g%l%c%cwf%flx_dst_dep_wet4
flx_dst_dep_dry4 => clm3%g%l%c%cwf%flx_dst_dep_dry4
forc_aer => clm_a2l%forc_aer
! Renew the mass of ice lens (h2osoi_ice) and liquid (h2osoi_liq) in the
! surface snow layer resulting from sublimation (frost) / evaporation (condense)
!dir$ concurrent
!cdir nodep
do fc = 1,num_snowc
c = filter_snowc(fc)
if (do_capsnow(c)) then
wgdif = h2osoi_ice(c,snl(c)+1) - qflx_sub_snow(c)*dtime
h2osoi_ice(c,snl(c)+1) = wgdif
if (wgdif < 0._r8) then
h2osoi_ice(c,snl(c)+1) = 0._r8
h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif
end if
h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) - qflx_evap_grnd(c) * dtime
else
wgdif = h2osoi_ice(c,snl(c)+1) + (qflx_dew_snow(c) - qflx_sub_snow(c)) * dtime
h2osoi_ice(c,snl(c)+1) = wgdif
if (wgdif < 0._r8) then
h2osoi_ice(c,snl(c)+1) = 0._r8
h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif
end if
h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + &
(qflx_rain_grnd(c) + qflx_dew_grnd(c) - qflx_evap_grnd(c)) * dtime
end if
h2osoi_liq(c,snl(c)+1) = max(0._r8, h2osoi_liq(c,snl(c)+1))
end do
! Porosity and partial volume
do j = -nlevsno+1, 0
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j >= snl(c)+1) then
vol_ice(c,j) = min(1._r8, h2osoi_ice(c,j)/(dz(c,j)*denice))
eff_porosity(c,j) = 1._r8 - vol_ice(c,j)
vol_liq(c,j) = min(eff_porosity(c,j),h2osoi_liq(c,j)/(dz(c,j)*denh2o))
end if
end do
end do
! Capillary forces within snow are usually two or more orders of magnitude
! less than those of gravity. Only gravity terms are considered.
! the genernal expression for water flow is "K * ss**3", however,
! no effective parameterization for "K". Thus, a very simple consideration
! (not physically based) is introduced:
! when the liquid water of layer exceeds the layer's holding
! capacity, the excess meltwater adds to the underlying neighbor layer.
! Also compute aerosol fluxes through snowpack in this loop:
! 1) compute aerosol mass in each layer
! 2) add aerosol mass flux from above layer to mass of this layer
! 3) qout_xxx is mass flux of aerosol species xxx out bottom of
! layer in water flow, proportional to (current) concentration
! of aerosol in layer multiplied by a scavenging ratio.
! 4) update mass of aerosol in top layer, accordingly
! 5) update mass concentration of aerosol accordingly
qin(:) = 0._r8
qin_bc_phi(:) = 0._r8
qin_bc_pho(:) = 0._r8
qin_oc_phi(:) = 0._r8
qin_oc_pho(:) = 0._r8
qin_dst1(:) = 0._r8
qin_dst2(:) = 0._r8
qin_dst3(:) = 0._r8
qin_dst4(:) = 0._r8
do j = -nlevsno+1, 0
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j >= snl(c)+1) then
h2osoi_liq(c,j) = h2osoi_liq(c,j) + qin(c)
mss_bcphi(c,j) = mss_bcphi(c,j) + qin_bc_phi(c)
mss_bcpho(c,j) = mss_bcpho(c,j) + qin_bc_pho(c)
mss_ocphi(c,j) = mss_ocphi(c,j) + qin_oc_phi(c)
mss_ocpho(c,j) = mss_ocpho(c,j) + qin_oc_pho(c)
mss_dst1(c,j) = mss_dst1(c,j) + qin_dst1(c)
mss_dst2(c,j) = mss_dst2(c,j) + qin_dst2(c)
mss_dst3(c,j) = mss_dst3(c,j) + qin_dst3(c)
mss_dst4(c,j) = mss_dst4(c,j) + qin_dst4(c)
if (j <= -1) then
! No runoff over snow surface, just ponding on surface
if (eff_porosity(c,j) < wimp .OR. eff_porosity(c,j+1) < wimp) then
qout(c) = 0._r8
else
qout(c) = max(0._r8,(vol_liq(c,j)-ssi*eff_porosity(c,j))*dz(c,j))
qout(c) = min(qout(c),(1._r8-vol_ice(c,j+1)-vol_liq(c,j+1))*dz(c,j+1))
end if
else
qout(c) = max(0._r8,(vol_liq(c,j) - ssi*eff_porosity(c,j))*dz(c,j))
end if
qout(c) = qout(c)*1000._r8
h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(c)
qin(c) = qout(c)
! mass of ice+water: in extremely rare circumstances, this can
! be zero, even though there is a snow layer defined. In
! this case, set the mass to a very small value to
! prevent division by zero.
mss_liqice = h2osoi_liq(c,j)+h2osoi_ice(c,j)
if (mss_liqice < 1E-30_r8) then
mss_liqice = 1E-30_r8
endif
! BCPHI:
! 1. flux with meltwater:
qout_bc_phi(c) = qout(c)*scvng_fct_mlt_bcphi*(mss_bcphi(c,j)/mss_liqice)
if (qout_bc_phi(c) > mss_bcphi(c,j)) then
qout_bc_phi(c) = mss_bcphi(c,j)
endif
mss_bcphi(c,j) = mss_bcphi(c,j) - qout_bc_phi(c)
qin_bc_phi(c) = qout_bc_phi(c)
! BCPHO:
! 1. flux with meltwater:
qout_bc_pho(c) = qout(c)*scvng_fct_mlt_bcpho*(mss_bcpho(c,j)/mss_liqice)
if (qout_bc_pho(c) > mss_bcpho(c,j)) then
qout_bc_pho(c) = mss_bcpho(c,j)
endif
mss_bcpho(c,j) = mss_bcpho(c,j) - qout_bc_pho(c)
qin_bc_pho(c) = qout_bc_pho(c)
! OCPHI:
! 1. flux with meltwater:
qout_oc_phi(c) = qout(c)*scvng_fct_mlt_ocphi*(mss_ocphi(c,j)/mss_liqice)
if (qout_oc_phi(c) > mss_ocphi(c,j)) then
qout_oc_phi(c) = mss_ocphi(c,j)
endif
mss_ocphi(c,j) = mss_ocphi(c,j) - qout_oc_phi(c)
qin_oc_phi(c) = qout_oc_phi(c)
! OCPHO:
! 1. flux with meltwater:
qout_oc_pho(c) = qout(c)*scvng_fct_mlt_ocpho*(mss_ocpho(c,j)/mss_liqice)
if (qout_oc_pho(c) > mss_ocpho(c,j)) then
qout_oc_pho(c) = mss_ocpho(c,j)
endif
mss_ocpho(c,j) = mss_ocpho(c,j) - qout_oc_pho(c)
qin_oc_pho(c) = qout_oc_pho(c)
! DUST 1:
! 1. flux with meltwater:
qout_dst1(c) = qout(c)*scvng_fct_mlt_dst1*(mss_dst1(c,j)/mss_liqice)
if (qout_dst1(c) > mss_dst1(c,j)) then
qout_dst1(c) = mss_dst1(c,j)
endif
mss_dst1(c,j) = mss_dst1(c,j) - qout_dst1(c)
qin_dst1(c) = qout_dst1(c)
! DUST 2:
! 1. flux with meltwater:
qout_dst2(c) = qout(c)*scvng_fct_mlt_dst2*(mss_dst2(c,j)/mss_liqice)
if (qout_dst2(c) > mss_dst2(c,j)) then
qout_dst2(c) = mss_dst2(c,j)
endif
mss_dst2(c,j) = mss_dst2(c,j) - qout_dst2(c)
qin_dst2(c) = qout_dst2(c)
! DUST 3:
! 1. flux with meltwater:
qout_dst3(c) = qout(c)*scvng_fct_mlt_dst3*(mss_dst3(c,j)/mss_liqice)
if (qout_dst3(c) > mss_dst3(c,j)) then
qout_dst3(c) = mss_dst3(c,j)
endif
mss_dst3(c,j) = mss_dst3(c,j) - qout_dst3(c)
qin_dst3(c) = qout_dst3(c)
! DUST 4:
! 1. flux with meltwater:
qout_dst4(c) = qout(c)*scvng_fct_mlt_dst4*(mss_dst4(c,j)/mss_liqice)
if (qout_dst4(c) > mss_dst4(c,j)) then
qout_dst4(c) = mss_dst4(c,j)
endif
mss_dst4(c,j) = mss_dst4(c,j) - qout_dst4(c)
qin_dst4(c) = qout_dst4(c)
end if
end do
end do
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
! Qout from snow bottom
qflx_top_soil(c) = qout(c) / dtime
end do
!dir$ concurrent
!cdir nodep
do fc = 1, num_nosnowc
c = filter_nosnowc(fc)
qflx_top_soil(c) = qflx_rain_grnd(c) + qflx_snomelt(c)
end do
! set aerosol deposition fluxes from forcing array
! The forcing array is either set from an external file
! or from fluxes received from the atmosphere model
do c = lbc,ubc
g = cgridcell(c)
flx_bc_dep_dry(c) = forc_aer(g,1) + forc_aer(g,2)
flx_bc_dep_wet(c) = forc_aer(g,3)
flx_bc_dep_phi(c) = forc_aer(g,1) + forc_aer(g,3)
flx_bc_dep_pho(c) = forc_aer(g,2)
flx_bc_dep(c) = forc_aer(g,1) + forc_aer(g,2) + forc_aer(g,3)
flx_oc_dep_dry(c) = forc_aer(g,4) + forc_aer(g,5)
flx_oc_dep_wet(c) = forc_aer(g,6)
flx_oc_dep_phi(c) = forc_aer(g,4) + forc_aer(g,6)
flx_oc_dep_pho(c) = forc_aer(g,5)
flx_oc_dep(c) = forc_aer(g,4) + forc_aer(g,5) + forc_aer(g,6)
flx_dst_dep_wet1(c) = forc_aer(g,7)
flx_dst_dep_dry1(c) = forc_aer(g,8)
flx_dst_dep_wet2(c) = forc_aer(g,9)
flx_dst_dep_dry2(c) = forc_aer(g,10)
flx_dst_dep_wet3(c) = forc_aer(g,11)
flx_dst_dep_dry3(c) = forc_aer(g,12)
flx_dst_dep_wet4(c) = forc_aer(g,13)
flx_dst_dep_dry4(c) = forc_aer(g,14)
flx_dst_dep(c) = forc_aer(g,7) + forc_aer(g,8) + forc_aer(g,9) + &
forc_aer(g,10) + forc_aer(g,11) + forc_aer(g,12) + &
forc_aer(g,13) + forc_aer(g,14)
end do
! aerosol deposition fluxes into top layer
! This is done after the inter-layer fluxes so that some aerosol
! is in the top layer after deposition, and is not immediately
! washed out before radiative calculations are done
do fc = 1, num_snowc
c = filter_snowc(fc)
mss_bcphi(c,snl(c)+1) = mss_bcphi(c,snl(c)+1) + (flx_bc_dep_phi(c)*dtime)
mss_bcpho(c,snl(c)+1) = mss_bcpho(c,snl(c)+1) + (flx_bc_dep_pho(c)*dtime)
mss_ocphi(c,snl(c)+1) = mss_ocphi(c,snl(c)+1) + (flx_oc_dep_phi(c)*dtime)
mss_ocpho(c,snl(c)+1) = mss_ocpho(c,snl(c)+1) + (flx_oc_dep_pho(c)*dtime)
mss_dst1(c,snl(c)+1) = mss_dst1(c,snl(c)+1) + (flx_dst_dep_dry1(c) + flx_dst_dep_wet1(c))*dtime
mss_dst2(c,snl(c)+1) = mss_dst2(c,snl(c)+1) + (flx_dst_dep_dry2(c) + flx_dst_dep_wet2(c))*dtime
mss_dst3(c,snl(c)+1) = mss_dst3(c,snl(c)+1) + (flx_dst_dep_dry3(c) + flx_dst_dep_wet3(c))*dtime
mss_dst4(c,snl(c)+1) = mss_dst4(c,snl(c)+1) + (flx_dst_dep_dry4(c) + flx_dst_dep_wet4(c))*dtime
end do
end subroutine SnowWater
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: SnowCompaction
!
! !INTERFACE:
subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc) 1,3
!
! !DESCRIPTION:
! Determine the change in snow layer thickness due to compaction and
! settling.
! Three metamorphisms of changing snow characteristics are implemented,
! i.e., destructive, overburden, and melt. The treatments of the former
! two are from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution
! due to melt metamorphism is simply taken as a ratio of snow ice
! fraction after the melting versus before the melting.
!
! !USES:
use clmtype
use clm_varcon , only : denice, denh2o, tfrz
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_snowc ! number of column snow points in column filter
integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points
!
! !CALLED FROM:
! subroutine Hydrology2 in module Hydrology2Mod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 2/28/02, Peter Thornton: Migrated to new data structures
! 2/29/08, David Lawrence: Revised snow overburden to be include 0.5 weight of current layer
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in scalars
!
integer, pointer :: snl(:) !number of snow layers
!
! local pointers to implicit in arguments
!
integer, pointer :: imelt(:,:) !flag for melting (=1), freezing (=2), Not=0
real(r8), pointer :: frac_iceold(:,:) !fraction of ice relative to the tot water
real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin)
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2)
!
! local pointers to implicit inout arguments
!
real(r8), pointer :: dz(:,:) !layer depth (m)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: j, c, fc ! indices
real(r8), parameter :: c2 = 23.e-3_r8 ! [m3/kg]
real(r8), parameter :: c3 = 2.777e-6_r8 ! [1/s]
real(r8), parameter :: c4 = 0.04_r8 ! [1/K]
real(r8), parameter :: c5 = 2.0_r8 !
real(r8), parameter :: dm = 100.0_r8 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3]
real(r8), parameter :: eta0 = 9.e+5_r8 ! The Viscosity Coefficient Eta0 [kg-s/m2]
real(r8) :: burden(lbc:ubc) ! pressure of overlying snow [kg/m2]
real(r8) :: ddz1 ! Rate of settling of snowpack due to destructive metamorphism.
real(r8) :: ddz2 ! Rate of compaction of snowpack due to overburden.
real(r8) :: ddz3 ! Rate of compaction of snowpack due to melt [1/s]
real(r8) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)).
real(r8) :: fi ! Fraction of ice relative to the total water content at current time step
real(r8) :: td ! t_soisno - tfrz [K]
real(r8) :: pdzdtc ! Nodal rate of change in fractional-thickness due to compaction [fraction/s]
real(r8) :: void ! void (1 - vol_ice - vol_liq)
real(r8) :: wx ! water mass (ice+liquid) [kg/m2]
real(r8) :: bi ! partial density of ice [kg/m3]
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes (column-level)
snl => clm3%g%l%c%cps%snl
dz => clm3%g%l%c%cps%dz
imelt => clm3%g%l%c%cps%imelt
frac_iceold => clm3%g%l%c%cps%frac_iceold
t_soisno => clm3%g%l%c%ces%t_soisno
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
! Begin calculation - note that the following column loops are only invoked if snl(c) < 0
burden(:) = 0._r8
do j = -nlevsno+1, 0
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j >= snl(c)+1) then
wx = h2osoi_ice(c,j) + h2osoi_liq(c,j)
void = 1._r8 - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o) / dz(c,j)
! Allow compaction only for non-saturated node and higher ice lens node.
if (void > 0.001_r8 .and. h2osoi_ice(c,j) > .1_r8) then
bi = h2osoi_ice(c,j) / dz(c,j)
fi = h2osoi_ice(c,j) / wx
td = tfrz-t_soisno(c,j)
dexpf = exp(-c4*td)
! Settling as a result of destructive metamorphism
ddz1 = -c3*dexpf
if (bi > dm) ddz1 = ddz1*exp(-46.0e-3_r8*(bi-dm))
! Liquid water term
if (h2osoi_liq(c,j) > 0.01_r8*dz(c,j)) ddz1=ddz1*c5
! Compaction due to overburden
ddz2 = -(burden(c)+wx/2._r8)*exp(-0.08_r8*td - c2*bi)/eta0
! Compaction occurring during melt
if (imelt(c,j) == 1) then
ddz3 = - 1._r8/dtime * max(0._r8,(frac_iceold(c,j) - fi)/frac_iceold(c,j))
else
ddz3 = 0._r8
end if
! Time rate of fractional change in dz (units of s-1)
pdzdtc = ddz1 + ddz2 + ddz3
! The change in dz due to compaction
dz(c,j) = dz(c,j) * (1._r8+pdzdtc*dtime)
end if
! Pressure of overlying snow
burden(c) = burden(c) + wx
end if
end do
end do
end subroutine SnowCompaction
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CombineSnowLayers
!
! !INTERFACE:
subroutine CombineSnowLayers(lbc, ubc, num_snowc, filter_snowc) 1,4
!
! !DESCRIPTION:
! Combine snow layers that are less than a minimum thickness or mass
! If the snow element thickness or mass is less than a prescribed minimum,
! then it is combined with a neighboring element. The subroutine
! clm\_combo.f90 then executes the combination of mass and energy.
!
! !USES:
use clmtype
use clm_varcon, only : istsoil, isturb
#ifdef CROP
use clm_varcon, only : istcrop
#endif
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(inout) :: num_snowc ! number of column snow points in column filter
integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points
!
! !CALLED FROM:
! subroutine Hydrology2 in module Hydrology2Mod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 2/28/02, Peter Thornton: Migrated to new data structures.
! 03/28/08, Mark Flanner: Added aerosol masses and snow grain radius
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer, pointer :: clandunit(:) !landunit index for each column
integer, pointer :: ltype(:) !landunit type
!
! local pointers to implicit inout arguments
!
integer , pointer :: snl(:) !number of snow layers
real(r8), pointer :: h2osno(:) !snow water (mm H2O)
real(r8), pointer :: snowdp(:) !snow height (m)
real(r8), pointer :: dz(:,:) !layer depth (m)
real(r8), pointer :: zi(:,:) !interface level below a "z" level (m)
real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin)
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2)
!
! local pointers to implicit out arguments
!
real(r8), pointer :: z(:,:) ! layer thickness (m)
real(r8), pointer :: mss_bcphi(:,:) ! hydrophilic BC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocphi(:,:) ! hydrophilic OC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst1(:,:) ! dust species 1 mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst2(:,:) ! dust species 2 mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst3(:,:) ! dust species 3 mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst4(:,:) ! dust species 4 mass in snow (col,lyr) [kg]
real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6]
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: c, fc ! column indices
integer :: i,k ! loop indices
integer :: j,l ! node indices
integer :: msn_old(lbc:ubc) ! number of top snow layer
integer :: mssi(lbc:ubc) ! node index
integer :: neibor ! adjacent node selected for combination
real(r8):: zwice(lbc:ubc) ! total ice mass in snow
real(r8):: zwliq (lbc:ubc) ! total liquid water in snow
real(r8):: dzmin(5) ! minimum of top snow layer
data dzmin /0.010_r8, 0.015_r8, 0.025_r8, 0.055_r8, 0.115_r8/
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes (landunit-level)
ltype => clm3%g%l%itype
! Assign local pointers to derived subtypes (column-level)
clandunit => clm3%g%l%c%landunit
snl => clm3%g%l%c%cps%snl
snowdp => clm3%g%l%c%cps%snowdp
h2osno => clm3%g%l%c%cws%h2osno
dz => clm3%g%l%c%cps%dz
zi => clm3%g%l%c%cps%zi
z => clm3%g%l%c%cps%z
t_soisno => clm3%g%l%c%ces%t_soisno
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
mss_bcphi => clm3%g%l%c%cps%mss_bcphi
mss_bcpho => clm3%g%l%c%cps%mss_bcpho
mss_ocphi => clm3%g%l%c%cps%mss_ocphi
mss_ocpho => clm3%g%l%c%cps%mss_ocpho
mss_dst1 => clm3%g%l%c%cps%mss_dst1
mss_dst2 => clm3%g%l%c%cps%mss_dst2
mss_dst3 => clm3%g%l%c%cps%mss_dst3
mss_dst4 => clm3%g%l%c%cps%mss_dst4
snw_rds => clm3%g%l%c%cps%snw_rds
! Check the mass of ice lens of snow, when the total is less than a small value,
! combine it with the underlying neighbor.
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
msn_old(c) = snl(c)
end do
! The following loop is NOT VECTORIZED
do fc = 1, num_snowc
c = filter_snowc(fc)
l = clandunit(c)
do j = msn_old(c)+1,0
if (h2osoi_ice(c,j) <= .1_r8) then
#ifndef CROP
if (ltype(l) == istsoil .or. ltype(l)==isturb) then
#else
if (ltype(l) == istsoil .or. ltype(l)==isturb .or. ltype(l) == istcrop) then
#endif
h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j)
h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j)
! NOTE: Temperature, and similarly snw_rds, of the
! underlying snow layer are NOT adjusted in this case.
! Because the layer being eliminated has a small mass,
! this should not make a large difference, but it
! would be more thorough to do so.
if (j /= 0) then
mss_bcphi(c,j+1) = mss_bcphi(c,j+1) + mss_bcphi(c,j)
mss_bcpho(c,j+1) = mss_bcpho(c,j+1) + mss_bcpho(c,j)
mss_ocphi(c,j+1) = mss_ocphi(c,j+1) + mss_ocphi(c,j)
mss_ocpho(c,j+1) = mss_ocpho(c,j+1) + mss_ocpho(c,j)
mss_dst1(c,j+1) = mss_dst1(c,j+1) + mss_dst1(c,j)
mss_dst2(c,j+1) = mss_dst2(c,j+1) + mss_dst2(c,j)
mss_dst3(c,j+1) = mss_dst3(c,j+1) + mss_dst3(c,j)
mss_dst4(c,j+1) = mss_dst4(c,j+1) + mss_dst4(c,j)
end if
#ifndef CROP
else if (ltype(l) /= istsoil .and. ltype(l) /= isturb .and. j /= 0) then
#else
else if (ltype(l) /= istsoil .and. ltype(l) /= isturb .and. ltype(l) /= istcrop .and. j /= 0) then
#endif
h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j)
h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j)
mss_bcphi(c,j+1) = mss_bcphi(c,j+1) + mss_bcphi(c,j)
mss_bcpho(c,j+1) = mss_bcpho(c,j+1) + mss_bcpho(c,j)
mss_ocphi(c,j+1) = mss_ocphi(c,j+1) + mss_ocphi(c,j)
mss_ocpho(c,j+1) = mss_ocpho(c,j+1) + mss_ocpho(c,j)
mss_dst1(c,j+1) = mss_dst1(c,j+1) + mss_dst1(c,j)
mss_dst2(c,j+1) = mss_dst2(c,j+1) + mss_dst2(c,j)
mss_dst3(c,j+1) = mss_dst3(c,j+1) + mss_dst3(c,j)
mss_dst4(c,j+1) = mss_dst4(c,j+1) + mss_dst4(c,j)
end if
! shift all elements above this down one.
if (j > snl(c)+1 .and. snl(c) < -1) then
do i = j, snl(c)+2, -1
t_soisno(c,i) = t_soisno(c,i-1)
h2osoi_liq(c,i) = h2osoi_liq(c,i-1)
h2osoi_ice(c,i) = h2osoi_ice(c,i-1)
mss_bcphi(c,i) = mss_bcphi(c,i-1)
mss_bcpho(c,i) = mss_bcpho(c,i-1)
mss_ocphi(c,i) = mss_ocphi(c,i-1)
mss_ocpho(c,i) = mss_ocpho(c,i-1)
mss_dst1(c,i) = mss_dst1(c,i-1)
mss_dst2(c,i) = mss_dst2(c,i-1)
mss_dst3(c,i) = mss_dst3(c,i-1)
mss_dst4(c,i) = mss_dst4(c,i-1)
snw_rds(c,i) = snw_rds(c,i-1)
dz(c,i) = dz(c,i-1)
end do
end if
snl(c) = snl(c) + 1
end if
end do
end do
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
h2osno(c) = 0._r8
snowdp(c) = 0._r8
zwice(c) = 0._r8
zwliq(c) = 0._r8
end do
do j = -nlevsno+1,0
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j >= snl(c)+1) then
h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
snowdp(c) = snowdp(c) + dz(c,j)
zwice(c) = zwice(c) + h2osoi_ice(c,j)
zwliq(c) = zwliq(c) + h2osoi_liq(c,j)
end if
end do
end do
! Check the snow depth - all snow gone
! The liquid water assumes ponding on soil surface.
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
l = clandunit(c)
if (snowdp(c) < 0.01_r8 .and. snowdp(c) > 0._r8) then
snl(c) = 0
h2osno(c) = zwice(c)
mss_bcphi(c,:) = 0._r8
mss_bcpho(c,:) = 0._r8
mss_ocphi(c,:) = 0._r8
mss_ocpho(c,:) = 0._r8
mss_dst1(c,:) = 0._r8
mss_dst2(c,:) = 0._r8
mss_dst3(c,:) = 0._r8
mss_dst4(c,:) = 0._r8
if (h2osno(c) <= 0._r8) snowdp(c) = 0._r8
#ifndef CROP
if (ltype(l) == istsoil .or. ltype(l) == isturb) then
#else
if (ltype(l) == istsoil .or. ltype(l) == isturb .or. ltype(l) == istcrop) then
#endif
h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(c)
end if
end if
end do
! Check the snow depth - snow layers combined
! The following loop IS NOT VECTORIZED
do fc = 1, num_snowc
c = filter_snowc(fc)
! Two or more layers
if (snl(c) < -1) then
msn_old(c) = snl(c)
mssi(c) = 1
do i = msn_old(c)+1,0
if (dz(c,i) < dzmin(mssi(c))) then
if (i == snl(c)+1) then
! If top node is removed, combine with bottom neighbor.
neibor = i + 1
else if (i == 0) then
! If the bottom neighbor is not snow, combine with the top neighbor.
neibor = i - 1
else
! If none of the above special cases apply, combine with the thinnest neighbor
neibor = i + 1
if ((dz(c,i-1)+dz(c,i)) < (dz(c,i+1)+dz(c,i))) neibor = i-1
end if
! Node l and j are combined and stored as node j.
if (neibor > i) then
j = neibor
l = i
else
j = i
l = neibor
end if
! this should be included in 'Combo' for consistency,
! but functionally it is the same to do it here
mss_bcphi(c,j)=mss_bcphi(c,j)+mss_bcphi(c,l)
mss_bcpho(c,j)=mss_bcpho(c,j)+mss_bcpho(c,l)
mss_ocphi(c,j)=mss_ocphi(c,j)+mss_ocphi(c,l)
mss_ocpho(c,j)=mss_ocpho(c,j)+mss_ocpho(c,l)
mss_dst1(c,j)=mss_dst1(c,j)+mss_dst1(c,l)
mss_dst2(c,j)=mss_dst2(c,j)+mss_dst2(c,l)
mss_dst3(c,j)=mss_dst3(c,j)+mss_dst3(c,l)
mss_dst4(c,j)=mss_dst4(c,j)+mss_dst4(c,l)
! mass-weighted combination of effective grain size:
snw_rds(c,j) = (snw_rds(c,j)*(h2osoi_liq(c,j)+h2osoi_ice(c,j)) + &
snw_rds(c,l)*(h2osoi_liq(c,l)+h2osoi_ice(c,l))) / &
(h2osoi_liq(c,j)+h2osoi_ice(c,j)+h2osoi_liq(c,l)+h2osoi_ice(c,l))
call Combo (dz(c,j), h2osoi_liq(c,j), h2osoi_ice(c,j), &
t_soisno(c,j), dz(c,l), h2osoi_liq(c,l), h2osoi_ice(c,l), t_soisno(c,l) )
! Now shift all elements above this down one.
if (j-1 > snl(c)+1) then
do k = j-1, snl(c)+2, -1
t_soisno(c,k) = t_soisno(c,k-1)
h2osoi_ice(c,k) = h2osoi_ice(c,k-1)
h2osoi_liq(c,k) = h2osoi_liq(c,k-1)
mss_bcphi(c,k) = mss_bcphi(c,k-1)
mss_bcpho(c,k) = mss_bcpho(c,k-1)
mss_ocphi(c,k) = mss_ocphi(c,k-1)
mss_ocpho(c,k) = mss_ocpho(c,k-1)
mss_dst1(c,k) = mss_dst1(c,k-1)
mss_dst2(c,k) = mss_dst2(c,k-1)
mss_dst3(c,k) = mss_dst3(c,k-1)
mss_dst4(c,k) = mss_dst4(c,k-1)
snw_rds(c,k) = snw_rds(c,k-1)
dz(c,k) = dz(c,k-1)
end do
end if
! Decrease the number of snow layers
snl(c) = snl(c) + 1
if (snl(c) >= -1) EXIT
else
! The layer thickness is greater than the prescribed minimum value
mssi(c) = mssi(c) + 1
end if
end do
end if
end do
! Reset the node depth and the depth of layer interface
do j = 0, -nlevsno+1, -1
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j >= snl(c) + 1) then
z(c,j) = zi(c,j) - 0.5_r8*dz(c,j)
zi(c,j-1) = zi(c,j) - dz(c,j)
end if
end do
end do
end subroutine CombineSnowLayers
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: DivideSnowLayers
!
! !INTERFACE:
subroutine DivideSnowLayers(lbc, ubc, num_snowc, filter_snowc) 1,6
!
! !DESCRIPTION:
! Subdivides snow layers if they exceed their prescribed maximum thickness.
!
! !USES:
use clmtype
use clm_varcon, only : tfrz
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(inout) :: num_snowc ! number of column snow points in column filter
integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points
!
! !CALLED FROM:
! subroutine Hydrology2 in module Hydrology2Mod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 2/28/02, Peter Thornton: Migrated to new data structures.
! 2/29/08, David Lawrence: Snowpack T profile maintained during layer splitting
! 03/28/08, Mark Flanner: Added aerosol masses and snow grain radius
!
! !LOCAL VARIABLES:
!
! local pointers to implicit inout arguments
!
integer , pointer :: snl(:) !number of snow layers
real(r8), pointer :: dz(:,:) !layer depth (m)
real(r8), pointer :: zi(:,:) !interface level below a "z" level (m)
real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin)
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2)
!
! local pointers to implicit out arguments
!
real(r8), pointer :: z(:,:) ! layer thickness (m)
real(r8), pointer :: mss_bcphi(:,:) ! hydrophilic BC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_bcpho(:,:) ! hydrophobic BC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocphi(:,:) ! hydrophilic OC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocpho(:,:) ! hydrophobic OC mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst1(:,:) ! dust species 1 mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst2(:,:) ! dust species 2 mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst3(:,:) ! dust species 3 mass in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst4(:,:) ! dust species 4 mass in snow (col,lyr) [kg]
real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6]
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: j, c, fc ! indices
real(r8) :: drr ! thickness of the combined [m]
integer :: msno ! number of snow layer 1 (top) to msno (bottom)
real(r8) :: dzsno(lbc:ubc,nlevsno) ! Snow layer thickness [m]
real(r8) :: swice(lbc:ubc,nlevsno) ! Partial volume of ice [m3/m3]
real(r8) :: swliq(lbc:ubc,nlevsno) ! Partial volume of liquid water [m3/m3]
real(r8) :: tsno(lbc:ubc ,nlevsno) ! Nodel temperature [K]
real(r8) :: zwice ! temporary
real(r8) :: zwliq ! temporary
real(r8) :: propor ! temporary
real(r8) :: dtdz ! temporary
! temporary variables mimicking the structure of other layer division variables
real(r8) :: mbc_phi(lbc:ubc,nlevsno) ! mass of BC in each snow layer
real(r8) :: zmbc_phi ! temporary
real(r8) :: mbc_pho(lbc:ubc,nlevsno) ! mass of BC in each snow layer
real(r8) :: zmbc_pho ! temporary
real(r8) :: moc_phi(lbc:ubc,nlevsno) ! mass of OC in each snow layer
real(r8) :: zmoc_phi ! temporary
real(r8) :: moc_pho(lbc:ubc,nlevsno) ! mass of OC in each snow layer
real(r8) :: zmoc_pho ! temporary
real(r8) :: mdst1(lbc:ubc,nlevsno) ! mass of dust 1 in each snow layer
real(r8) :: zmdst1 ! temporary
real(r8) :: mdst2(lbc:ubc,nlevsno) ! mass of dust 2 in each snow layer
real(r8) :: zmdst2 ! temporary
real(r8) :: mdst3(lbc:ubc,nlevsno) ! mass of dust 3 in each snow layer
real(r8) :: zmdst3 ! temporary
real(r8) :: mdst4(lbc:ubc,nlevsno) ! mass of dust 4 in each snow layer
real(r8) :: zmdst4 ! temporary
real(r8) :: rds(lbc:ubc,nlevsno)
!-----------------------------------------------------------------------
! Assign local pointers to derived subtype components (column-level)
snl => clm3%g%l%c%cps%snl
dz => clm3%g%l%c%cps%dz
zi => clm3%g%l%c%cps%zi
z => clm3%g%l%c%cps%z
t_soisno => clm3%g%l%c%ces%t_soisno
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
mss_bcphi => clm3%g%l%c%cps%mss_bcphi
mss_bcpho => clm3%g%l%c%cps%mss_bcpho
mss_ocphi => clm3%g%l%c%cps%mss_ocphi
mss_ocpho => clm3%g%l%c%cps%mss_ocpho
mss_dst1 => clm3%g%l%c%cps%mss_dst1
mss_dst2 => clm3%g%l%c%cps%mss_dst2
mss_dst3 => clm3%g%l%c%cps%mss_dst3
mss_dst4 => clm3%g%l%c%cps%mss_dst4
snw_rds => clm3%g%l%c%cps%snw_rds
! Begin calculation - note that the following column loops are only invoked
! for snow-covered columns
do j = 1,nlevsno
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j <= abs(snl(c))) then
dzsno(c,j) = dz(c,j+snl(c))
swice(c,j) = h2osoi_ice(c,j+snl(c))
swliq(c,j) = h2osoi_liq(c,j+snl(c))
tsno(c,j) = t_soisno(c,j+snl(c))
mbc_phi(c,j) = mss_bcphi(c,j+snl(c))
mbc_pho(c,j) = mss_bcpho(c,j+snl(c))
moc_phi(c,j) = mss_ocphi(c,j+snl(c))
moc_pho(c,j) = mss_ocpho(c,j+snl(c))
mdst1(c,j) = mss_dst1(c,j+snl(c))
mdst2(c,j) = mss_dst2(c,j+snl(c))
mdst3(c,j) = mss_dst3(c,j+snl(c))
mdst4(c,j) = mss_dst4(c,j+snl(c))
rds(c,j) = snw_rds(c,j+snl(c))
end if
end do
end do
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
msno = abs(snl(c))
if (msno == 1) then
! Specify a new snow layer
if (dzsno(c,1) > 0.03_r8) then
msno = 2
dzsno(c,1) = dzsno(c,1)/2._r8
swice(c,1) = swice(c,1)/2._r8
swliq(c,1) = swliq(c,1)/2._r8
dzsno(c,2) = dzsno(c,1)
swice(c,2) = swice(c,1)
swliq(c,2) = swliq(c,1)
tsno(c,2) = tsno(c,1)
mbc_phi(c,1) = mbc_phi(c,1)/2._r8
mbc_phi(c,2) = mbc_phi(c,1)
mbc_pho(c,1) = mbc_pho(c,1)/2._r8
mbc_pho(c,2) = mbc_pho(c,1)
moc_phi(c,1) = moc_phi(c,1)/2._r8
moc_phi(c,2) = moc_phi(c,1)
moc_pho(c,1) = moc_pho(c,1)/2._r8
moc_pho(c,2) = moc_pho(c,1)
mdst1(c,1) = mdst1(c,1)/2._r8
mdst1(c,2) = mdst1(c,1)
mdst2(c,1) = mdst2(c,1)/2._r8
mdst2(c,2) = mdst2(c,1)
mdst3(c,1) = mdst3(c,1)/2._r8
mdst3(c,2) = mdst3(c,1)
mdst4(c,1) = mdst4(c,1)/2._r8
mdst4(c,2) = mdst4(c,1)
rds(c,2) = rds(c,1)
end if
end if
if (msno > 1) then
if (dzsno(c,1) > 0.02_r8) then
drr = dzsno(c,1) - 0.02_r8
propor = drr/dzsno(c,1)
zwice = propor*swice(c,1)
zwliq = propor*swliq(c,1)
zmbc_phi = propor*mbc_phi(c,1)
zmbc_pho = propor*mbc_pho(c,1)
zmoc_phi = propor*moc_phi(c,1)
zmoc_pho = propor*moc_pho(c,1)
zmdst1 = propor*mdst1(c,1)
zmdst2 = propor*mdst2(c,1)
zmdst3 = propor*mdst3(c,1)
zmdst4 = propor*mdst4(c,1)
propor = 0.02_r8/dzsno(c,1)
swice(c,1) = propor*swice(c,1)
swliq(c,1) = propor*swliq(c,1)
mbc_phi(c,1) = propor*mbc_phi(c,1)
mbc_pho(c,1) = propor*mbc_pho(c,1)
moc_phi(c,1) = propor*moc_phi(c,1)
moc_pho(c,1) = propor*moc_pho(c,1)
mdst1(c,1) = propor*mdst1(c,1)
mdst2(c,1) = propor*mdst2(c,1)
mdst3(c,1) = propor*mdst3(c,1)
mdst4(c,1) = propor*mdst4(c,1)
dzsno(c,1) = 0.02_r8
mbc_phi(c,2) = mbc_phi(c,2)+zmbc_phi ! (combo)
mbc_pho(c,2) = mbc_pho(c,2)+zmbc_pho ! (combo)
moc_phi(c,2) = moc_phi(c,2)+zmoc_phi ! (combo)
moc_pho(c,2) = moc_pho(c,2)+zmoc_pho ! (combo)
mdst1(c,2) = mdst1(c,2)+zmdst1 ! (combo)
mdst2(c,2) = mdst2(c,2)+zmdst2 ! (combo)
mdst3(c,2) = mdst3(c,2)+zmdst3 ! (combo)
mdst4(c,2) = mdst4(c,2)+zmdst4 ! (combo)
rds(c,2) = rds(c,1) ! (combo)
call Combo (dzsno(c,2), swliq(c,2), swice(c,2), tsno(c,2), drr, &
zwliq, zwice, tsno(c,1))
! Subdivide a new layer
if (msno <= 2 .and. dzsno(c,2) > 0.07_r8) then
msno = 3
dtdz = (tsno(c,1) - tsno(c,2))/((dzsno(c,1)+dzsno(c,2))/2._r8)
dzsno(c,2) = dzsno(c,2)/2._r8
swice(c,2) = swice(c,2)/2._r8
swliq(c,2) = swliq(c,2)/2._r8
dzsno(c,3) = dzsno(c,2)
swice(c,3) = swice(c,2)
swliq(c,3) = swliq(c,2)
tsno(c,3) = tsno(c,2) - dtdz*dzsno(c,2)/2._r8
if (tsno(c,3) >= tfrz) then
tsno(c,3) = tsno(c,2)
else
tsno(c,2) = tsno(c,2) + dtdz*dzsno(c,2)/2._r8
endif
mbc_phi(c,2) = mbc_phi(c,2)/2._r8
mbc_phi(c,3) = mbc_phi(c,2)
mbc_pho(c,2) = mbc_pho(c,2)/2._r8
mbc_pho(c,3) = mbc_pho(c,2)
moc_phi(c,2) = moc_phi(c,2)/2._r8
moc_phi(c,3) = moc_phi(c,2)
moc_pho(c,2) = moc_pho(c,2)/2._r8
moc_pho(c,3) = moc_pho(c,2)
mdst1(c,2) = mdst1(c,2)/2._r8
mdst1(c,3) = mdst1(c,2)
mdst2(c,2) = mdst2(c,2)/2._r8
mdst2(c,3) = mdst2(c,2)
mdst3(c,2) = mdst3(c,2)/2._r8
mdst3(c,3) = mdst3(c,2)
mdst4(c,2) = mdst4(c,2)/2._r8
mdst4(c,3) = mdst4(c,2)
rds(c,3) = rds(c,2)
end if
end if
end if
if (msno > 2) then
if (dzsno(c,2) > 0.05_r8) then
drr = dzsno(c,2) - 0.05_r8
propor = drr/dzsno(c,2)
zwice = propor*swice(c,2)
zwliq = propor*swliq(c,2)
zmbc_phi = propor*mbc_phi(c,2)
zmbc_pho = propor*mbc_pho(c,2)
zmoc_phi = propor*moc_phi(c,2)
zmoc_pho = propor*moc_pho(c,2)
zmdst1 = propor*mdst1(c,2)
zmdst2 = propor*mdst2(c,2)
zmdst3 = propor*mdst3(c,2)
zmdst4 = propor*mdst4(c,2)
propor = 0.05_r8/dzsno(c,2)
swice(c,2) = propor*swice(c,2)
swliq(c,2) = propor*swliq(c,2)
mbc_phi(c,2) = propor*mbc_phi(c,2)
mbc_pho(c,2) = propor*mbc_pho(c,2)
moc_phi(c,2) = propor*moc_phi(c,2)
moc_pho(c,2) = propor*moc_pho(c,2)
mdst1(c,2) = propor*mdst1(c,2)
mdst2(c,2) = propor*mdst2(c,2)
mdst3(c,2) = propor*mdst3(c,2)
mdst4(c,2) = propor*mdst4(c,2)
dzsno(c,2) = 0.05_r8
mbc_phi(c,3) = mbc_phi(c,3)+zmbc_phi ! (combo)
mbc_pho(c,3) = mbc_pho(c,3)+zmbc_pho ! (combo)
moc_phi(c,3) = moc_phi(c,3)+zmoc_phi ! (combo)
moc_pho(c,3) = moc_pho(c,3)+zmoc_pho ! (combo)
mdst1(c,3) = mdst1(c,3)+zmdst1 ! (combo)
mdst2(c,3) = mdst2(c,3)+zmdst2 ! (combo)
mdst3(c,3) = mdst3(c,3)+zmdst3 ! (combo)
mdst4(c,3) = mdst4(c,3)+zmdst4 ! (combo)
rds(c,3) = rds(c,2) ! (combo)
call Combo (dzsno(c,3), swliq(c,3), swice(c,3), tsno(c,3), drr, &
zwliq, zwice, tsno(c,2))
! Subdivided a new layer
if (msno <= 3 .and. dzsno(c,3) > 0.18_r8) then
msno = 4
dtdz = (tsno(c,2) - tsno(c,3))/((dzsno(c,2)+dzsno(c,3))/2._r8)
dzsno(c,3) = dzsno(c,3)/2._r8
swice(c,3) = swice(c,3)/2._r8
swliq(c,3) = swliq(c,3)/2._r8
dzsno(c,4) = dzsno(c,3)
swice(c,4) = swice(c,3)
swliq(c,4) = swliq(c,3)
tsno(c,4) = tsno(c,3) - dtdz*dzsno(c,3)/2._r8
if (tsno(c,4) >= tfrz) then
tsno(c,4) = tsno(c,3)
else
tsno(c,3) = tsno(c,3) + dtdz*dzsno(c,3)/2._r8
endif
mbc_phi(c,3) = mbc_phi(c,3)/2._r8
mbc_phi(c,4) = mbc_phi(c,3)
mbc_pho(c,3) = mbc_pho(c,3)/2._r8
mbc_pho(c,4) = mbc_pho(c,3)
moc_phi(c,3) = moc_phi(c,3)/2._r8
moc_phi(c,4) = moc_phi(c,3)
moc_pho(c,3) = moc_pho(c,3)/2._r8
moc_pho(c,4) = moc_pho(c,3)
mdst1(c,3) = mdst1(c,3)/2._r8
mdst1(c,4) = mdst1(c,3)
mdst2(c,3) = mdst2(c,3)/2._r8
mdst2(c,4) = mdst2(c,3)
mdst3(c,3) = mdst3(c,3)/2._r8
mdst3(c,4) = mdst3(c,3)
mdst4(c,3) = mdst4(c,3)/2._r8
mdst4(c,4) = mdst4(c,3)
rds(c,4) = rds(c,3)
end if
end if
end if
if (msno > 3) then
if (dzsno(c,3) > 0.11_r8) then
drr = dzsno(c,3) - 0.11_r8
propor = drr/dzsno(c,3)
zwice = propor*swice(c,3)
zwliq = propor*swliq(c,3)
zmbc_phi = propor*mbc_phi(c,3)
zmbc_pho = propor*mbc_pho(c,3)
zmoc_phi = propor*moc_phi(c,3)
zmoc_pho = propor*moc_pho(c,3)
zmdst1 = propor*mdst1(c,3)
zmdst2 = propor*mdst2(c,3)
zmdst3 = propor*mdst3(c,3)
zmdst4 = propor*mdst4(c,3)
propor = 0.11_r8/dzsno(c,3)
swice(c,3) = propor*swice(c,3)
swliq(c,3) = propor*swliq(c,3)
mbc_phi(c,3) = propor*mbc_phi(c,3)
mbc_pho(c,3) = propor*mbc_pho(c,3)
moc_phi(c,3) = propor*moc_phi(c,3)
moc_pho(c,3) = propor*moc_pho(c,3)
mdst1(c,3) = propor*mdst1(c,3)
mdst2(c,3) = propor*mdst2(c,3)
mdst3(c,3) = propor*mdst3(c,3)
mdst4(c,3) = propor*mdst4(c,3)
dzsno(c,3) = 0.11_r8
mbc_phi(c,4) = mbc_phi(c,4)+zmbc_phi ! (combo)
mbc_pho(c,4) = mbc_pho(c,4)+zmbc_pho ! (combo)
moc_phi(c,4) = moc_phi(c,4)+zmoc_phi ! (combo)
moc_pho(c,4) = moc_pho(c,4)+zmoc_pho ! (combo)
mdst1(c,4) = mdst1(c,4)+zmdst1 ! (combo)
mdst2(c,4) = mdst2(c,4)+zmdst2 ! (combo)
mdst3(c,4) = mdst3(c,4)+zmdst3 ! (combo)
mdst4(c,4) = mdst4(c,4)+zmdst4 ! (combo)
rds(c,4) = rds(c,3) ! (combo)
call Combo (dzsno(c,4), swliq(c,4), swice(c,4), tsno(c,4), drr, &
zwliq, zwice, tsno(c,3))
! Subdivided a new layer
if (msno <= 4 .and. dzsno(c,4) > 0.41_r8) then
msno = 5
dtdz = (tsno(c,3) - tsno(c,4))/((dzsno(c,3)+dzsno(c,4))/2._r8)
dzsno(c,4) = dzsno(c,4)/2._r8
swice(c,4) = swice(c,4)/2._r8
swliq(c,4) = swliq(c,4)/2._r8
dzsno(c,5) = dzsno(c,4)
swice(c,5) = swice(c,4)
swliq(c,5) = swliq(c,4)
tsno(c,5) = tsno(c,4) - dtdz*dzsno(c,4)/2._r8
if (tsno(c,5) >= tfrz) then
tsno(c,5) = tsno(c,4)
else
tsno(c,4) = tsno(c,4) + dtdz*dzsno(c,4)/2._r8
endif
mbc_phi(c,4) = mbc_phi(c,4)/2._r8
mbc_phi(c,5) = mbc_phi(c,4)
mbc_pho(c,4) = mbc_pho(c,4)/2._r8
mbc_pho(c,5) = mbc_pho(c,4)
moc_phi(c,4) = moc_phi(c,4)/2._r8
moc_phi(c,5) = moc_phi(c,4)
moc_pho(c,4) = moc_pho(c,4)/2._r8
moc_pho(c,5) = moc_pho(c,4)
mdst1(c,4) = mdst1(c,4)/2._r8
mdst1(c,5) = mdst1(c,4)
mdst2(c,4) = mdst2(c,4)/2._r8
mdst2(c,5) = mdst2(c,4)
mdst3(c,4) = mdst3(c,4)/2._r8
mdst3(c,5) = mdst3(c,4)
mdst4(c,4) = mdst4(c,4)/2._r8
mdst4(c,5) = mdst4(c,4)
rds(c,5) = rds(c,4)
end if
end if
end if
if (msno > 4) then
if (dzsno(c,4) > 0.23_r8) then
drr = dzsno(c,4) - 0.23_r8
propor = drr/dzsno(c,4)
zwice = propor*swice(c,4)
zwliq = propor*swliq(c,4)
zmbc_phi = propor*mbc_phi(c,4)
zmbc_pho = propor*mbc_pho(c,4)
zmoc_phi = propor*moc_phi(c,4)
zmoc_pho = propor*moc_pho(c,4)
zmdst1 = propor*mdst1(c,4)
zmdst2 = propor*mdst2(c,4)
zmdst3 = propor*mdst3(c,4)
zmdst4 = propor*mdst4(c,4)
propor = 0.23_r8/dzsno(c,4)
swice(c,4) = propor*swice(c,4)
swliq(c,4) = propor*swliq(c,4)
mbc_phi(c,4) = propor*mbc_phi(c,4)
mbc_pho(c,4) = propor*mbc_pho(c,4)
moc_phi(c,4) = propor*moc_phi(c,4)
moc_pho(c,4) = propor*moc_pho(c,4)
mdst1(c,4) = propor*mdst1(c,4)
mdst2(c,4) = propor*mdst2(c,4)
mdst3(c,4) = propor*mdst3(c,4)
mdst4(c,4) = propor*mdst4(c,4)
dzsno(c,4) = 0.23_r8
mbc_phi(c,5) = mbc_phi(c,5)+zmbc_phi ! (combo)
mbc_pho(c,5) = mbc_pho(c,5)+zmbc_pho ! (combo)
moc_phi(c,5) = moc_phi(c,5)+zmoc_phi ! (combo)
moc_pho(c,5) = moc_pho(c,5)+zmoc_pho ! (combo)
mdst1(c,5) = mdst1(c,5)+zmdst1 ! (combo)
mdst2(c,5) = mdst2(c,5)+zmdst2 ! (combo)
mdst3(c,5) = mdst3(c,5)+zmdst3 ! (combo)
mdst4(c,5) = mdst4(c,5)+zmdst4 ! (combo)
rds(c,5) = rds(c,4) ! (combo)
call Combo (dzsno(c,5), swliq(c,5), swice(c,5), tsno(c,5), drr, &
zwliq, zwice, tsno(c,4))
end if
end if
snl(c) = -msno
end do
do j = -nlevsno+1,0
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j >= snl(c)+1) then
dz(c,j) = dzsno(c,j-snl(c))
h2osoi_ice(c,j) = swice(c,j-snl(c))
h2osoi_liq(c,j) = swliq(c,j-snl(c))
t_soisno(c,j) = tsno(c,j-snl(c))
mss_bcphi(c,j) = mbc_phi(c,j-snl(c))
mss_bcpho(c,j) = mbc_pho(c,j-snl(c))
mss_ocphi(c,j) = moc_phi(c,j-snl(c))
mss_ocpho(c,j) = moc_pho(c,j-snl(c))
mss_dst1(c,j) = mdst1(c,j-snl(c))
mss_dst2(c,j) = mdst2(c,j-snl(c))
mss_dst3(c,j) = mdst3(c,j-snl(c))
mss_dst4(c,j) = mdst4(c,j-snl(c))
snw_rds(c,j) = rds(c,j-snl(c))
end if
end do
end do
do j = 0, -nlevsno+1, -1
!dir$ concurrent
!cdir nodep
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j >= snl(c)+1) then
z(c,j) = zi(c,j) - 0.5_r8*dz(c,j)
zi(c,j-1) = zi(c,j) - dz(c,j)
end if
end do
end do
end subroutine DivideSnowLayers
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: Combo
!
! !INTERFACE:
subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) 12,1
!
! !DESCRIPTION:
! Combines two elements and returns the following combined
! variables: dz, t, wliq, wice.
! The combined temperature is based on the equation:
! the sum of the enthalpies of the two elements =
! that of the combined element.
!
! !USES:
use clm_varcon, only : cpice, cpliq, tfrz, hfus
!
! !ARGUMENTS:
implicit none
real(r8), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m]
real(r8), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2]
real(r8), intent(in) :: wice2 ! ice of element 2 [kg/m2]
real(r8), intent(in) :: t2 ! nodal temperature of element 2 [K]
real(r8), intent(inout) :: dz ! nodal thickness of 1 elements being combined [m]
real(r8), intent(inout) :: wliq ! liquid water of element 1
real(r8), intent(inout) :: wice ! ice of element 1 [kg/m2]
real(r8), intent(inout) :: t ! nodel temperature of elment 1 [K]
!
! !CALLED FROM:
! subroutine CombineSnowLayers in this module
! subroutine DivideSnowLayers in this module
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
!
!
! !LOCAL VARIABLES:
!EOP
!
real(r8) :: dzc ! Total thickness of nodes 1 and 2 (dzc=dz+dz2).
real(r8) :: wliqc ! Combined liquid water [kg/m2]
real(r8) :: wicec ! Combined ice [kg/m2]
real(r8) :: tc ! Combined node temperature [K]
real(r8) :: h ! enthalpy of element 1 [J/m2]
real(r8) :: h2 ! enthalpy of element 2 [J/m2]
real(r8) :: hc ! temporary
!-----------------------------------------------------------------------
dzc = dz+dz2
wicec = (wice+wice2)
wliqc = (wliq+wliq2)
h = (cpice*wice+cpliq*wliq) * (t-tfrz)+hfus*wliq
h2= (cpice*wice2+cpliq*wliq2) * (t2-tfrz)+hfus*wliq2
hc = h + h2
tc = tfrz + (hc - hfus*wliqc) / (cpice*wicec + cpliq*wliqc)
dz = dzc
wice = wicec
wliq = wliqc
t = tc
end subroutine Combo
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: BuildSnowFilter
!
! !INTERFACE:
subroutine BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec, & 2,1
num_snowc, filter_snowc, &
num_nosnowc, filter_nosnowc)
!
! !DESCRIPTION:
! Constructs snow filter for use in vectorized loops for snow hydrology.
!
! !USES:
use clmtype
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
integer, intent(out) :: num_snowc ! number of column snow points in column filter
integer, intent(out) :: filter_snowc(ubc-lbc+1) ! column filter for snow points
integer, intent(out) :: num_nosnowc ! number of column non-snow points in column filter
integer, intent(out) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points
!
! !CALLED FROM:
! subroutine Hydrology2 in Hydrology2Mod
! subroutine CombineSnowLayers in this module
!
! !REVISION HISTORY:
! 2003 July 31: Forrest Hoffman
!
! !LOCAL VARIABLES:
! local pointers to implicit in arguments
integer , pointer :: snl(:) ! number of snow layers
!
!
! !OTHER LOCAL VARIABLES:
!EOP
integer :: fc, c
!-----------------------------------------------------------------------
! Assign local pointers to derived subtype components (column-level)
snl => clm3%g%l%c%cps%snl
! Build snow/no-snow filters for other subroutines
num_snowc = 0
num_nosnowc = 0
do fc = 1, num_nolakec
c = filter_nolakec(fc)
if (snl(c) < 0) then
num_snowc = num_snowc + 1
filter_snowc(num_snowc) = c
else
num_nosnowc = num_nosnowc + 1
filter_nosnowc(num_nosnowc) = c
end if
end do
end subroutine BuildSnowFilter
end module SnowHydrologyMod
module STATICEcosysdynMOD 3,3
!#if (!defined DGVM)
#if (!defined CN)
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: STATICEcosysDynMod
!
! !DESCRIPTION:
! Static Ecosystem dynamics: phenology, vegetation.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use decompMod , only : get_proc_bounds
use module_cam_support, only: endrun
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: EcosystemDyn ! Ecosystem dynamics: phenology, vegetation
public :: EcosystemDynini ! Dynamically allocate memory
public :: interpMonthlyVeg ! interpolate monthly vegetation data
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!
! !PRIVATE MEMBER FUNCTIONS:
private :: readMonthlyVegetation ! read monthly vegetation data for two months
!
! PRIVATE TYPES:
integer , private :: InterpMonths1 ! saved month index
real(r8), private :: timwt(2) ! time weights for month 1 and month 2
real(r8), allocatable :: mlai1(:) ! lai for interpolation (month 1)
real(r8), allocatable :: mlai2(:) ! lai for interpolation (month 2)
real(r8), allocatable :: msai1(:) ! sai for interpolation (month 1)
real(r8), allocatable :: msai2(:) ! sai for interpolation (month 2)
real(r8), allocatable :: mhvt1(:) ! top vegetation height for interpolation (month 1)
real(r8), allocatable :: mhvt2(:) ! top vegetation height for interpolation (month 2)
real(r8), allocatable :: mhvb1(:) ! bottom vegetation height for interpolation(month 1)
real(r8), allocatable :: mhvb2(:) ! bottom vegetation height for interpolation(month 2)
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: EcosystemDynini
!
! !INTERFACE:
subroutine EcosystemDynini () 1,4
!
! !DESCRIPTION:
! Dynamically allocate memory and set to signaling NaN.
!
! !USES:
use nanMod
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
!
!EOP
!
! LOCAL VARIABLES:
integer :: ier ! error code
integer :: begg
integer :: endg
integer :: begl
integer :: endl
integer :: begc
integer :: endc
integer :: begp
integer :: endp
!-----------------------------------------------------------------------
InterpMonths1 = -999 ! saved month index
! begg,begl,begc,begp are all equal to 1
call get_proc_bounds (begg, endg, begl, endl, begc, endc, begp, endp)
ier = 0
if(.not.allocated(mlai1)) allocate (mlai1(begp:endp))
if(.not.allocated(mlai2)) allocate (mlai2(begp:endp))
if(.not.allocated(msai1)) allocate (msai1(begp:endp))
if(.not.allocated(msai2)) allocate (msai2(begp:endp))
if(.not.allocated(mhvt1)) allocate (mhvt1(begp:endp))
if(.not.allocated(mhvt2)) allocate (mhvt2(begp:endp))
if(.not.allocated(mhvb1)) allocate (mhvb1(begp:endp))
if(.not.allocated(mhvb2)) allocate (mhvb2(begp:endp))
! if(.not.allocated(mlai1))allocate (mlai1(endp), mlai2(endp), &
! msai1(endp), msai2(endp), &
! mhvt1(endp), mhvt2(endp), &
! mhvb1(endp), mhvb2(endp), stat=ier)
if (ier /= 0) then
write (6,*) 'EcosystemDynini allocation error'
call endrun
end if
call CLMDebug('EcosystemDynini mark1')
mlai1(:) = nan
mlai2(:) = nan
msai1(:) = nan
msai2(:) = nan
mhvt1(:) = nan
mhvt2(:) = nan
mhvb1(:) = nan
mhvb2(:) = nan
end subroutine EcosystemDynini
!-----------------------------------------------------------------------
!
! !IROUTINE: EcosystemDyn
!
! !INTERFACE:
subroutine EcosystemDyn(lbp, ubp, num_nolakep, filter_nolakep, doalb) 3,1
!
! !DESCRIPTION:
! Ecosystem dynamics: phenology, vegetation
! Calculates leaf areas (tlai, elai), stem areas (tsai, esai) and
! height (htop).
!
! !USES:
use clmtype
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbp, ubp ! pft bounds
integer, intent(in) :: num_nolakep ! number of column non-lake points in pft filter
integer, intent(in) :: filter_nolakep(ubp-lbp+1) ! pft filter for non-lake points
logical, intent(in) :: doalb ! true = surface albedo calculation time step
!
! !CALLED FROM:
!
! !REVISION HISTORY:
! Author: Gordon Bonan
! 2/1/02, Peter Thornton: Migrated to new data structure.
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: pcolumn(:) ! column index associated with each pft
real(r8), pointer :: snowdp(:) ! snow height (m)
!
! local pointers to implicit out arguments
!
real(r8), pointer :: tlai(:) ! one-sided leaf area index, no burying by snow
real(r8), pointer :: tsai(:) ! one-sided stem area index, no burying by snow
real(r8), pointer :: htop(:) ! canopy top (m)
real(r8), pointer :: hbot(:) ! canopy bottom (m)
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) ! one-sided stem area index with burying by snow
integer , pointer :: frac_veg_nosno_alb(:) ! frac of vegetation not covered by snow [-]
!
!EOP
!
! !OTHER LOCAL VARIABLES:
!
integer :: fp,p,c ! indices
real(r8) :: ol ! thickness of canopy layer covered by snow (m)
real(r8) :: fb ! fraction of canopy layer covered by snow
!-----------------------------------------------------------------------
if (doalb) then
! Assign local pointers to derived type scalar members (column-level)
snowdp => clm3%g%l%c%cps%snowdp
! Assign local pointers to derived type scalar members (pftlevel)
pcolumn => clm3%g%l%c%p%column
tlai => clm3%g%l%c%p%pps%tlai
tsai => clm3%g%l%c%p%pps%tsai
elai => clm3%g%l%c%p%pps%elai
esai => clm3%g%l%c%p%pps%esai
htop => clm3%g%l%c%p%pps%htop
hbot => clm3%g%l%c%p%pps%hbot
frac_veg_nosno_alb => clm3%g%l%c%p%pps%frac_veg_nosno_alb
!dir$ concurrent
!cdir nodep
do fp = 1, num_nolakep
p = filter_nolakep(fp)
c = pcolumn(p)
! need to update elai and esai only every albedo time step so do not
! have any inconsistency in lai and sai between SurfaceAlbedo calls (i.e.,
! if albedos are not done every time step).
! leaf phenology
! Set leaf and stem areas based on day of year
! Interpolate leaf area index, stem area index, and vegetation heights
! between two monthly
! The weights below (timwt(1) and timwt(2)) were obtained by a call to
! routine InterpMonthlyVeg in subroutine NCARlsm.
! Field Monthly Values
! -------------------------
! leaf area index LAI <- mlai1 and mlai2
! leaf area index SAI <- msai1 and msai2
! top height HTOP <- mhvt1 and mhvt2
! bottom height HBOT <- mhvb1 and mhvb2
tlai(p) = timwt(1)*mlai1(p) + timwt(2)*mlai2(p)
tsai(p) = timwt(1)*msai1(p) + timwt(2)*msai2(p)
htop(p) = timwt(1)*mhvt1(p) + timwt(2)*mhvt2(p)
hbot(p) = timwt(1)*mhvb1(p) + timwt(2)*mhvb2(p)
! adjust lai and sai for burying by snow. if exposed lai and sai
! are less than 0.05, set equal to zero to prevent numerical
! problems associated with very small lai and sai.
ol = min( max(snowdp(c)-hbot(p), 0._r8), htop(p)-hbot(p))
fb = 1. - ol / max(1.e-06_r8, htop(p)-hbot(p))
elai(p) = max(tlai(p)*fb, 0.0_r8)
esai(p) = max(tsai(p)*fb, 0.0_r8)
if (elai(p) < 0.05) elai(p) = 0._r8
if (esai(p) < 0.05) esai(p) = 0._r8
! Fraction of vegetation free of snow
if ((elai(p) + esai(p)) >= 0.05) then
frac_veg_nosno_alb(p) = 1
else
frac_veg_nosno_alb(p) = 0
end if
end do ! end of pft loop
end if !end of if-doalb block
end subroutine EcosystemDyn
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: interpMonthlyVeg
!
! !INTERFACE:
subroutine interpMonthlyVeg (kmo, kda) 2,2
!
! !DESCRIPTION:
! Determine if 2 new months of data are to be read.
!
! !USES:
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!
! LOCAL VARIABLES:
integer :: kyr ! year (0, ...) for nstep+1
integer :: kmo ! month (1, ..., 12)
integer :: kda ! day of month (1, ..., 31)
integer :: ksec ! seconds into current date for nstep+1
real(r8):: dtime ! land model time step (sec)
real(r8):: t ! a fraction: kda/ndaypm
integer :: it(2) ! month 1 and month 2 (step 1)
integer :: months(2) ! months to be interpolated (1 to 12)
integer, dimension(12) :: ndaypm= &
(/31,28,31,30,31,30,31,31,30,31,30,31/) !days per month
!-----------------------------------------------------------------------
t = (kda-0.5) / ndaypm(kmo)
it(1) = t + 0.5
it(2) = it(1) + 1
months(1) = kmo + it(1) - 1
months(2) = kmo + it(2) - 1
if (months(1) < 1) months(1) = 12
if (months(2) > 12) months(2) = 1
timwt(1) = (it(1)+0.5) - t
timwt(2) = 1.-timwt(1)
call CLMDebug(' call readMonthlyVegetation')
call readMonthlyVegetation(kmo, kda, months)
end subroutine interpMonthlyVeg
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: readMonthlyVegetation
!
! !INTERFACE:
! subroutine readMonthlyVegetation (kmo, kda, months)
subroutine readMonthlyVegetation(kmo, kda, months) 1,13
!
! !DESCRIPTION:
! Read monthly vegetation data for two consec. months.
!
! !USES:
use clmtype
use clm_varpar , only : lsmlon, lsmlat, maxpatch_pft, maxpatch, numpft
use clm_varcon , only: hvt, hvb ,lai,sai
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: kmo ! month (1, ..., 12)
integer, intent(in) :: kda ! day of month (1, ..., 31)
integer, intent(in) :: months(2) ! months to be interpolated (1 to 12)
!
! !REVISION HISTORY:
! Created by Sam Levis
!
!EOP
!
! LOCAL VARIABLES:
integer :: i,j,k,l,m,p,ivt ! indices
integer :: begg
integer :: endg
integer :: begl
integer :: endl
integer :: begc
integer :: endc
integer :: begp
integer :: endp
integer :: ier ! error code
!-----------------------------------------------------------------------
! begg,begl,begc,begp are all equal to 1
call get_proc_bounds (begg, endg, begl, endl, begc, endc, begp, endp)
do k=1,2
do p = begp, endp
! i = clm3%g%l%c%p%ixy(p)
! j = clm3%g%l%c%p%jxy(p)
m = clm3%g%l%c%p%mxy(p)
ivt = clm3%g%l%c%p%itype(p)
call CLMDebug('mark1')
! Assign lai/sai/hgtt/hgtb to the top [maxpatch_pft] pfts
! as determined in subroutine surfrd
if((m <= maxpatch_pft.and.ivt/=0).or.ivt==15.or.ivt==16)then!vegetated pft
! if(ivt/=0.or.ivt==15.or.ivt==16)then!vegetated pft
if (k == 1) then
call CLMDebug('if (k == 1) m1')
mlai1(p) = lai(ivt,months(k))
msai1(p) = sai(ivt,months(k))
mhvt1(p) = hvt(ivt)
mhvb1(p) = hvb(ivt)
else !if (k == 2)
call CLMDebug('else m1')
mlai2(p) = lai(ivt,months(k))
msai2(p) = sai(ivt,months(k))
mhvt2(p) = hvt(ivt)
mhvb2(p) = hvb(ivt)
end if
else
call CLMDebug('non vegetated') ! non-vegetated pft
if (k == 1) then
call CLMDebug('if (k == 1) m2')
call CLMDebug('test')
mlai1(p) = 0_r8
msai1(p) = 0_r8
mhvt1(p) = 0_r8
call CLMDebug('mhvb1(p)')
mhvb1(p) = 0_r8
else !if (k == 2)
call CLMDebug('else m2')
mlai2(p) = 0.
msai2(p) = 0.
mhvt2(p) = 0.
mhvb2(p) = 0.
end if
end if
end do ! end of loop over pfts
end do ! end of loop over months
call CLMDebug('done readMonthlyVegetation')
end subroutine readMonthlyVegetation
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: EcosystemDyn_dealloc
!
! !INTERFACE:
subroutine EcosystemDyn_dealloc () 1
!
implicit none
!
!EOP
!-----------------------------------------------------------------------
if(allocated(mlai1)) deallocate (mlai1)
if(allocated(mlai2)) deallocate (mlai2)
if(allocated(msai1)) deallocate (msai1)
if(allocated(msai2)) deallocate (msai2)
if(allocated(mhvt1)) deallocate (mhvt1)
if(allocated(mhvt2)) deallocate (mhvt2)
if(allocated(mhvb1)) deallocate (mhvb1)
if(allocated(mhvb2)) deallocate (mhvb2)
end subroutine EcosystemDyn_dealloc
#endif
end module STATICEcosysDynMod
module HydrologyLakeMod 1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: HydrologyLakeMod
!
! !DESCRIPTION:
! Calculate lake hydrology
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: HydrologyLake
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: HydrologyLake
!
! !INTERFACE:
subroutine HydrologyLake(lbp, ubp, num_lakep, filter_lakep) 1,4
!
! !DESCRIPTION:
! Calculate lake hydrology
!
! WARNING: This subroutine assumes lake columns have one and only one pft.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype
use clm_varcon , only : hfus, tfrz, spval
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbp, ubp ! pft-index bounds
integer, intent(in) :: num_lakep ! number of pft non-lake points in pft filter
integer, intent(in) :: filter_lakep(ubp-lbp+1) ! pft filter for non-lake points
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! Author: Gordon Bonan
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 3/4/02: Peter Thornton; Migrated to new data structures.
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arrays
!
integer , pointer :: pcolumn(:) !pft's column index
integer , pointer :: pgridcell(:) !pft's gridcell index
real(r8), pointer :: begwb(:) !water mass begining of the time step
real(r8), pointer :: forc_snow(:) !snow rate [mm/s]
real(r8), pointer :: forc_rain(:) !rain rate [mm/s]
logical , pointer :: do_capsnow(:) !true => do snow capping
real(r8), pointer :: t_grnd(:) !ground temperature (Kelvin)
real(r8), pointer :: qmelt(:) !snow melt [mm/s]
real(r8), pointer :: qflx_evap_soi(:) !soil evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_evap_tot(:) !qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
!
! local pointers to implicit inout arrays
!
real(r8), pointer :: h2osno(:) !snow water (mm H2O)
!
! local pointers to implicit out arrays
!
real(r8), pointer :: endwb(:) !water mass end of the time step
real(r8), pointer :: snowdp(:) !snow height (m)
real(r8), pointer :: snowice(:) !average snow ice lens
real(r8), pointer :: snowliq(:) !average snow liquid water
real(r8), pointer :: eflx_snomelt(:) !snow melt heat flux (W/m**2)
real(r8), pointer :: qflx_infl(:) !infiltration (mm H2O /s)
real(r8), pointer :: qflx_snomelt(:) !snow melt (mm H2O /s)
real(r8), pointer :: qflx_surf(:) !surface runoff (mm H2O /s)
real(r8), pointer :: qflx_drain(:) !sub-surface runoff (mm H2O /s)
real(r8), pointer :: qflx_qrgwl(:) !qflx_surf at glaciers, wetlands, lakes
real(r8), pointer :: qflx_runoff(:) !total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s)
real(r8), pointer :: qflx_snwcp_ice(:)!excess snowfall due to snow capping (mm H2O /s) [+]`
real(r8), pointer :: qflx_evap_tot_col(:) !pft quantity averaged to the column (assuming one pft)
real(r8) ,pointer :: soilalpha(:) !factor that reduces ground saturated specific humidity (-)
real(r8), pointer :: zwt(:) !water table depth
real(r8), pointer :: fcov(:) !fractional impermeable area
real(r8), pointer :: fsat(:) !fractional area with water table at surface
real(r8), pointer :: qcharge(:) !aquifer recharge rate (mm/s)
!
! local pointers to implicit out multi-level arrays
!
real(r8), pointer :: rootr_column(:,:) !effective fraction of roots in each soil layer
real(r8), pointer :: h2osoi_vol(:,:) !volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3]
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
real(r8), parameter :: snow_bd = 250._r8 !constant snow bulk density
integer :: fp, p, c, g ! indices
real(r8) :: qflx_evap_grnd ! ground surface evaporation rate (mm h2o/s)
real(r8) :: qflx_dew_grnd ! ground surface dew formation (mm h2o /s) [+]
real(r8) :: qflx_sub_snow ! sublimation rate from snow pack (mm h2o /s) [+]
real(r8) :: qflx_dew_snow ! surface dew added to snow pack (mm h2o /s) [+]
!-----------------------------------------------------------------------
! Assign local pointers to derived type gridcell members
forc_snow => clm_a2l%forc_snow
forc_rain => clm_a2l%forc_rain
! Assign local pointers to derived type column members
begwb => clm3%g%l%c%cwbal%begwb
endwb => clm3%g%l%c%cwbal%endwb
do_capsnow => clm3%g%l%c%cps%do_capsnow
snowdp => clm3%g%l%c%cps%snowdp
t_grnd => clm3%g%l%c%ces%t_grnd
h2osno => clm3%g%l%c%cws%h2osno
snowice => clm3%g%l%c%cws%snowice
snowliq => clm3%g%l%c%cws%snowliq
eflx_snomelt => clm3%g%l%c%cef%eflx_snomelt
qmelt => clm3%g%l%c%cwf%qmelt
qflx_snomelt => clm3%g%l%c%cwf%qflx_snomelt
qflx_surf => clm3%g%l%c%cwf%qflx_surf
qflx_qrgwl => clm3%g%l%c%cwf%qflx_qrgwl
qflx_runoff => clm3%g%l%c%cwf%qflx_runoff
qflx_snwcp_ice => clm3%g%l%c%cwf%pwf_a%qflx_snwcp_ice
qflx_drain => clm3%g%l%c%cwf%qflx_drain
qflx_infl => clm3%g%l%c%cwf%qflx_infl
rootr_column => clm3%g%l%c%cps%rootr_column
h2osoi_vol => clm3%g%l%c%cws%h2osoi_vol
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
qflx_evap_tot_col => clm3%g%l%c%cwf%pwf_a%qflx_evap_tot
soilalpha => clm3%g%l%c%cws%soilalpha
zwt => clm3%g%l%c%cws%zwt
fcov => clm3%g%l%c%cws%fcov
fsat => clm3%g%l%c%cws%fsat
qcharge => clm3%g%l%c%cws%qcharge
! Assign local pointers to derived type pft members
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
qflx_evap_soi => clm3%g%l%c%p%pwf%qflx_evap_soi
qflx_evap_tot => clm3%g%l%c%p%pwf%qflx_evap_tot
do fp = 1, num_lakep
p = filter_lakep(fp)
c = pcolumn(p)
g = pgridcell(p)
! Snow on the lake ice
! Note that these are only local variables, as per the original
! Hydrology_Lake code. So even though these names correspond to
! variables in clmtype, this routine is not updating the
! values of the clmtype variables. (PET, 3/4/02)
qflx_evap_grnd = 0._r8
qflx_sub_snow = 0._r8
qflx_dew_snow = 0._r8
qflx_dew_grnd = 0._r8
if (qflx_evap_soi(p) >= 0._r8) then
! Sublimation: do not allow for more sublimation than there is snow
! after melt. Remaining surface evaporation used for infiltration.
qflx_sub_snow = min(qflx_evap_soi(p), h2osno(c)/dtime-qmelt(c))
qflx_evap_grnd = qflx_evap_soi(p) - qflx_sub_snow
else
if (t_grnd(c) < tfrz-0.1_r8) then
qflx_dew_snow = abs(qflx_evap_soi(p))
else
qflx_dew_grnd = abs(qflx_evap_soi(p))
end if
end if
! Update snow pack
if (do_capsnow(c)) then
h2osno(c) = h2osno(c) - (qmelt(c) + qflx_sub_snow)*dtime
qflx_snwcp_ice(c) = forc_snow(g) + qflx_dew_snow
else
h2osno(c) = h2osno(c) + (forc_snow(g)-qmelt(c)-qflx_sub_snow+qflx_dew_snow)*dtime
qflx_snwcp_ice(c) = 0._r8
end if
h2osno(c) = max(h2osno(c), 0._r8)
#if (defined PERGRO)
if (abs(h2osno(c)) < 1.e-10_r8) h2osno(c) = 0._r8
#else
h2osno(c) = max(h2osno(c), 0._r8)
#endif
! No snow if lake unfrozen
if (t_grnd(c) > tfrz) h2osno(c) = 0._r8
! Snow depth
snowdp(c) = h2osno(c)/snow_bd !Assume a constant snow bulk density = 250.
! Determine ending water balance
endwb(c) = h2osno(c)
! The following are needed for global average on history tape.
! Note that components that are not displayed over lake on history tape
! must be set to spval here
eflx_snomelt(c) = qmelt(c)*hfus
qflx_infl(c) = 0._r8
qflx_snomelt(c) = qmelt(c)
qflx_surf(c) = 0._r8
qflx_drain(c) = 0._r8
rootr_column(c,:) = spval
snowice(c) = spval
snowliq(c) = spval
soilalpha(c) = spval
zwt(c) = spval
fcov(c) = spval
fsat(c) = spval
qcharge(c) = spval
h2osoi_vol(c,:) = spval
h2osoi_ice(c,:) = spval
h2osoi_liq(c,:) = spval
qflx_qrgwl(c) = forc_rain(g) + forc_snow(g) - qflx_evap_tot(p) - qflx_snwcp_ice(c) - &
(endwb(c)-begwb(c))/dtime
qflx_runoff(c) = qflx_drain(c) + qflx_surf(c) + qflx_qrgwl(c)
! The pft average must be done here for output to history tape
qflx_evap_tot_col(c) = qflx_evap_tot(p)
end do
end subroutine HydrologyLake
end module HydrologyLakeMod
module Hydrology1Mod 1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: Hydrology1Mod
!
! !DESCRIPTION:
! Calculation of
! (1) water storage of intercepted precipitation
! (2) direct throughfall and canopy drainage of precipitation
! (3) the fraction of foliage covered by water and the fraction
! of foliage that is dry and transpiring.
! (4) snow layer initialization if the snow accumulation exceeds 10 mm.
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: Hydrology1
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: Hydrology1
!
! !INTERFACE:
subroutine Hydrology1(lbc, ubc, lbp, ubp, num_nolakec, filter_nolakec, & 1,10
num_nolakep, filter_nolakep)
!
! !DESCRIPTION:
! Calculation of
! (1) water storage of intercepted precipitation
! (2) direct throughfall and canopy drainage of precipitation
! (3) the fraction of foliage covered by water and the fraction
! of foliage that is dry and transpiring.
! (4) snow layer initialization if the snow accumulation exceeds 10 mm.
! Note: The evaporation loss is taken off after the calculation of leaf
! temperature in the subroutine clm\_leaftem.f90, not in this subroutine.
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use clm_varcon , only : tfrz, istice, istwet, istsoil, isturb, &
icol_roof, icol_sunwall, icol_shadewall
#ifdef CROP
use clm_varcon , only : istcrop
#endif
use FracWetMod , only : FracWet
use subgridAveMod, only : p2c
use SNICARMod , only : snw_rds_min
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbp, ubp ! pft bounds
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
integer, intent(in) :: num_nolakep ! number of pft non-lake points in pft filter
integer, intent(in) :: filter_nolakep(ubp-lbp+1) ! pft filter for non-lake points
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 2/15/02, Peter Thornton: Migrated to new data structures. Required
! adding a PFT loop.
! 4/26/05, Peter Thornton: Made the canopy interception factor fpi max=0.25
! the default behavior
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in arrays
!
integer , pointer :: cgridcell(:) ! columns's gridcell
integer , pointer :: clandunit(:) ! columns's landunit
integer , pointer :: pgridcell(:) ! pft's gridcell
integer , pointer :: plandunit(:) ! pft's landunit
integer , pointer :: pcolumn(:) ! pft's column
integer , pointer :: npfts(:) ! number of pfts in column
integer , pointer :: pfti(:) ! column's beginning pft index
integer , pointer :: ltype(:) ! landunit type
integer , pointer :: ctype(:) ! column type
real(r8), pointer :: forc_rain(:) ! rain rate [mm/s]
real(r8), pointer :: forc_snow(:) ! snow rate [mm/s]
real(r8), pointer :: forc_t(:) ! atmospheric temperature (Kelvin)
logical , pointer :: do_capsnow(:) ! true => do snow capping
real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin)
real(r8), pointer :: dewmx(:) ! Maximum allowed dew [mm]
integer , pointer :: frac_veg_nosno(:) ! fraction of veg not covered by snow (0/1 now) [-]
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) ! one-sided stem area index with burying by snow
real(r8), pointer :: h2ocan_loss(:) ! canopy water mass balance term (column)
!
! local pointers to original implicit inout arrays
!
integer , pointer :: snl(:) ! number of snow layers
real(r8), pointer :: snowdp(:) ! snow height (m)
real(r8), pointer :: h2osno(:) ! snow water (mm H2O)
real(r8), pointer :: h2ocan(:) ! total canopy water (mm H2O)
!
! local pointers to original implicit out arrays
!
real(r8), pointer :: qflx_prec_intr(:) ! interception of precipitation [mm/s]
real(r8), pointer :: qflx_prec_grnd(:) ! water onto ground including canopy runoff [kg/(m2 s)]
real(r8), pointer :: qflx_snwcp_liq(:) ! excess rainfall due to snow capping (mm H2O /s) [+]
real(r8), pointer :: qflx_snwcp_ice(:) ! excess snowfall due to snow capping (mm H2O /s) [+]
real(r8), pointer :: qflx_snow_grnd_pft(:) ! snow on ground after interception (mm H2O/s) [+]
real(r8), pointer :: qflx_snow_grnd_col(:) ! snow on ground after interception (mm H2O/s) [+]
real(r8), pointer :: qflx_rain_grnd(:) ! rain on ground after interception (mm H2O/s) [+]
real(r8), pointer :: fwet(:) ! fraction of canopy that is wet (0 to 1)
real(r8), pointer :: fdry(:) ! fraction of foliage that is green and dry [-] (new)
real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m)
real(r8), pointer :: dz(:,:) ! layer depth (m)
real(r8), pointer :: z(:,:) ! layer thickness (m)
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin)
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
real(r8), pointer :: frac_iceold(:,:) ! fraction of ice relative to the tot water
real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6]
real(r8), pointer :: mss_bcpho(:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bcphi(:,:) ! mass of hydrophilic BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bctot(:,:) ! total mass of BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bc_col(:) ! total column mass of BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bc_top(:) ! total top-layer mass of BC (col,lyr) [kg]
real(r8), pointer :: mss_ocpho(:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocphi(:,:) ! mass of hydrophilic OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_octot(:,:) ! total mass of OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_oc_col(:) ! total column mass of OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_oc_top(:) ! total top-layer mass of OC (col,lyr) [kg]
real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dsttot(:,:) ! total mass of dust in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst_col(:) ! total column mass of dust in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst_top(:) ! total top-layer mass of dust in snow (col,lyr) [kg]
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: f ! filter index
integer :: pi ! pft index
integer :: p ! pft index
integer :: c ! column index
integer :: l ! landunit index
integer :: g ! gridcell index
integer :: newnode ! flag when new snow node is set, (1=yes, 0=no)
real(r8) :: h2ocanmx ! maximum allowed water on canopy [mm]
real(r8) :: fpi ! coefficient of interception
real(r8) :: xrun ! excess water that exceeds the leaf capacity [mm/s]
real(r8) :: dz_snowf ! layer thickness rate change due to precipitation [mm/s]
real(r8) :: bifall ! bulk density of newly fallen dry snow [kg/m3]
real(r8) :: fracsnow(lbp:ubp) ! frac of precipitation that is snow
real(r8) :: fracrain(lbp:ubp) ! frac of precipitation that is rain
real(r8) :: qflx_candrip(lbp:ubp) ! rate of canopy runoff and snow falling off canopy [mm/s]
real(r8) :: qflx_through_rain(lbp:ubp) ! direct rain throughfall [mm/s]
real(r8) :: qflx_through_snow(lbp:ubp) ! direct snow throughfall [mm/s]
real(r8) :: qflx_prec_grnd_snow(lbp:ubp) ! snow precipitation incident on ground [mm/s]
real(r8) :: qflx_prec_grnd_rain(lbp:ubp) ! rain precipitation incident on ground [mm/s]
!-----------------------------------------------------------------------
! Assign local pointers to derived type members (gridcell-level)
pgridcell => clm3%g%l%c%p%gridcell
forc_rain => clm_a2l%forc_rain
forc_snow => clm_a2l%forc_snow
forc_t => clm_a2l%forc_t
! Assign local pointers to derived type members (landunit-level)
ltype => clm3%g%l%itype
! Assign local pointers to derived type members (column-level)
cgridcell => clm3%g%l%c%gridcell
clandunit => clm3%g%l%c%landunit
ctype => clm3%g%l%c%itype
pfti => clm3%g%l%c%pfti
npfts => clm3%g%l%c%npfts
do_capsnow => clm3%g%l%c%cps%do_capsnow
t_grnd => clm3%g%l%c%ces%t_grnd
snl => clm3%g%l%c%cps%snl
snowdp => clm3%g%l%c%cps%snowdp
h2osno => clm3%g%l%c%cws%h2osno
zi => clm3%g%l%c%cps%zi
dz => clm3%g%l%c%cps%dz
z => clm3%g%l%c%cps%z
frac_iceold => clm3%g%l%c%cps%frac_iceold
t_soisno => clm3%g%l%c%ces%t_soisno
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
qflx_snow_grnd_col => clm3%g%l%c%cwf%pwf_a%qflx_snow_grnd
h2ocan_loss => clm3%g%l%c%cwf%h2ocan_loss
snw_rds => clm3%g%l%c%cps%snw_rds
mss_bcpho => clm3%g%l%c%cps%mss_bcpho
mss_bcphi => clm3%g%l%c%cps%mss_bcphi
mss_bctot => clm3%g%l%c%cps%mss_bctot
mss_bc_col => clm3%g%l%c%cps%mss_bc_col
mss_bc_top => clm3%g%l%c%cps%mss_bc_top
mss_ocpho => clm3%g%l%c%cps%mss_ocpho
mss_ocphi => clm3%g%l%c%cps%mss_ocphi
mss_octot => clm3%g%l%c%cps%mss_octot
mss_oc_col => clm3%g%l%c%cps%mss_oc_col
mss_oc_top => clm3%g%l%c%cps%mss_oc_top
mss_dst1 => clm3%g%l%c%cps%mss_dst1
mss_dst2 => clm3%g%l%c%cps%mss_dst2
mss_dst3 => clm3%g%l%c%cps%mss_dst3
mss_dst4 => clm3%g%l%c%cps%mss_dst4
mss_dsttot => clm3%g%l%c%cps%mss_dsttot
mss_dst_col => clm3%g%l%c%cps%mss_dst_col
mss_dst_top => clm3%g%l%c%cps%mss_dst_top
! Assign local pointers to derived type members (pft-level)
plandunit => clm3%g%l%c%p%landunit
pcolumn => clm3%g%l%c%p%column
dewmx => clm3%g%l%c%p%pps%dewmx
frac_veg_nosno => clm3%g%l%c%p%pps%frac_veg_nosno
elai => clm3%g%l%c%p%pps%elai
esai => clm3%g%l%c%p%pps%esai
h2ocan => clm3%g%l%c%p%pws%h2ocan
qflx_prec_intr => clm3%g%l%c%p%pwf%qflx_prec_intr
qflx_prec_grnd => clm3%g%l%c%p%pwf%qflx_prec_grnd
qflx_snwcp_liq => clm3%g%l%c%p%pwf%qflx_snwcp_liq
qflx_snwcp_ice => clm3%g%l%c%p%pwf%qflx_snwcp_ice
qflx_snow_grnd_pft => clm3%g%l%c%p%pwf%qflx_snow_grnd
qflx_rain_grnd => clm3%g%l%c%p%pwf%qflx_rain_grnd
fwet => clm3%g%l%c%p%pps%fwet
fdry => clm3%g%l%c%p%pps%fdry
! Start pft loop
do f = 1, num_nolakep
p = filter_nolakep(f)
g = pgridcell(p)
l = plandunit(p)
c = pcolumn(p)
! Canopy interception and precipitation onto ground surface
! Add precipitation to leaf water
#ifndef CROP
if (ltype(l)==istsoil .or. ltype(l)==istwet .or. ltype(l)==isturb)then
#else
if (ltype(l)==istsoil .or. ltype(l)==istwet .or. ltype(l)==isturb .or. &
ltype(l)==istcrop) then
#endif
qflx_candrip(p) = 0._r8 ! rate of canopy runoff
qflx_through_snow(p) = 0._r8 ! rain precipitation direct through canopy
qflx_through_rain(p) = 0._r8 ! snow precipitation direct through canopy
qflx_prec_intr(p) = 0._r8 ! total intercepted precipitation
fracsnow(p) = 0._r8 ! fraction of input precip that is snow
fracrain(p) = 0._r8 ! fraction of input precip that is rain
if (ctype(c) /= icol_sunwall .and. ctype(c) /= icol_shadewall) then
if (frac_veg_nosno(p) == 1 .and. (forc_rain(g) + forc_snow(g)) > 0._r8) then
! determine fraction of input precipitation that is snow and rain
fracsnow(p) = forc_snow(g)/(forc_snow(g) + forc_rain(g))
fracrain(p) = forc_rain(g)/(forc_snow(g) + forc_rain(g))
! The leaf water capacities for solid and liquid are different,
! generally double for snow, but these are of somewhat less
! significance for the water budget because of lower evap. rate at
! lower temperature. Hence, it is reasonable to assume that
! vegetation storage of solid water is the same as liquid water.
h2ocanmx = dewmx(p) * (elai(p) + esai(p))
! Coefficient of interception
! set fraction of potential interception to max 0.25
fpi = 0.25_r8*(1._r8 - exp(-0.5_r8*(elai(p) + esai(p))))
! Direct throughfall
qflx_through_snow(p) = forc_snow(g) * (1._r8-fpi)
qflx_through_rain(p) = forc_rain(g) * (1._r8-fpi)
! Intercepted precipitation [mm/s]
qflx_prec_intr(p) = (forc_snow(g) + forc_rain(g)) * fpi
! Water storage of intercepted precipitation and dew
h2ocan(p) = max(0._r8, h2ocan(p) + dtime*qflx_prec_intr(p))
! Initialize rate of canopy runoff and snow falling off canopy
qflx_candrip(p) = 0._r8
! Excess water that exceeds the leaf capacity
xrun = (h2ocan(p) - h2ocanmx)/dtime
! Test on maximum dew on leaf
! Note if xrun > 0 then h2ocan must be at least h2ocanmx
if (xrun > 0._r8) then
qflx_candrip(p) = xrun
h2ocan(p) = h2ocanmx
end if
end if
end if
else if (ltype(l) == istice) then
h2ocan(p) = 0._r8
qflx_candrip(p) = 0._r8
qflx_through_snow(p) = 0._r8
qflx_through_rain(p) = 0._r8
qflx_prec_intr(p) = 0._r8
fracsnow(p) = 0._r8
fracrain(p) = 0._r8
end if
! Precipitation onto ground (kg/(m2 s))
! PET, 1/18/2005: Added new terms for mass balance correction
! due to dynamic pft weight shifting (column-level h2ocan_loss)
! Because the fractionation between rain and snow is indeterminate if
! rain + snow = 0, I am adding this very small flux only to the rain
! components.
if (ctype(c) /= icol_sunwall .and. ctype(c) /= icol_shadewall) then
if (frac_veg_nosno(p) == 0) then
qflx_prec_grnd_snow(p) = forc_snow(g)
qflx_prec_grnd_rain(p) = forc_rain(g) + h2ocan_loss(c)
else
qflx_prec_grnd_snow(p) = qflx_through_snow(p) + (qflx_candrip(p) * fracsnow(p))
qflx_prec_grnd_rain(p) = qflx_through_rain(p) + (qflx_candrip(p) * fracrain(p)) + h2ocan_loss(c)
end if
! Urban sunwall and shadewall have no intercepted precipitation
else
qflx_prec_grnd_snow(p) = 0.
qflx_prec_grnd_rain(p) = 0.
end if
qflx_prec_grnd(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p)
if (do_capsnow(c)) then
qflx_snwcp_liq(p) = qflx_prec_grnd_rain(p)
qflx_snwcp_ice(p) = qflx_prec_grnd_snow(p)
qflx_snow_grnd_pft(p) = 0._r8
qflx_rain_grnd(p) = 0._r8
else
qflx_snwcp_liq(p) = 0._r8
qflx_snwcp_ice(p) = 0._r8
qflx_snow_grnd_pft(p) = qflx_prec_grnd_snow(p) ! ice onto ground (mm/s)
qflx_rain_grnd(p) = qflx_prec_grnd_rain(p) ! liquid water onto ground (mm/s)
end if
end do ! (end pft loop)
! Determine the fraction of foliage covered by water and the
! fraction of foliage that is dry and transpiring.
call FracWet(num_nolakep, filter_nolakep)
! Update column level state variables for snow.
call p2c(num_nolakec, filter_nolakec, qflx_snow_grnd_pft, qflx_snow_grnd_col)
! Determine snow height and snow water
do f = 1, num_nolakec
c = filter_nolakec(f)
l = clandunit(c)
g = cgridcell(c)
! Use Alta relationship, Anderson(1976); LaChapelle(1961),
! U.S.Department of Agriculture Forest Service, Project F,
! Progress Rep. 1, Alta Avalanche Study Center:Snow Layer Densification.
if (do_capsnow(c)) then
dz_snowf = 0._r8
else
if (forc_t(g) > tfrz + 2._r8) then
bifall=50._r8 + 1.7_r8*(17.0_r8)**1.5_r8
else if (forc_t(g) > tfrz - 15._r8) then
bifall=50._r8 + 1.7_r8*(forc_t(g) - tfrz + 15._r8)**1.5_r8
else
bifall=50._r8
end if
dz_snowf = qflx_snow_grnd_col(c)/bifall
snowdp(c) = snowdp(c) + dz_snowf*dtime
h2osno(c) = h2osno(c) + qflx_snow_grnd_col(c)*dtime ! snow water equivalent (mm)
end if
if (ltype(l)==istwet .and. t_grnd(c)>tfrz) then
h2osno(c)=0._r8
snowdp(c)=0._r8
end if
! When the snow accumulation exceeds 10 mm, initialize snow layer
! Currently, the water temperature for the precipitation is simply set
! as the surface air temperature
newnode = 0 ! flag for when snow node will be initialized
if (snl(c) == 0 .and. qflx_snow_grnd_col(c) > 0.0_r8 .and. snowdp(c) >= 0.01_r8) then
newnode = 1
snl(c) = -1
dz(c,0) = snowdp(c) ! meter
z(c,0) = -0.5_r8*dz(c,0)
zi(c,-1) = -dz(c,0)
t_soisno(c,0) = min(tfrz, forc_t(g)) ! K
h2osoi_ice(c,0) = h2osno(c) ! kg/m2
h2osoi_liq(c,0) = 0._r8 ! kg/m2
frac_iceold(c,0) = 1._r8
! intitialize SNICAR variables for fresh snow:
snw_rds(c,0) = snw_rds_min
mss_bcpho(c,:) = 0._r8
mss_bcphi(c,:) = 0._r8
mss_bctot(c,:) = 0._r8
mss_bc_col(c) = 0._r8
mss_bc_top(c) = 0._r8
mss_ocpho(c,:) = 0._r8
mss_ocphi(c,:) = 0._r8
mss_octot(c,:) = 0._r8
mss_oc_col(c) = 0._r8
mss_oc_top(c) = 0._r8
mss_dst1(c,:) = 0._r8
mss_dst2(c,:) = 0._r8
mss_dst3(c,:) = 0._r8
mss_dst4(c,:) = 0._r8
mss_dsttot(c,:) = 0._r8
mss_dst_col(c) = 0._r8
mss_dst_top(c) = 0._r8
end if
! The change of ice partial density of surface node due to precipitation.
! Only ice part of snowfall is added here, the liquid part will be added
! later.
if (snl(c) < 0 .and. newnode == 0) then
h2osoi_ice(c,snl(c)+1) = h2osoi_ice(c,snl(c)+1)+dtime*qflx_snow_grnd_col(c)
dz(c,snl(c)+1) = dz(c,snl(c)+1)+dz_snowf*dtime
end if
end do
end subroutine Hydrology1
end module Hydrology1Mod
module Hydrology2Mod 1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: Hydrology2Mod
!
! !DESCRIPTION:
! Calculation of soil/snow hydrology.
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: Hydrology2 ! Calculates soil/snow hydrology
!
! !REVISION HISTORY:
! 2/28/02 Peter Thornton: Migrated to new data structures.
! 7/12/03 Forrest Hoffman ,Mariana Vertenstein : Migrated to vector code
! 11/05/03 Peter Thornton: Added calculation of soil water potential
! for use in CN phenology code.
! 04/25/07 Keith Oleson: CLM3.5 Hydrology
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: Hydrology2
!
! !INTERFACE:
subroutine Hydrology2(lbc, ubc, lbp, ubp, & 1,18
num_nolakec, filter_nolakec, &
num_hydrologyc, filter_hydrologyc, &
num_urbanc, filter_urbanc, &
num_snowc, filter_snowc, &
num_nosnowc, filter_nosnowc)
!
! !DESCRIPTION:
! This is the main subroutine to execute the calculation of soil/snow
! hydrology
! Calling sequence is:
! Hydrology2: surface hydrology driver
! -> SnowWater: change of snow mass and snow water onto soil
! -> SurfaceRunoff: surface runoff
! -> Infiltration: infiltration into surface soil layer
! -> SoilWater: soil water movement between layers
! -> Tridiagonal tridiagonal matrix solution
! -> Drainage: subsurface runoff
! -> SnowCompaction: compaction of snow layers
! -> CombineSnowLayers: combine snow layers that are thinner than minimum
! -> DivideSnowLayers: subdivide snow layers that are thicker than maximum
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype
use clm_varcon , only : denh2o, denice, spval, &
istice, istwet, istsoil, isturb, &
icol_roof, icol_road_imperv, icol_road_perv, icol_sunwall, &
icol_shadewall
#ifdef CROP
use clm_varcon , only : istcrop
#endif
use clm_varpar , only : nlevgrnd, nlevsno, nlevsoi
use SnowHydrologyMod, only : SnowCompaction, CombineSnowLayers, DivideSnowLayers, &
SnowWater, BuildSnowFilter
use SoilHydrologyMod, only : Infiltration, SoilWater, Drainage, SurfaceRunoff
use globals , only : nstep,dtime,is_perpetual
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: lbp, ubp ! pft bounds
integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
integer, intent(in) :: num_hydrologyc ! number of column soil points in column filter
integer, intent(in) :: filter_hydrologyc(ubc-lbc+1)! column filter for soil points
integer, intent(in) :: num_urbanc ! number of column urban points in column filter
integer, intent(in) :: filter_urbanc(ubc-lbc+1) ! column filter for urban points
integer :: num_snowc ! number of column snow points
integer :: filter_snowc(ubc-lbc+1) ! column filter for snow points
integer :: num_nosnowc ! number of column non-snow points
integer :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: cgridcell(:) ! column's gridcell
integer , pointer :: clandunit(:) ! column's landunit
integer , pointer :: ityplun(:) ! landunit type
integer , pointer :: ctype(:) ! column type
integer , pointer :: snl(:) ! number of snow layers
real(r8), pointer :: h2ocan(:) ! canopy water (mm H2O)
real(r8), pointer :: h2osno(:) ! snow water (mm H2O)
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity)
real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm)
real(r8), pointer :: bsw(:,:) ! Clapp and Hornberger "b"
real(r8), pointer :: z(:,:) ! layer depth (m)
real(r8), pointer :: forc_rain(:) ! rain rate [mm/s]
real(r8), pointer :: forc_snow(:) ! snow rate [mm/s]
real(r8), pointer :: begwb(:) ! water mass begining of the time step
real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
real(r8), pointer :: bsw2(:,:) ! Clapp and Hornberger "b" for CN code
real(r8), pointer :: psisat(:,:) ! soil water potential at saturation for CN code (MPa)
real(r8), pointer :: vwcsat(:,:) ! volumetric water content at saturation for CN code (m3/m3)
!
! local pointers to implicit inout arguments
!
real(r8), pointer :: dz(:,:) ! layer thickness depth (m)
real(r8), pointer :: zi(:,:) ! interface depth (m)
real(r8), pointer :: zwt(:) ! water table depth (m)
real(r8), pointer :: fcov(:) ! fractional impermeable area
real(r8), pointer :: fsat(:) ! fractional area with water table at surface
real(r8), pointer :: wa(:) ! water in the unconfined aquifer (mm)
real(r8), pointer :: qcharge(:) ! aquifer recharge rate (mm/s)
real(r8), pointer :: smp_l(:,:) ! soil matrix potential [mm]
real(r8), pointer :: hk_l(:,:) ! hydraulic conductivity (mm/s)
real(r8), pointer :: qflx_rsub_sat(:) ! soil saturation excess [mm h2o/s]
!
! local pointers to implicit out arguments
!
real(r8), pointer :: endwb(:) ! water mass end of the time step
real(r8), pointer :: wf(:) ! soil water as frac. of whc for top 0.5 m
real(r8), pointer :: snowice(:) ! average snow ice lens
real(r8), pointer :: snowliq(:) ! average snow liquid water
real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin)
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin)
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
real(r8), pointer :: t_soi_10cm(:) ! soil temperature in top 10cm of soil (Kelvin)
real(r8), pointer :: h2osoi_liqice_10cm(:) ! liquid water + ice lens in top 10cm of soil (kg/m2)
real(r8), pointer :: h2osoi_vol(:,:) ! volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3]
real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s)
real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s)
real(r8), pointer :: qflx_infl(:) ! infiltration (mm H2O /s)
real(r8), pointer :: qflx_qrgwl(:) ! qflx_surf at glaciers, wetlands, lakes
real(r8), pointer :: qflx_runoff(:) ! total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s)
real(r8), pointer :: qflx_runoff_u(:) ! Urban total runoff (qflx_drain+qflx_surf) (mm H2O /s)
real(r8), pointer :: qflx_runoff_r(:) ! Rural total runoff (qflx_drain+qflx_surf+qflx_qrgwl) (mm H2O /s)
real(r8), pointer :: t_grnd_u(:) ! Urban ground temperature (Kelvin)
real(r8), pointer :: t_grnd_r(:) ! Rural ground temperature (Kelvin)
real(r8), pointer :: qflx_snwcp_ice(:)! excess snowfall due to snow capping (mm H2O /s) [+]`
real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa)
real(r8), pointer :: snot_top(:) ! snow temperature in top layer (col) [K]
real(r8), pointer :: dTdz_top(:) ! temperature gradient in top layer (col) [K m-1]
real(r8), pointer :: snw_rds(:,:) ! effective snow grain radius (col,lyr) [microns, m^-6]
real(r8), pointer :: snw_rds_top(:) ! effective snow grain size, top layer(col) [microns]
real(r8), pointer :: sno_liq_top(:) ! liquid water fraction in top snow layer (col) [frc]
real(r8), pointer :: frac_sno(:) ! snow cover fraction (col) [frc]
real(r8), pointer :: h2osno_top(:) ! mass of snow in top layer (col) [kg]
real(r8), pointer :: mss_bcpho(:,:) ! mass of hydrophobic BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bcphi(:,:) ! mass of hydrophillic BC in snow (col,lyr) [kg]
real(r8), pointer :: mss_bctot(:,:) ! total mass of BC (pho+phi) (col,lyr) [kg]
real(r8), pointer :: mss_bc_col(:) ! total mass of BC in snow column (col) [kg]
real(r8), pointer :: mss_bc_top(:) ! total mass of BC in top snow layer (col) [kg]
real(r8), pointer :: mss_cnc_bcphi(:,:) ! mass concentration of BC species 1 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_bcpho(:,:) ! mass concentration of BC species 2 (col,lyr) [kg/kg]
real(r8), pointer :: mss_ocpho(:,:) ! mass of hydrophobic OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_ocphi(:,:) ! mass of hydrophillic OC in snow (col,lyr) [kg]
real(r8), pointer :: mss_octot(:,:) ! total mass of OC (pho+phi) (col,lyr) [kg]
real(r8), pointer :: mss_oc_col(:) ! total mass of OC in snow column (col) [kg]
real(r8), pointer :: mss_oc_top(:) ! total mass of OC in top snow layer (col) [kg]
real(r8), pointer :: mss_cnc_ocphi(:,:) ! mass concentration of OC species 1 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_ocpho(:,:) ! mass concentration of OC species 2 (col,lyr) [kg/kg]
real(r8), pointer :: mss_dst1(:,:) ! mass of dust species 1 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst2(:,:) ! mass of dust species 2 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst3(:,:) ! mass of dust species 3 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst4(:,:) ! mass of dust species 4 in snow (col,lyr) [kg]
real(r8), pointer :: mss_dsttot(:,:) ! total mass of dust in snow (col,lyr) [kg]
real(r8), pointer :: mss_dst_col(:) ! total mass of dust in snow column (col) [kg]
real(r8), pointer :: mss_dst_top(:) ! total mass of dust in top snow layer (col) [kg]
real(r8), pointer :: mss_cnc_dst1(:,:) ! mass concentration of dust species 1 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst2(:,:) ! mass concentration of dust species 2 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst3(:,:) ! mass concentration of dust species 3 (col,lyr) [kg/kg]
real(r8), pointer :: mss_cnc_dst4(:,:) ! mass concentration of dust species 4 (col,lyr) [kg/kg]
logical , pointer :: do_capsnow(:) ! true => do snow capping
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: g,l,c,j,fc ! indices
real(r8) :: vol_liq(lbc:ubc,1:nlevgrnd)! partial volume of liquid water in layer
real(r8) :: icefrac(lbc:ubc,1:nlevgrnd)! ice fraction in layer
real(r8) :: dwat(lbc:ubc,1:nlevgrnd) ! change in soil water
real(r8) :: hk(lbc:ubc,1:nlevgrnd) ! hydraulic conductivity (mm h2o/s)
real(r8) :: dhkdw(lbc:ubc,1:nlevgrnd) ! d(hk)/d(vol_liq)
real(r8) :: psi,vwc,fsattmp ! temporary variables for soilpsi calculation
#if (defined CN) || (defined CASA)
real(r8) :: watdry ! temporary
real(r8) :: rwat(lbc:ubc) ! soil water wgted by depth to maximum depth of 0.5 m
real(r8) :: swat(lbc:ubc) ! same as rwat but at saturation
real(r8) :: rz(lbc:ubc) ! thickness of soil layers contributing to rwat (m)
real(r8) :: tsw ! volumetric soil water to 0.5 m
real(r8) :: stsw ! volumetric soil water to 0.5 m at saturation
#endif
real(r8) :: snowmass ! liquid+ice snow mass in a layer [kg/m2]
real(r8) :: snowcap_scl_fct ! temporary factor used to correct for snow capping
real(r8) :: fracl ! fraction of soil layer contributing to 10cm total soil water
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (gridcell-level)
forc_rain => clm_a2l%forc_rain
forc_snow => clm_a2l%forc_snow
! Assign local pointers to derived subtypes components (landunit-level)
ityplun => clm3%g%l%itype
! Assign local pointers to derived subtypes components (column-level)
cgridcell => clm3%g%l%c%gridcell
clandunit => clm3%g%l%c%landunit
ctype => clm3%g%l%c%itype
snl => clm3%g%l%c%cps%snl
t_grnd => clm3%g%l%c%ces%t_grnd
h2ocan => clm3%g%l%c%cws%pws_a%h2ocan
h2osno => clm3%g%l%c%cws%h2osno
wf => clm3%g%l%c%cps%wf
snowice => clm3%g%l%c%cws%snowice
snowliq => clm3%g%l%c%cws%snowliq
zwt => clm3%g%l%c%cws%zwt
fcov => clm3%g%l%c%cws%fcov
fsat => clm3%g%l%c%cws%fsat
wa => clm3%g%l%c%cws%wa
qcharge => clm3%g%l%c%cws%qcharge
watsat => clm3%g%l%c%cps%watsat
sucsat => clm3%g%l%c%cps%sucsat
bsw => clm3%g%l%c%cps%bsw
z => clm3%g%l%c%cps%z
dz => clm3%g%l%c%cps%dz
zi => clm3%g%l%c%cps%zi
t_soisno => clm3%g%l%c%ces%t_soisno
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_vol => clm3%g%l%c%cws%h2osoi_vol
t_soi_10cm => clm3%g%l%c%ces%t_soi_10cm
h2osoi_liqice_10cm => clm3%g%l%c%cws%h2osoi_liqice_10cm
qflx_evap_tot => clm3%g%l%c%cwf%pwf_a%qflx_evap_tot
qflx_drain => clm3%g%l%c%cwf%qflx_drain
qflx_surf => clm3%g%l%c%cwf%qflx_surf
qflx_infl => clm3%g%l%c%cwf%qflx_infl
qflx_qrgwl => clm3%g%l%c%cwf%qflx_qrgwl
endwb => clm3%g%l%c%cwbal%endwb
begwb => clm3%g%l%c%cwbal%begwb
bsw2 => clm3%g%l%c%cps%bsw2
psisat => clm3%g%l%c%cps%psisat
vwcsat => clm3%g%l%c%cps%vwcsat
soilpsi => clm3%g%l%c%cps%soilpsi
smp_l => clm3%g%l%c%cws%smp_l
hk_l => clm3%g%l%c%cws%hk_l
qflx_rsub_sat => clm3%g%l%c%cwf%qflx_rsub_sat
qflx_runoff => clm3%g%l%c%cwf%qflx_runoff
qflx_runoff_u => clm3%g%l%c%cwf%qflx_runoff_u
qflx_runoff_r => clm3%g%l%c%cwf%qflx_runoff_r
t_grnd_u => clm3%g%l%c%ces%t_grnd_u
t_grnd_r => clm3%g%l%c%ces%t_grnd_r
snot_top => clm3%g%l%c%cps%snot_top
dTdz_top => clm3%g%l%c%cps%dTdz_top
snw_rds => clm3%g%l%c%cps%snw_rds
snw_rds_top => clm3%g%l%c%cps%snw_rds_top
sno_liq_top => clm3%g%l%c%cps%sno_liq_top
frac_sno => clm3%g%l%c%cps%frac_sno
h2osno_top => clm3%g%l%c%cps%h2osno_top
mss_bcpho => clm3%g%l%c%cps%mss_bcpho
mss_bcphi => clm3%g%l%c%cps%mss_bcphi
mss_bctot => clm3%g%l%c%cps%mss_bctot
mss_bc_col => clm3%g%l%c%cps%mss_bc_col
mss_bc_top => clm3%g%l%c%cps%mss_bc_top
mss_cnc_bcphi => clm3%g%l%c%cps%mss_cnc_bcphi
mss_cnc_bcpho => clm3%g%l%c%cps%mss_cnc_bcpho
mss_ocpho => clm3%g%l%c%cps%mss_ocpho
mss_ocphi => clm3%g%l%c%cps%mss_ocphi
mss_octot => clm3%g%l%c%cps%mss_octot
mss_oc_col => clm3%g%l%c%cps%mss_oc_col
mss_oc_top => clm3%g%l%c%cps%mss_oc_top
mss_cnc_ocphi => clm3%g%l%c%cps%mss_cnc_ocphi
mss_cnc_ocpho => clm3%g%l%c%cps%mss_cnc_ocpho
mss_dst1 => clm3%g%l%c%cps%mss_dst1
mss_dst2 => clm3%g%l%c%cps%mss_dst2
mss_dst3 => clm3%g%l%c%cps%mss_dst3
mss_dst4 => clm3%g%l%c%cps%mss_dst4
mss_dsttot => clm3%g%l%c%cps%mss_dsttot
mss_dst_col => clm3%g%l%c%cps%mss_dst_col
mss_dst_top => clm3%g%l%c%cps%mss_dst_top
mss_cnc_dst1 => clm3%g%l%c%cps%mss_cnc_dst1
mss_cnc_dst2 => clm3%g%l%c%cps%mss_cnc_dst2
mss_cnc_dst3 => clm3%g%l%c%cps%mss_cnc_dst3
mss_cnc_dst4 => clm3%g%l%c%cps%mss_cnc_dst4
qflx_snwcp_ice => clm3%g%l%c%cwf%pwf_a%qflx_snwcp_ice
do_capsnow => clm3%g%l%c%cps%do_capsnow
! Determine time step and step size
! Determine initial snow/no-snow filters (will be modified possibly by
! routines CombineSnowLayers and DivideSnowLayers below
call BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec, &
num_snowc, filter_snowc, num_nosnowc, filter_nosnowc)
! Determine the change of snow mass and the snow water onto soil
call SnowWater(lbc, ubc, num_snowc, filter_snowc, num_nosnowc, filter_nosnowc)
! Determine soil hydrology
call SurfaceRunoff(lbc, ubc, lbp, ubp, num_hydrologyc, filter_hydrologyc, &
num_urbanc, filter_urbanc, &
vol_liq, icefrac )
call Infiltration(lbc, ubc, num_hydrologyc, filter_hydrologyc, &
num_urbanc, filter_urbanc)
call SoilWater(lbc, ubc, num_hydrologyc, filter_hydrologyc, &
num_urbanc, filter_urbanc, &
vol_liq, dwat, hk, dhkdw)
call Drainage(lbc, ubc, num_hydrologyc, filter_hydrologyc, &
num_urbanc, filter_urbanc, &
vol_liq, hk, icefrac)
if (.not. is_perpetual) then
! Natural compaction and metamorphosis.
call SnowCompaction(lbc, ubc, num_snowc, filter_snowc)
! Combine thin snow elements
call CombineSnowLayers(lbc, ubc, num_snowc, filter_snowc)
! Divide thick snow elements
call DivideSnowLayers(lbc, ubc, num_snowc, filter_snowc)
else
do fc = 1, num_snowc
c = filter_snowc(fc)
h2osno(c) = 0._r8
end do
do j = -nlevsno+1,0
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j >= snl(c)+1) then
h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
end if
end do
end do
end if
! Set empty snow layers to zero
do j = -nlevsno+1,0
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j <= snl(c) .and. snl(c) > -nlevsno) then
h2osoi_ice(c,j) = 0._r8
h2osoi_liq(c,j) = 0._r8
t_soisno(c,j) = 0._r8
dz(c,j) = 0._r8
z(c,j) = 0._r8
zi(c,j-1) = 0._r8
end if
end do
end do
! Build new snow filter
call BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec, &
num_snowc, filter_snowc, num_nosnowc, filter_nosnowc)
! Vertically average t_soisno and sum of h2osoi_liq and h2osoi_ice
! over all snow layers for history output
do fc = 1, num_snowc
c = filter_snowc(fc)
snowice(c) = 0._r8
snowliq(c) = 0._r8
end do
do fc = 1, num_nosnowc
c = filter_nosnowc(fc)
snowice(c) = spval
snowliq(c) = spval
end do
do j = -nlevsno+1, 0
do fc = 1, num_snowc
c = filter_snowc(fc)
if (j >= snl(c)+1) then
snowice(c) = snowice(c) + h2osoi_ice(c,j)
snowliq(c) = snowliq(c) + h2osoi_liq(c,j)
end if
end do
end do
! Determine ground temperature, ending water balance and volumetric soil water
! Calculate soil temperature and total water (liq+ice) in top 10cm of soil
do fc = 1, num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (ityplun(l) /= isturb) then
t_soi_10cm(c) = 0._r8
h2osoi_liqice_10cm(c) = 0._r8
end if
end do
do j = 1, nlevsoi
do fc = 1, num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
if (ityplun(l) /= isturb) then
if (zi(c,j) <= 0.1_r8) then
fracl = 1._r8
t_soi_10cm(c) = t_soi_10cm(c) + t_soisno(c,j)*dz(c,j)*fracl
h2osoi_liqice_10cm(c) = h2osoi_liqice_10cm(c) + (h2osoi_liq(c,j)+h2osoi_ice(c,j))* &
fracl
else
if (zi(c,j) > 0.1_r8 .and. zi(c,j-1) .lt. 0.1_r8) then
fracl = (0.1_r8 - zi(c,j-1))/dz(c,j)
t_soi_10cm(c) = t_soi_10cm(c) + t_soisno(c,j)*dz(c,j)*fracl
h2osoi_liqice_10cm(c) = h2osoi_liqice_10cm(c) + (h2osoi_liq(c,j)+h2osoi_ice(c,j))* &
fracl
end if
end if
end if
end do
end do
do fc = 1, num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
t_grnd(c) = t_soisno(c,snl(c)+1)
if (ityplun(l) /= isturb) then
t_soi_10cm(c) = t_soi_10cm(c)/0.1_r8
end if
if (ityplun(l)==isturb) then
t_grnd_u(c) = t_soisno(c,snl(c)+1)
end if
#ifndef CROP
if (ityplun(l)==istsoil) then
#else
if (ityplun(l)==istsoil .or. ityplun(l)==istcrop) then
#endif
t_grnd_r(c) = t_soisno(c,snl(c)+1)
end if
if (ctype(c) == icol_roof .or. ctype(c) == icol_sunwall &
.or. ctype(c) == icol_shadewall .or. ctype(c) == icol_road_imperv) then
endwb(c) = h2ocan(c) + h2osno(c)
else
endwb(c) = h2ocan(c) + h2osno(c) + wa(c)
end if
end do
do j = 1, nlevgrnd
do fc = 1, num_nolakec
c = filter_nolakec(fc)
endwb(c) = endwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice)
end do
end do
! Determine wetland and land ice hydrology (must be placed here
! since need snow updated from CombineSnowLayers)
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
g = cgridcell(c)
if (ityplun(l)==istwet .or. ityplun(l)==istice) then
qflx_drain(c) = 0._r8
qflx_surf(c) = 0._r8
qflx_infl(c) = 0._r8
qflx_qrgwl(c) = forc_rain(g) + forc_snow(g) - qflx_evap_tot(c) - qflx_snwcp_ice(c) - &
(endwb(c)-begwb(c))/dtime
fcov(c) = spval
fsat(c) = spval
qcharge(c) = spval
qflx_rsub_sat(c) = spval
else if (ityplun(l) == isturb .and. ctype(c) /= icol_road_perv) then
fcov(c) = spval
fsat(c) = spval
qcharge(c) = spval
qflx_rsub_sat(c) = spval
end if
qflx_runoff(c) = qflx_drain(c) + qflx_surf(c) + qflx_qrgwl(c)
if (ityplun(l)==isturb) then
qflx_runoff_u(c) = qflx_drain(c) + qflx_surf(c)
#ifndef CROP
else if (ityplun(l)==istsoil) then
#else
else if (ityplun(l)==istsoil .or. ityplun(l)==istcrop) then
#endif
qflx_runoff_r(c) = qflx_drain(c) + qflx_surf(c) + qflx_qrgwl(c)
end if
end do
#if (defined CN) || (defined CASA)
do j = 1, nlevgrnd
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
if (h2osoi_liq(c,j) > 0._r8) then
vwc = h2osoi_liq(c,j)/(dz(c,j)*denh2o)
! the following limit set to catch very small values of
! fractional saturation that can crash the calculation of psi
fsattmp = max(vwc/vwcsat(c,j), 0.001_r8)
psi = psisat(c,j) * (fsattmp)**bsw2(c,j)
soilpsi(c,j) = min(max(psi,-15.0_r8),0._r8)
else
soilpsi(c,j) = -15.0_r8
end if
end do
end do
#endif
#if (defined CN) || (defined CASA)
! Available soil water up to a depth of 0.5 m.
! Potentially available soil water (=whc) up to a depth of 0.5 m.
! Water content as fraction of whc up to a depth of 0.5 m.
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
rwat(c) = 0._r8
swat(c) = 0._r8
rz(c) = 0._r8
end do
do j = 1, nlevgrnd
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
!if (z(c,j)+0.5_r8*dz(c,j) <= 0.5_r8) then
if (z(c,j)+0.5_r8*dz(c,j) <= 0.05_r8) then
watdry = watsat(c,j) * (316230._r8/sucsat(c,j)) ** (-1._r8/bsw(c,j))
rwat(c) = rwat(c) + (h2osoi_vol(c,j)-watdry) * dz(c,j)
swat(c) = swat(c) + (watsat(c,j) -watdry) * dz(c,j)
rz(c) = rz(c) + dz(c,j)
end if
end do
end do
do fc = 1, num_hydrologyc
c = filter_hydrologyc(fc)
if (rz(c) /= 0._r8) then
tsw = rwat(c)/rz(c)
stsw = swat(c)/rz(c)
else
watdry = watsat(c,1) * (316230._r8/sucsat(c,1)) ** (-1._r8/bsw(c,1))
tsw = h2osoi_vol(c,1) - watdry
stsw = watsat(c,1) - watdry
end if
wf(c) = tsw/stsw
end do
#endif
! Calculate column-integrated aerosol masses, and
! mass concentrations for radiative calculations and output
! (based on new snow level state, after SnowFilter is rebuilt.
! NEEDS TO BE AFTER SnowFiler is rebuilt, otherwise there
! can be zero snow layers but an active column in filter)
do fc = 1, num_snowc
c = filter_snowc(fc)
! Zero column-integrated aerosol mass before summation
mss_bc_col(c) = 0._r8
mss_oc_col(c) = 0._r8
mss_dst_col(c) = 0._r8
do j = -nlevsno+1, 0
! layer mass of snow:
snowmass = h2osoi_ice(c,j)+h2osoi_liq(c,j)
! Correct the top layer aerosol mass to account for snow capping.
! This approach conserves the aerosol mass concentration
! (but not the aerosol amss) when snow-capping is invoked
if (j == snl(c)+1) then
if (do_capsnow(c)) then
snowcap_scl_fct = snowmass / (snowmass+(qflx_snwcp_ice(c)*dtime))
mss_bcpho(c,j) = mss_bcpho(c,j)*snowcap_scl_fct
mss_bcphi(c,j) = mss_bcphi(c,j)*snowcap_scl_fct
mss_ocpho(c,j) = mss_ocpho(c,j)*snowcap_scl_fct
mss_ocphi(c,j) = mss_ocphi(c,j)*snowcap_scl_fct
mss_dst1(c,j) = mss_dst1(c,j)*snowcap_scl_fct
mss_dst2(c,j) = mss_dst2(c,j)*snowcap_scl_fct
mss_dst3(c,j) = mss_dst3(c,j)*snowcap_scl_fct
mss_dst4(c,j) = mss_dst4(c,j)*snowcap_scl_fct
endif
endif
if (j >= snl(c)+1) then
mss_bctot(c,j) = mss_bcpho(c,j) + mss_bcphi(c,j)
mss_bc_col(c) = mss_bc_col(c) + mss_bctot(c,j)
mss_cnc_bcphi(c,j) = mss_bcphi(c,j) / snowmass
mss_cnc_bcpho(c,j) = mss_bcpho(c,j) / snowmass
mss_octot(c,j) = mss_ocpho(c,j) + mss_ocphi(c,j)
mss_oc_col(c) = mss_oc_col(c) + mss_octot(c,j)
mss_cnc_ocphi(c,j) = mss_ocphi(c,j) / snowmass
mss_cnc_ocpho(c,j) = mss_ocpho(c,j) / snowmass
mss_dsttot(c,j) = mss_dst1(c,j) + mss_dst2(c,j) + mss_dst3(c,j) + mss_dst4(c,j)
mss_dst_col(c) = mss_dst_col(c) + mss_dsttot(c,j)
mss_cnc_dst1(c,j) = mss_dst1(c,j) / snowmass
mss_cnc_dst2(c,j) = mss_dst2(c,j) / snowmass
mss_cnc_dst3(c,j) = mss_dst3(c,j) / snowmass
mss_cnc_dst4(c,j) = mss_dst4(c,j) / snowmass
else
!set variables of empty snow layers to zero
snw_rds(c,j) = 0._r8
mss_bcpho(c,j) = 0._r8
mss_bcphi(c,j) = 0._r8
mss_bctot(c,j) = 0._r8
mss_cnc_bcphi(c,j) = 0._r8
mss_cnc_bcpho(c,j) = 0._r8
mss_ocpho(c,j) = 0._r8
mss_ocphi(c,j) = 0._r8
mss_octot(c,j) = 0._r8
mss_cnc_ocphi(c,j) = 0._r8
mss_cnc_ocpho(c,j) = 0._r8
mss_dst1(c,j) = 0._r8
mss_dst2(c,j) = 0._r8
mss_dst3(c,j) = 0._r8
mss_dst4(c,j) = 0._r8
mss_dsttot(c,j) = 0._r8
mss_cnc_dst1(c,j) = 0._r8
mss_cnc_dst2(c,j) = 0._r8
mss_cnc_dst3(c,j) = 0._r8
mss_cnc_dst4(c,j) = 0._r8
endif
enddo
! top-layer diagnostics
h2osno_top(c) = h2osoi_ice(c,snl(c)+1) + h2osoi_liq(c,snl(c)+1)
mss_bc_top(c) = mss_bctot(c,snl(c)+1)
mss_oc_top(c) = mss_octot(c,snl(c)+1)
mss_dst_top(c) = mss_dsttot(c,snl(c)+1)
enddo
! Zero mass variables in columns without snow
do fc = 1, num_nosnowc
c = filter_nosnowc(fc)
h2osno_top(c) = 0._r8
snw_rds(c,:) = 0._r8
mss_bc_top(c) = 0._r8
mss_bc_col(c) = 0._r8
mss_bcpho(c,:) = 0._r8
mss_bcphi(c,:) = 0._r8
mss_bctot(c,:) = 0._r8
mss_cnc_bcphi(c,:) = 0._r8
mss_cnc_bcpho(c,:) = 0._r8
mss_oc_top(c) = 0._r8
mss_oc_col(c) = 0._r8
mss_ocpho(c,:) = 0._r8
mss_ocphi(c,:) = 0._r8
mss_octot(c,:) = 0._r8
mss_cnc_ocphi(c,:) = 0._r8
mss_cnc_ocpho(c,:) = 0._r8
mss_dst_top(c) = 0._r8
mss_dst_col(c) = 0._r8
mss_dst1(c,:) = 0._r8
mss_dst2(c,:) = 0._r8
mss_dst3(c,:) = 0._r8
mss_dst4(c,:) = 0._r8
mss_dsttot(c,:) = 0._r8
mss_cnc_dst1(c,:) = 0._r8
mss_cnc_dst2(c,:) = 0._r8
mss_cnc_dst3(c,:) = 0._r8
mss_cnc_dst4(c,:) = 0._r8
! top-layer diagnostics (spval is not averaged when computing history fields)
snot_top(c) = spval
dTdz_top(c) = spval
snw_rds_top(c) = spval
sno_liq_top(c) = spval
enddo
end subroutine Hydrology2
end module Hydrology2Mod
module DriverInitMod 1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: clm_driverInitMod
!
! !DESCRIPTION:
! Initialization of clm driver variables needed from previous timestep
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: DriverInit
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: clm_driverInit
!
! !INTERFACE:
subroutine DriverInit(lbc, ubc, lbp, ubp, & 1,4
num_nolakec, filter_nolakec, num_lakec, filter_lakec)
!
! !DESCRIPTION:
! Initialization of clm driver variables needed from previous timestep
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use clm_varpar , only : nlevsno
use subgridAveMod, only : p2c
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column-index bounds
integer, intent(in) :: lbp, ubp ! pft-index bounds
integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
integer, intent(in) :: num_lakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_lakec(ubc-lbc+1) ! column filter for non-lake points
!
! !CALLED FROM:
! subroutine driver1
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in variables
!
real(r8), pointer :: pwtgcell(:) ! weight of pft wrt corresponding gridcell
integer , pointer :: snl(:) ! number of snow layers
real(r8), pointer :: h2osno(:) ! snow water (mm H2O)
integer , pointer :: frac_veg_nosno_alb(:) ! fraction of vegetation not covered by snow (0 OR 1) [-]
integer , pointer :: frac_veg_nosno(:) ! fraction of vegetation not covered by snow (0 OR 1 now) [-] (pft-level)
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
!
! local pointers to original implicit out variables
!
logical , pointer :: do_capsnow(:) ! true => do snow capping
real(r8), pointer :: h2osno_old(:) ! snow water (mm H2O) at previous time step
real(r8), pointer :: frac_iceold(:,:) ! fraction of ice relative to the tot water
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: c, p, f, j, fc ! indices
!-----------------------------------------------------------------------
! Assign local pointers to derived type members (column-level)
snl => clm3%g%l%c%cps%snl
h2osno => clm3%g%l%c%cws%h2osno
h2osno_old => clm3%g%l%c%cws%h2osno_old
do_capsnow => clm3%g%l%c%cps%do_capsnow
frac_iceold => clm3%g%l%c%cps%frac_iceold
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
frac_veg_nosno_alb => clm3%g%l%c%p%pps%frac_veg_nosno_alb
frac_veg_nosno => clm3%g%l%c%p%pps%frac_veg_nosno
! Assign local pointers to derived type members (pft-level)
pwtgcell => clm3%g%l%c%p%wtgcell
do c = lbc, ubc
! Save snow mass at previous time step
h2osno_old(c) = h2osno(c)
! Decide whether to cap snow
if (h2osno(c) > 1000._r8) then
do_capsnow(c) = .true.
else
do_capsnow(c) = .false.
end if
end do
! Initialize fraction of vegetation not covered by snow (pft-level)
do p = lbp,ubp
if (pwtgcell(p)>0._r8) then
frac_veg_nosno(p) = frac_veg_nosno_alb(p)
else
frac_veg_nosno(p) = 0._r8
end if
end do
! Initialize set of previous time-step variables
! Ice fraction of snow at previous time step
do j = -nlevsno+1,0
do f = 1, num_nolakec
c = filter_nolakec(f)
if (j >= snl(c) + 1) then
frac_iceold(c,j) = h2osoi_ice(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))
end if
end do
end do
end subroutine DriverInit
end module DriverInitMod
module CanopyFluxesMod 1,1
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: CanopyFluxesMod
!
! !DESCRIPTION:
! Calculates the leaf temperature and the leaf fluxes,
! transpiration, photosynthesis and updates the dew
! accumulation due to evaporation.
!
! !USES:
use module_cam_support, only: endrun
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: CanopyFluxes !Calculates the leaf temperature and leaf fluxes
!
! !PRIVATE MEMBER FUNCTIONS:
private :: Stomata !Leaf stomatal resistance and leaf photosynthesis
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! 4/25/05, Peter Thornton: replaced old Stomata subroutine with what
! used to be called StomataCN, as part of migration to new sun/shade
! algorithms.
!
!EOP
!------------------------------------------------------------------------------
contains
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: CanopyFluxes
!
! !INTERFACE:
subroutine CanopyFluxes(lbg, ubg, lbc, ubc, lbp, ubp, & 1,15
num_nolakep, filter_nolakep)
!
! !DESCRIPTION:
! 1. Calculates the leaf temperature:
! 2. Calculates the leaf fluxes, transpiration, photosynthesis and
! updates the dew accumulation due to evaporation.
!
! Method:
! Use the Newton-Raphson iteration to solve for the foliage
! temperature that balances the surface energy budget:
!
! f(t_veg) = Net radiation - Sensible - Latent = 0
! f(t_veg) + d(f)/d(t_veg) * dt_veg = 0 (*)
!
! Note:
! (1) In solving for t_veg, t_grnd is given from the previous timestep.
! (2) The partial derivatives of aerodynamical resistances, which cannot
! be determined analytically, are ignored for d(H)/dT and d(LE)/dT
! (3) The weighted stomatal resistance of sunlit and shaded foliage is used
! (4) Canopy air temperature and humidity are derived from => Hc + Hg = Ha
! => Ec + Eg = Ea
! (5) Energy loss is due to: numerical truncation of energy budget equation
! (*); and "ecidif" (see the code) which is dropped into the sensible
! heat
! (6) The convergence criteria: the difference, del = t_veg(n+1)-t_veg(n)
! and del2 = t_veg(n)-t_veg(n-1) less than 0.01 K, and the difference
! of water flux from the leaf between the iteration step (n+1) and (n)
! less than 0.1 W/m2; or the iterative steps over 40.
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use clm_varpar , only : nlevgrnd, nlevsno
use clm_varcon , only : sb, cpair, hvap, vkc, grav, denice, &
denh2o, tfrz, csoilc, tlsai_crit, alpha_aero
use QSatMod , only : QSat
use FrictionVelocityMod, only : FrictionVelocity, MoninObukIni
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbg, ubg ! gridcell bounds
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: lbp, ubp ! pft bounds
integer, intent(in) :: num_nolakep ! number of column non-lake points in pft filter
integer, intent(in) :: filter_nolakep(ubp-lbp+1) ! pft filter for non-lake points
!
! !CALLED FROM:
! subroutine Biogeophysics1 in module Biogeophysics1Mod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 12/19/01, Peter Thornton
! Changed tg to t_grnd for consistency with other routines
! 1/29/02, Peter Thornton
! Migrate to new data structures, new calling protocol. For now co2 and
! o2 partial pressures are hardwired, but they should be coming in from
! forc_pco2 and forc_po2. Keeping the same hardwired values as in CLM2 to
! assure bit-for-bit results in the first comparisons.
! 27 February 2008: Keith Oleson; Sparse/dense aerodynamic parameters from
! X. Zeng
! 6 March 2009: Peter Thornton; Daylength control on Vcmax, from Bill Bauerle
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in variables
!
integer , pointer :: frac_veg_nosno(:) ! frac of veg not covered by snow (0 OR 1 now) [-]
integer , pointer :: ivt(:) ! pft vegetation type
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: plandunit(:) ! pft's landunit index
integer , pointer :: pgridcell(:) ! pft's gridcell index
real(r8), pointer :: forc_th(:) ! atmospheric potential temperature (Kelvin)
real(r8), pointer :: t_grnd(:) ! ground surface temperature [K]
real(r8), pointer :: thm(:) ! intermediate variable (forc_t+0.0098*forc_hgt_t_pft)
real(r8), pointer :: qg(:) ! specific humidity at ground surface [kg/kg]
real(r8), pointer :: thv(:) ! virtual potential temperature (kelvin)
real(r8), pointer :: z0mv(:) ! roughness length over vegetation, momentum [m]
real(r8), pointer :: z0hv(:) ! roughness length over vegetation, sensible heat [m]
real(r8), pointer :: z0qv(:) ! roughness length over vegetation, latent heat [m]
real(r8), pointer :: z0mg(:) ! roughness length of ground, momentum [m]
real(r8), pointer :: dqgdT(:) ! temperature derivative of "qg"
real(r8), pointer :: htvp(:) ! latent heat of evaporation (/sublimation) [J/kg]
real(r8), pointer :: emv(:) ! ground emissivity
real(r8), pointer :: emg(:) ! vegetation emissivity
real(r8), pointer :: forc_pbot(:) ! atmospheric pressure (Pa)
real(r8), pointer :: forc_pco2(:) ! partial pressure co2 (Pa)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
real(r8), pointer :: forc_pc13o2(:) ! partial pressure c13o2 (Pa)
#endif
real(r8), pointer :: forc_po2(:) ! partial pressure o2 (Pa)
real(r8), pointer :: forc_q(:) ! atmospheric specific humidity (kg/kg)
real(r8), pointer :: forc_u(:) ! atmospheric wind speed in east direction (m/s)
real(r8), pointer :: forc_v(:) ! atmospheric wind speed in north direction (m/s)
real(r8), pointer :: forc_hgt_u_pft(:) !observational height of wind at pft level [m]
real(r8), pointer :: forc_rho(:) ! density (kg/m**3)
real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2)
real(r8), pointer :: displa(:) ! displacement height (m)
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) ! one-sided stem area index with burying by snow
real(r8), pointer :: fdry(:) ! fraction of foliage that is green and dry [-]
real(r8), pointer :: fwet(:) ! fraction of canopy that is wet (0 to 1)
real(r8), pointer :: laisun(:) ! sunlit leaf area
real(r8), pointer :: laisha(:) ! shaded leaf area
real(r8), pointer :: sabv(:) ! solar radiation absorbed by vegetation (W/m**2)
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity)
real(r8), pointer :: watdry(:,:) ! btran parameter for btran=0
real(r8), pointer :: watopt(:,:) ! btran parameter for btran = 1
real(r8), pointer :: h2osoi_ice(:,:)! ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:)! liquid water (kg/m2)
real(r8), pointer :: dz(:,:) ! layer depth (m)
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin)
real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm)
real(r8), pointer :: bsw(:,:) ! Clapp and Hornberger "b"
real(r8), pointer :: rootfr(:,:) ! fraction of roots in each soil layer
real(r8), pointer :: dleaf(:) ! characteristic leaf dimension (m)
real(r8), pointer :: smpso(:) ! soil water potential at full stomatal opening (mm)
real(r8), pointer :: smpsc(:) ! soil water potential at full stomatal closure (mm)
real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1)
real(r8), pointer :: htop(:) ! canopy top(m)
real(r8), pointer :: snowdp(:) ! snow height (m)
real(r8), pointer :: soilbeta(:) ! soil wetness relative to field capacity
real(r8), pointer :: lat(:) ! latitude (radians)
real(r8), pointer :: decl(:) ! declination angle (radians)
real(r8), pointer :: max_dayl(:) !maximum daylength for this column (s)
!
! local pointers to implicit inout arguments
!
real(r8), pointer :: cgrnds(:) ! deriv. of soil sensible heat flux wrt soil temp [w/m2/k]
real(r8), pointer :: cgrndl(:) ! deriv. of soil latent heat flux wrt soil temp [w/m**2/k]
real(r8), pointer :: t_veg(:) ! vegetation temperature (Kelvin)
real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (Kelvin)
real(r8), pointer :: q_ref2m(:) ! 2 m height surface specific humidity (kg/kg)
real(r8), pointer :: t_ref2m_r(:) ! Rural 2 m height surface air temperature (Kelvin)
real(r8), pointer :: rh_ref2m(:) ! 2 m height surface relative humidity (%)
real(r8), pointer :: rh_ref2m_r(:) ! Rural 2 m height surface relative humidity (%)
real(r8), pointer :: h2ocan(:) ! canopy water (mm H2O)
real(r8), pointer :: cisun(:) !sunlit intracellular CO2 (Pa)
real(r8), pointer :: cisha(:) !shaded intracellular CO2 (Pa)
!
! local pointers to implicit out arguments
!
real(r8), pointer :: rb1(:) ! boundary layer resistance (s/m)
real(r8), pointer :: cgrnd(:) ! deriv. of soil energy flux wrt to soil temp [w/m2/k]
real(r8), pointer :: dlrad(:) ! downward longwave radiation below the canopy [W/m2]
real(r8), pointer :: ulrad(:) ! upward longwave radiation above the canopy [W/m2]
real(r8), pointer :: ram1(:) ! aerodynamical resistance (s/m)
real(r8), pointer :: btran(:) ! transpiration wetness factor (0 to 1)
real(r8), pointer :: rssun(:) ! sunlit stomatal resistance (s/m)
real(r8), pointer :: rssha(:) ! shaded stomatal resistance (s/m)
real(r8), pointer :: psnsun(:) ! sunlit leaf photosynthesis (umol CO2 /m**2/ s)
real(r8), pointer :: psnsha(:) ! shaded leaf photosynthesis (umol CO2 /m**2/ s)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
real(r8), pointer :: c13_psnsun(:) ! sunlit leaf photosynthesis (umol 13CO2 /m**2/ s)
real(r8), pointer :: c13_psnsha(:) ! shaded leaf photosynthesis (umol 13CO2 /m**2/ s)
! 4/21/05: PET
! Adding isotope code
real(r8), pointer :: rc13_canair(:) !C13O2/C12O2 in canopy air
real(r8), pointer :: rc13_psnsun(:) !C13O2/C12O2 in sunlit canopy psn flux
real(r8), pointer :: rc13_psnsha(:) !C13O2/C12O2 in shaded canopy psn flux
real(r8), pointer :: alphapsnsun(:) !fractionation factor in sunlit canopy psn flux
real(r8), pointer :: alphapsnsha(:) !fractionation factor in shaded canopy psn flux
#endif
real(r8), pointer :: qflx_tran_veg(:) ! vegetation transpiration (mm H2O/s) (+ = to atm)
real(r8), pointer :: dt_veg(:) ! change in t_veg, last iteration (Kelvin)
real(r8), pointer :: qflx_evap_veg(:) ! vegetation evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: eflx_sh_veg(:) ! sensible heat flux from leaves (W/m**2) [+ to atm]
real(r8), pointer :: taux(:) ! wind (shear) stress: e-w (kg/m/s**2)
real(r8), pointer :: tauy(:) ! wind (shear) stress: n-s (kg/m/s**2)
real(r8), pointer :: eflx_sh_grnd(:) ! sensible heat flux from ground (W/m**2) [+ to atm]
real(r8), pointer :: qflx_evap_soi(:) ! soil evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: fpsn(:) ! photosynthesis (umol CO2 /m**2 /s)
real(r8), pointer :: rootr(:,:) ! effective fraction of roots in each soil layer
real(r8), pointer :: rresis(:,:) ! root resistance by layer (0-1) (nlevgrnd)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
real(r8), parameter :: btran0 = 0.0_r8 ! initial value
real(r8), parameter :: zii = 1000.0_r8 ! convective boundary layer height [m]
real(r8), parameter :: beta = 1.0_r8 ! coefficient of conective velocity [-]
real(r8), parameter :: delmax = 1.0_r8 ! maxchange in leaf temperature [K]
real(r8), parameter :: dlemin = 0.1_r8 ! max limit for energy flux convergence [w/m2]
real(r8), parameter :: dtmin = 0.01_r8 ! max limit for temperature convergence [K]
integer , parameter :: itmax = 40 ! maximum number of iteration [-]
integer , parameter :: itmin = 2 ! minimum number of iteration [-]
!added by K.Sakaguchi for litter resistance
real(r8), parameter :: lai_dl = 0.5_r8 ! placeholder for (dry) plant litter area index (m2/m2)
real(r8), parameter :: z_dl = 0.05_r8 ! placeholder for (dry) litter layer thickness (m)
!added by K.Sakaguchi for stability formulation
real(r8), parameter :: ria = 0.5_r8 ! free parameter for stable formulation (currently = 0.5, "gamma" in Sakaguchi&Zeng,2008)
real(r8) :: zldis(lbp:ubp) ! reference height "minus" zero displacement height [m]
real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory
real(r8) :: wc ! convective velocity [m/s]
real(r8) :: dth(lbp:ubp) ! diff of virtual temp. between ref. height and surface
real(r8) :: dthv(lbp:ubp) ! diff of vir. poten. temp. between ref. height and surface
real(r8) :: dqh(lbp:ubp) ! diff of humidity between ref. height and surface
real(r8) :: obu(lbp:ubp) ! Monin-Obukhov length (m)
real(r8) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s]
real(r8) :: ur(lbp:ubp) ! wind speed at reference height [m/s]
real(r8) :: uaf(lbp:ubp) ! velocity of air within foliage [m/s]
real(r8) :: temp1(lbp:ubp) ! relation for potential temperature profile
real(r8) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m
real(r8) :: temp2(lbp:ubp) ! relation for specific humidity profile
real(r8) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m
real(r8) :: ustar(lbp:ubp) ! friction velocity [m/s]
real(r8) :: tstar ! temperature scaling parameter
real(r8) :: qstar ! moisture scaling parameter
real(r8) :: thvstar ! virtual potential temperature scaling parameter
real(r8) :: taf(lbp:ubp) ! air temperature within canopy space [K]
real(r8) :: qaf(lbp:ubp) ! humidity of canopy air [kg/kg]
real(r8) :: rpp ! fraction of potential evaporation from leaf [-]
real(r8) :: rppdry ! fraction of potential evaporation through transp [-]
real(r8) :: cf ! heat transfer coefficient from leaves [-]
real(r8) :: rb(lbp:ubp) ! leaf boundary layer resistance [s/m]
real(r8) :: rah(lbp:ubp,2) ! thermal resistance [s/m]
real(r8) :: raw(lbp:ubp,2) ! moisture resistance [s/m]
real(r8) :: wta ! heat conductance for air [m/s]
real(r8) :: wtg(lbp:ubp) ! heat conductance for ground [m/s]
real(r8) :: wtl ! heat conductance for leaf [m/s]
real(r8) :: wta0(lbp:ubp) ! normalized heat conductance for air [-]
real(r8) :: wtl0(lbp:ubp) ! normalized heat conductance for leaf [-]
real(r8) :: wtg0 ! normalized heat conductance for ground [-]
real(r8) :: wtal(lbp:ubp) ! normalized heat conductance for air and leaf [-]
real(r8) :: wtga ! normalized heat cond. for air and ground [-]
real(r8) :: wtaq ! latent heat conductance for air [m/s]
real(r8) :: wtlq ! latent heat conductance for leaf [m/s]
real(r8) :: wtgq(lbp:ubp) ! latent heat conductance for ground [m/s]
real(r8) :: wtaq0(lbp:ubp) ! normalized latent heat conductance for air [-]
real(r8) :: wtlq0(lbp:ubp) ! normalized latent heat conductance for leaf [-]
real(r8) :: wtgq0 ! normalized heat conductance for ground [-]
real(r8) :: wtalq(lbp:ubp) ! normalized latent heat cond. for air and leaf [-]
real(r8) :: wtgaq ! normalized latent heat cond. for air and ground [-]
real(r8) :: el(lbp:ubp) ! vapor pressure on leaf surface [pa]
real(r8) :: deldT ! derivative of "el" on "t_veg" [pa/K]
real(r8) :: qsatl(lbp:ubp) ! leaf specific humidity [kg/kg]
real(r8) :: qsatldT(lbp:ubp) ! derivative of "qsatl" on "t_veg"
real(r8) :: e_ref2m ! 2 m height surface saturated vapor pressure [Pa]
real(r8) :: de2mdT ! derivative of 2 m height surface saturated vapor pressure on t_ref2m
real(r8) :: qsat_ref2m ! 2 m height surface saturated specific humidity [kg/kg]
real(r8) :: dqsat2mdT ! derivative of 2 m height surface saturated specific humidity on t_ref2m
real(r8) :: air(lbp:ubp),bir(lbp:ubp),cir(lbp:ubp) ! atmos. radiation temporay set
real(r8) :: dc1,dc2 ! derivative of energy flux [W/m2/K]
real(r8) :: delt ! temporary
real(r8) :: delq(lbp:ubp) ! temporary
real(r8) :: del(lbp:ubp) ! absolute change in leaf temp in current iteration [K]
real(r8) :: del2(lbp:ubp) ! change in leaf temperature in previous iteration [K]
real(r8) :: dele(lbp:ubp) ! change in latent heat flux from leaf [K]
real(r8) :: dels ! change in leaf temperature in current iteration [K]
real(r8) :: det(lbp:ubp) ! maximum leaf temp. change in two consecutive iter [K]
real(r8) :: efeb(lbp:ubp) ! latent heat flux from leaf (previous iter) [mm/s]
real(r8) :: efeold ! latent heat flux from leaf (previous iter) [mm/s]
real(r8) :: efpot ! potential latent energy flux [kg/m2/s]
real(r8) :: efe(lbp:ubp) ! water flux from leaf [mm/s]
real(r8) :: efsh ! sensible heat from leaf [mm/s]
real(r8) :: obuold(lbp:ubp) ! monin-obukhov length from previous iteration
real(r8) :: tlbef(lbp:ubp) ! leaf temperature from previous iteration [K]
real(r8) :: ecidif ! excess energies [W/m2]
real(r8) :: err(lbp:ubp) ! balance error
real(r8) :: erre ! balance error
real(r8) :: co2(lbp:ubp) ! atmospheric co2 partial pressure (pa)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
real(r8) :: c13o2(lbp:ubp) ! atmospheric c13o2 partial pressure (pa)
#endif
real(r8) :: o2(lbp:ubp) ! atmospheric o2 partial pressure (pa)
real(r8) :: svpts(lbp:ubp) ! saturation vapor pressure at t_veg (pa)
real(r8) :: eah(lbp:ubp) ! canopy air vapor pressure (pa)
real(r8) :: s_node ! vol_liq/eff_porosity
real(r8) :: smp_node ! matrix potential
real(r8) :: vol_ice ! partial volume of ice lens in layer
real(r8) :: eff_porosity ! effective porosity in layer
real(r8) :: vol_liq ! partial volume of liquid water in layer
integer :: itlef ! counter for leaf temperature iteration [-]
integer :: nmozsgn(lbp:ubp) ! number of times stability changes sign
real(r8) :: w ! exp(-LSAI)
real(r8) :: csoilcn ! interpolated csoilc for less than dense canopies
real(r8) :: fm(lbp:ubp) ! needed for BGC only to diagnose 10m wind speed
real(r8) :: wtshi ! sensible heat resistance for air, grnd and leaf [-]
real(r8) :: wtsqi ! latent heat resistance for air, grnd and leaf [-]
integer :: j ! soil/snow level index
integer :: p ! pft index
integer :: c ! column index
integer :: l ! landunit index
integer :: g ! gridcell index
integer :: fp ! lake filter pft index
integer :: fn ! number of values in pft filter
integer :: fnorig ! number of values in pft filter copy
integer :: fnold ! temporary copy of pft count
integer :: f ! filter index
integer :: filterp(ubp-lbp+1) ! temporary filter
integer :: fporig(ubp-lbp+1) ! temporary filter
real(r8) :: displa_loc(lbp:ubp) ! temporary copy
real(r8) :: z0mv_loc(lbp:ubp) ! temporary copy
real(r8) :: z0hv_loc(lbp:ubp) ! temporary copy
real(r8) :: z0qv_loc(lbp:ubp) ! temporary copy
logical :: found ! error flag for canopy above forcing hgt
integer :: index ! pft index for error
real(r8) :: egvf ! effective green vegetation fraction
real(r8) :: lt ! elai+esai
real(r8) :: ri ! stability parameter for under canopy air (unitless)
real(r8) :: csoilb ! turbulent transfer coefficient over bare soil (unitless)
real(r8) :: ricsoilc ! modified transfer coefficient under dense canopy (unitless)
real(r8) :: snowdp_c ! critical snow depth to cover plant litter (m)
real(r8) :: rdl ! dry litter layer resistance for water vapor (s/m)
real(r8) :: elai_dl ! exposed (dry) plant litter area index
real(r8) :: fsno_dl ! effective snow cover over plant litter
real(r8) :: dayl ! daylength (s)
real(r8) :: temp ! temporary, for daylength calculation
real(r8) :: dayl_factor(lbp:ubp) ! scalar (0-1) for daylength effect on Vcmax
!------------------------------------------------------------------------------
! Assign local pointers to derived type members (gridcell-level)
forc_lwrad => clm_a2l%forc_lwrad
forc_pco2 => clm_a2l%forc_pco2
#if (defined C13)
forc_pc13o2 => clm_a2l%forc_pc13o2
#endif
forc_po2 => clm_a2l%forc_po2
forc_q => clm_a2l%forc_q
forc_pbot => clm_a2l%forc_pbot
forc_u => clm_a2l%forc_u
forc_v => clm_a2l%forc_v
forc_th => clm_a2l%forc_th
forc_rho => clm_a2l%forc_rho
lat => clm3%g%lat
! Assign local pointers to derived type members (column-level)
t_soisno => clm3%g%l%c%ces%t_soisno
watsat => clm3%g%l%c%cps%watsat
watdry => clm3%g%l%c%cps%watdry
watopt => clm3%g%l%c%cps%watopt
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
dz => clm3%g%l%c%cps%dz
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
sucsat => clm3%g%l%c%cps%sucsat
bsw => clm3%g%l%c%cps%bsw
emg => clm3%g%l%c%cps%emg
t_grnd => clm3%g%l%c%ces%t_grnd
qg => clm3%g%l%c%cws%qg
thv => clm3%g%l%c%ces%thv
dqgdT => clm3%g%l%c%cws%dqgdT
htvp => clm3%g%l%c%cps%htvp
z0mg => clm3%g%l%c%cps%z0mg
frac_sno => clm3%g%l%c%cps%frac_sno
snowdp => clm3%g%l%c%cps%snowdp
soilbeta => clm3%g%l%c%cws%soilbeta
decl => clm3%g%l%c%cps%decl
max_dayl => clm3%g%l%c%cps%max_dayl
! Assign local pointers to derived type members (pft-level)
rb1 => clm3%g%l%c%p%pps%rb1
ivt => clm3%g%l%c%p%itype
pcolumn => clm3%g%l%c%p%column
plandunit => clm3%g%l%c%p%landunit
pgridcell => clm3%g%l%c%p%gridcell
frac_veg_nosno => clm3%g%l%c%p%pps%frac_veg_nosno
btran => clm3%g%l%c%p%pps%btran
rootfr => clm3%g%l%c%p%pps%rootfr
rootr => clm3%g%l%c%p%pps%rootr
rresis => clm3%g%l%c%p%pps%rresis
emv => clm3%g%l%c%p%pps%emv
t_veg => clm3%g%l%c%p%pes%t_veg
displa => clm3%g%l%c%p%pps%displa
z0mv => clm3%g%l%c%p%pps%z0mv
z0hv => clm3%g%l%c%p%pps%z0hv
z0qv => clm3%g%l%c%p%pps%z0qv
ram1 => clm3%g%l%c%p%pps%ram1
htop => clm3%g%l%c%p%pps%htop
rssun => clm3%g%l%c%p%pps%rssun
rssha => clm3%g%l%c%p%pps%rssha
cisun => clm3%g%l%c%p%pps%cisun
cisha => clm3%g%l%c%p%pps%cisha
psnsun => clm3%g%l%c%p%pcf%psnsun
psnsha => clm3%g%l%c%p%pcf%psnsha
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
c13_psnsun => clm3%g%l%c%p%pc13f%psnsun
c13_psnsha => clm3%g%l%c%p%pc13f%psnsha
! 4/21/05: PET
! Adding isotope code
rc13_canair => clm3%g%l%c%p%pepv%rc13_canair
rc13_psnsun => clm3%g%l%c%p%pepv%rc13_psnsun
rc13_psnsha => clm3%g%l%c%p%pepv%rc13_psnsha
alphapsnsun => clm3%g%l%c%p%pps%alphapsnsun
alphapsnsha => clm3%g%l%c%p%pps%alphapsnsha
#endif
elai => clm3%g%l%c%p%pps%elai
esai => clm3%g%l%c%p%pps%esai
fdry => clm3%g%l%c%p%pps%fdry
laisun => clm3%g%l%c%p%pps%laisun
laisha => clm3%g%l%c%p%pps%laisha
qflx_tran_veg => clm3%g%l%c%p%pwf%qflx_tran_veg
fwet => clm3%g%l%c%p%pps%fwet
h2ocan => clm3%g%l%c%p%pws%h2ocan
dt_veg => clm3%g%l%c%p%pps%dt_veg
sabv => clm3%g%l%c%p%pef%sabv
qflx_evap_veg => clm3%g%l%c%p%pwf%qflx_evap_veg
eflx_sh_veg => clm3%g%l%c%p%pef%eflx_sh_veg
taux => clm3%g%l%c%p%pmf%taux
tauy => clm3%g%l%c%p%pmf%tauy
eflx_sh_grnd => clm3%g%l%c%p%pef%eflx_sh_grnd
qflx_evap_soi => clm3%g%l%c%p%pwf%qflx_evap_soi
t_ref2m => clm3%g%l%c%p%pes%t_ref2m
q_ref2m => clm3%g%l%c%p%pes%q_ref2m
t_ref2m_r => clm3%g%l%c%p%pes%t_ref2m_r
rh_ref2m_r => clm3%g%l%c%p%pes%rh_ref2m_r
rh_ref2m => clm3%g%l%c%p%pes%rh_ref2m
dlrad => clm3%g%l%c%p%pef%dlrad
ulrad => clm3%g%l%c%p%pef%ulrad
cgrnds => clm3%g%l%c%p%pef%cgrnds
cgrndl => clm3%g%l%c%p%pef%cgrndl
cgrnd => clm3%g%l%c%p%pef%cgrnd
fpsn => clm3%g%l%c%p%pcf%fpsn
forc_hgt_u_pft => clm3%g%l%c%p%pps%forc_hgt_u_pft
thm => clm3%g%l%c%p%pes%thm
! Assign local pointers to derived type members (ecophysiological)
dleaf => pftcon%dleaf
smpso => pftcon%smpso
smpsc => pftcon%smpsc
! Filter pfts where frac_veg_nosno is non-zero
fn = 0
do fp = 1,num_nolakep
p = filter_nolakep(fp)
if (frac_veg_nosno(p) /= 0) then
fn = fn + 1
filterp(fn) = p
end if
end do
! Initialize
do f = 1, fn
p = filterp(f)
del(p) = 0._r8 ! change in leaf temperature from previous iteration
efeb(p) = 0._r8 ! latent head flux from leaf for previous iteration
wtlq0(p) = 0._r8
wtalq(p) = 0._r8
wtgq(p) = 0._r8
wtaq0(p) = 0._r8
obuold(p) = 0._r8
btran(p) = btran0
end do
! calculate daylength control for Vcmax
do f = 1, fn
p=filterp(f)
c=pcolumn(p)
g=pgridcell(p)
! calculate daylength
temp = -(sin(lat(g))*sin(decl(c)))/(cos(lat(g)) * cos(decl(c)))
temp = min(1._r8,max(-1._r8,temp))
dayl = 2.0_r8 * 13750.9871_r8 * acos(temp)
! calculate dayl_factor as the ratio of (current:max dayl)^2
! set a minimum of 0.01 (1%) for the dayl_factor
dayl_factor(p)=min(1._r8,max(0.01_r8,(dayl*dayl)/(max_dayl(c)*max_dayl(c))))
#if (defined NO_DAYLEN_VCMAX)
dayl_factor(p) = 1.0_r8
#endif
end do
rb1(lbp:ubp) = 0._r8
! Effective porosity of soil, partial volume of ice and liquid (needed for btran)
! and root resistance factors
do j = 1,nlevgrnd
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
l = plandunit(p)
! Root resistance factors
vol_ice = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice))
eff_porosity = watsat(c,j)-vol_ice
vol_liq = min(eff_porosity, h2osoi_liq(c,j)/(dz(c,j)*denh2o))
if (vol_liq .le. 0._r8 .or. t_soisno(c,j) .le. tfrz-2._r8) then
rootr(p,j) = 0._r8
else
s_node = max(vol_liq/eff_porosity,0.01_r8)
smp_node = max(smpsc(ivt(p)), -sucsat(c,j)*s_node**(-bsw(c,j)))
rresis(p,j) = min( (eff_porosity/watsat(c,j))* &
(smp_node - smpsc(ivt(p))) / (smpso(ivt(p)) - smpsc(ivt(p))), 1._r8)
rootr(p,j) = rootfr(p,j)*rresis(p,j)
btran(p) = btran(p) + rootr(p,j)
endif
end do
end do
! Normalize root resistances to get layer contribution to ET
do j = 1,nlevgrnd
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
if (btran(p) .gt. btran0) then
rootr(p,j) = rootr(p,j)/btran(p)
else
rootr(p,j) = 0._r8
end if
end do
end do
! Modify aerodynamic parameters for sparse/dense canopy (X. Zeng)
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
lt = min(elai(p)+esai(p), tlsai_crit)
egvf =(1._r8 - alpha_aero * exp(-lt)) / (1._r8 - alpha_aero * exp(-tlsai_crit))
displa(p) = egvf * displa(p)
z0mv(p) = exp(egvf * log(z0mv(p)) + (1._r8 - egvf) * log(z0mg(c)))
z0hv(p) = z0mv(p)
z0qv(p) = z0mv(p)
end do
found = .false.
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
g = pgridcell(p)
! Net absorbed longwave radiation by canopy and ground
! =air+bir*t_veg**4+cir*t_grnd(c)**4
air(p) = emv(p) * (1._r8+(1._r8-emv(p))*(1._r8-emg(c))) * forc_lwrad(g)
bir(p) = - (2._r8-emv(p)*(1._r8-emg(c))) * emv(p) * sb
cir(p) = emv(p)*emg(c)*sb
! Saturated vapor pressure, specific humidity, and their derivatives
! at the leaf surface
call QSat (t_veg(p), forc_pbot(g), el(p), deldT, qsatl(p), qsatldT(p))
! Determine atmospheric co2 and o2
co2(p) = forc_pco2(g)
o2(p) = forc_po2(g)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
c13o2(p) = forc_pc13o2(g)
#endif
! Initialize flux profile
nmozsgn(p) = 0
taf(p) = (t_grnd(c) + thm(p))/2._r8
qaf(p) = (forc_q(g)+qg(c))/2._r8
ur(p) = max(1.0_r8,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g)))
dth(p) = thm(p)-taf(p)
dqh(p) = forc_q(g)-qaf(p)
delq(p) = qg(c) - qaf(p)
dthv(p) = dth(p)*(1._r8+0.61_r8*forc_q(g))+0.61_r8*forc_th(g)*dqh(p)
zldis(p) = forc_hgt_u_pft(p) - displa(p)
! Check to see if the forcing height is below the canopy height
if (zldis(p) < 0._r8) then
found = .true.
index = p
end if
end do
if (found) then
write(6,*)'Error: Forcing height is below canopy height for pft index ',index
call endrun()
end if
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
! Initialize Monin-Obukhov length and wind speed
call MoninObukIni(ur(p), thv(c), dthv(p), zldis(p), z0mv(p), um(p), obu(p))
end do
! Set counter for leaf temperature iteration (itlef)
itlef = 0
fnorig = fn
fporig(1:fn) = filterp(1:fn)
! Make copies so that array sections are not passed in function calls to friction velocity
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
displa_loc(p) = displa(p)
z0mv_loc(p) = z0mv(p)
z0hv_loc(p) = z0hv(p)
z0qv_loc(p) = z0qv(p)
end do
! Begin stability iteration
ITERATION : do while (itlef <= itmax .and. fn > 0)
! Determine friction velocity, and potential temperature and humidity
! profiles of the surface boundary layer
call FrictionVelocity (lbp, ubp, fn, filterp, &
displa_loc, z0mv_loc, z0hv_loc, z0qv_loc, &
obu, itlef+1, ur, um, ustar, &
temp1, temp2, temp12m, temp22m, fm)
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
g = pgridcell(p)
tlbef(p) = t_veg(p)
del2(p) = del(p)
! Determine aerodynamic resistances
ram1(p) = 1._r8/(ustar(p)*ustar(p)/um(p))
rah(p,1) = 1._r8/(temp1(p)*ustar(p))
raw(p,1) = 1._r8/(temp2(p)*ustar(p))
! Bulk boundary layer resistance of leaves
uaf(p) = um(p)*sqrt( 1._r8/(ram1(p)*um(p)) )
cf = 0.01_r8/(sqrt(uaf(p))*sqrt(dleaf(ivt(p))))
rb(p) = 1._r8/(cf*uaf(p))
rb1(p) = rb(p)
! Parameterization for variation of csoilc with canopy density from
! X. Zeng, University of Arizona
w = exp(-(elai(p)+esai(p)))
! changed by K.Sakaguchi from here
! transfer coefficient over bare soil is changed to a local variable
! just for readability of the code (from line 680)
csoilb = (vkc/(0.13_r8*(z0mg(c)*uaf(p)/1.5e-5_r8)**0.45_r8))
!compute the stability parameter for ricsoilc ("S" in Sakaguchi&Zeng,2008)
ri = ( grav*htop(p) * (taf(p) - t_grnd(c)) ) / (taf(p) * uaf(p) **2.00_r8)
!! modify csoilc value (0.004) if the under-canopy is in stable condition
if ( (taf(p) - t_grnd(c) ) > 0._r8) then
! decrease the value of csoilc by dividing it with (1+gamma*min(S, 10.0))
! ria ("gmanna" in Sakaguchi&Zeng, 2008) is a constant (=0.5)
ricsoilc = csoilc / (1.00_r8 + ria*min( ri, 10.0_r8) )
csoilcn = csoilb*w + ricsoilc*(1._r8-w)
else
csoilcn = csoilb*w + csoilc*(1._r8-w)
end if
!! Sakaguchi changes for stability formulation ends here
rah(p,2) = 1._r8/(csoilcn*uaf(p))
raw(p,2) = rah(p,2)
! Stomatal resistances for sunlit and shaded fractions of canopy.
! Done each iteration to account for differences in eah, tv.
svpts(p) = el(p) ! pa
eah(p) = forc_pbot(g) * qaf(p) / 0.622_r8 ! pa
end do
! 4/25/05, PET: Now calling the sun/shade version of Stomata by default
call Stomata (fn, filterp, lbp, ubp, svpts, eah, o2, co2, rb, dayl_factor, phase='sun')
call Stomata (fn, filterp, lbp, ubp, svpts, eah, o2, co2, rb, dayl_factor, phase='sha')
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
g = pgridcell(p)
! Sensible heat conductance for air, leaf and ground
! Moved the original subroutine in-line...
wta = 1._r8/rah(p,1) ! air
wtl = (elai(p)+esai(p))/rb(p) ! leaf
wtg(p) = 1._r8/rah(p,2) ! ground
wtshi = 1._r8/(wta+wtl+wtg(p))
wtl0(p) = wtl*wtshi ! leaf
wtg0 = wtg(p)*wtshi ! ground
wta0(p) = wta*wtshi ! air
wtga = wta0(p)+wtg0 ! ground + air
wtal(p) = wta0(p)+wtl0(p) ! air + leaf
! Fraction of potential evaporation from leaf
if (fdry(p) .gt. 0._r8) then
rppdry = fdry(p)*rb(p)*(laisun(p)/(rb(p)+rssun(p)) + &
laisha(p)/(rb(p)+rssha(p)))/elai(p)
else
rppdry = 0._r8
end if
efpot = forc_rho(g)*wtl*(qsatl(p)-qaf(p))
if (efpot > 0._r8) then
if (btran(p) > btran0) then
qflx_tran_veg(p) = efpot*rppdry
rpp = rppdry + fwet(p)
else
!No transpiration if btran below 1.e-10
rpp = fwet(p)
qflx_tran_veg(p) = 0._r8
end if
!Check total evapotranspiration from leaves
rpp = min(rpp, (qflx_tran_veg(p)+h2ocan(p)/dtime)/efpot)
else
!No transpiration if potential evaporation less than zero
rpp = 1._r8
qflx_tran_veg(p) = 0._r8
end if
! Update conductances for changes in rpp
! Latent heat conductances for ground and leaf.
! Air has same conductance for both sensible and latent heat.
! Moved the original subroutine in-line...
wtaq = frac_veg_nosno(p)/raw(p,1) ! air
wtlq = frac_veg_nosno(p)*(elai(p)+esai(p))/rb(p) * rpp ! leaf
!Litter layer resistance. Added by K.Sakaguchi
snowdp_c = z_dl ! critical depth for 100% litter burial by snow (=litter thickness)
fsno_dl = snowdp(c)/snowdp_c ! effective snow cover for (dry)plant litter
elai_dl = lai_dl*(1._r8 - min(fsno_dl,1._r8)) ! exposed (dry)litter area index
rdl = ( 1._r8 - exp(-elai_dl) ) / ( 0.004_r8*uaf(p)) ! dry litter layer resistance
! add litter resistance and Lee and Pielke 1992 beta
if (delq(p) .lt. 0._r8) then !dew. Do not apply beta for negative flux (follow old rsoil)
wtgq(p) = frac_veg_nosno(p)/(raw(p,2)+rdl)
else
wtgq(p) = soilbeta(c)*frac_veg_nosno(p)/(raw(p,2)+rdl)
end if
wtsqi = 1._r8/(wtaq+wtlq+wtgq(p))
wtgq0 = wtgq(p)*wtsqi ! ground
wtlq0(p) = wtlq*wtsqi ! leaf
wtaq0(p) = wtaq*wtsqi ! air
wtgaq = wtaq0(p)+wtgq0 ! air + ground
wtalq(p) = wtaq0(p)+wtlq0(p) ! air + leaf
dc1 = forc_rho(g)*cpair*wtl
dc2 = hvap*forc_rho(g)*wtlq
efsh = dc1*(wtga*t_veg(p)-wtg0*t_grnd(c)-wta0(p)*thm(p))
efe(p) = dc2*(wtgaq*qsatl(p)-wtgq0*qg(c)-wtaq0(p)*forc_q(g))
! Evaporation flux from foliage
erre = 0._r8
if (efe(p)*efeb(p) < 0._r8) then
efeold = efe(p)
efe(p) = 0.1_r8*efeold
erre = efe(p) - efeold
end if
dt_veg(p) = (sabv(p) + air(p) + bir(p)*t_veg(p)**4 + &
cir(p)*t_grnd(c)**4 - efsh - efe(p)) / &
(- 4._r8*bir(p)*t_veg(p)**3 +dc1*wtga +dc2*wtgaq*qsatldT(p))
t_veg(p) = tlbef(p) + dt_veg(p)
dels = dt_veg(p)
del(p) = abs(dels)
err(p) = 0._r8
if (del(p) > delmax) then
dt_veg(p) = delmax*dels/del(p)
t_veg(p) = tlbef(p) + dt_veg(p)
err(p) = sabv(p) + air(p) + bir(p)*tlbef(p)**3*(tlbef(p) + &
4._r8*dt_veg(p)) + cir(p)*t_grnd(c)**4 - &
(efsh + dc1*wtga*dt_veg(p)) - (efe(p) + &
dc2*wtgaq*qsatldT(p)*dt_veg(p))
end if
! Fluxes from leaves to canopy space
! "efe" was limited as its sign changes frequently. This limit may
! result in an imbalance in "hvap*qflx_evap_veg" and
! "efe + dc2*wtgaq*qsatdt_veg"
efpot = forc_rho(g)*wtl*(wtgaq*(qsatl(p)+qsatldT(p)*dt_veg(p)) &
-wtgq0*qg(c)-wtaq0(p)*forc_q(g))
qflx_evap_veg(p) = rpp*efpot
! Calculation of evaporative potentials (efpot) and
! interception losses; flux in kg m**-2 s-1. ecidif
! holds the excess energy if all intercepted water is evaporated
! during the timestep. This energy is later added to the
! sensible heat flux.
ecidif = 0._r8
if (efpot > 0._r8 .and. btran(p) > btran0) then
qflx_tran_veg(p) = efpot*rppdry
else
qflx_tran_veg(p) = 0._r8
end if
ecidif = max(0._r8, qflx_evap_veg(p)-qflx_tran_veg(p)-h2ocan(p)/dtime)
qflx_evap_veg(p) = min(qflx_evap_veg(p),qflx_tran_veg(p)+h2ocan(p)/dtime)
! The energy loss due to above two limits is added to
! the sensible heat flux.
eflx_sh_veg(p) = efsh + dc1*wtga*dt_veg(p) + err(p) + erre + hvap*ecidif
! Re-calculate saturated vapor pressure, specific humidity, and their
! derivatives at the leaf surface
call QSat(t_veg(p), forc_pbot(g), el(p), deldT, qsatl(p), qsatldT(p))
! Update vegetation/ground surface temperature, canopy air
! temperature, canopy vapor pressure, aerodynamic temperature, and
! Monin-Obukhov stability parameter for next iteration.
taf(p) = wtg0*t_grnd(c) + wta0(p)*thm(p) + wtl0(p)*t_veg(p)
qaf(p) = wtlq0(p)*qsatl(p) + wtgq0*qg(c) + forc_q(g)*wtaq0(p)
! Update Monin-Obukhov length and wind speed including the
! stability effect
dth(p) = thm(p)-taf(p)
dqh(p) = forc_q(g)-qaf(p)
delq(p) = wtalq(p)*qg(c)-wtlq0(p)*qsatl(p)-wtaq0(p)*forc_q(g)
tstar = temp1(p)*dth(p)
qstar = temp2(p)*dqh(p)
thvstar = tstar*(1._r8+0.61_r8*forc_q(g)) + 0.61_r8*forc_th(g)*qstar
zeta = zldis(p)*vkc*grav*thvstar/(ustar(p)**2*thv(c))
if (zeta >= 0._r8) then !stable
zeta = min(2._r8,max(zeta,0.01_r8))
um(p) = max(ur(p),0.1_r8)
else !unstable
zeta = max(-100._r8,min(zeta,-0.01_r8))
wc = beta*(-grav*ustar(p)*thvstar*zii/thv(c))**0.333_r8
um(p) = sqrt(ur(p)*ur(p)+wc*wc)
end if
obu(p) = zldis(p)/zeta
if (obuold(p)*obu(p) < 0._r8) nmozsgn(p) = nmozsgn(p)+1
if (nmozsgn(p) >= 4) obu(p) = zldis(p)/(-0.01_r8)
obuold(p) = obu(p)
end do ! end of filtered pft loop
! Test for convergence
itlef = itlef+1
if (itlef > itmin) then
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
dele(p) = abs(efe(p)-efeb(p))
efeb(p) = efe(p)
det(p) = max(del(p),del2(p))
end do
fnold = fn
fn = 0
do f = 1, fnold
p = filterp(f)
if (.not. (det(p) < dtmin .and. dele(p) < dlemin)) then
fn = fn + 1
filterp(fn) = p
end if
end do
end if
end do ITERATION ! End stability iteration
fn = fnorig
filterp(1:fn) = fporig(1:fn)
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
g = pgridcell(p)
! Energy balance check in canopy
err(p) = sabv(p) + air(p) + bir(p)*tlbef(p)**3*(tlbef(p) + 4._r8*dt_veg(p)) &
+ cir(p)*t_grnd(c)**4 - eflx_sh_veg(p) - hvap*qflx_evap_veg(p)
! Fluxes from ground to canopy space
delt = wtal(p)*t_grnd(c)-wtl0(p)*t_veg(p)-wta0(p)*thm(p)
taux(p) = -forc_rho(g)*forc_u(g)/ram1(p)
tauy(p) = -forc_rho(g)*forc_v(g)/ram1(p)
eflx_sh_grnd(p) = cpair*forc_rho(g)*wtg(p)*delt
qflx_evap_soi(p) = forc_rho(g)*wtgq(p)*delq(p)
! 2 m height air temperature
t_ref2m(p) = thm(p) + temp1(p)*dth(p)*(1._r8/temp12m(p) - 1._r8/temp1(p))
t_ref2m_r(p) = t_ref2m(p)
! 2 m height specific humidity
q_ref2m(p) = forc_q(g) + temp2(p)*dqh(p)*(1._r8/temp22m(p) - 1._r8/temp2(p))
! 2 m height relative humidity
call QSat(t_ref2m(p), forc_pbot(g), e_ref2m, de2mdT, qsat_ref2m, dqsat2mdT)
rh_ref2m(p) = min(100._r8, q_ref2m(p) / qsat_ref2m * 100._r8)
rh_ref2m_r(p) = rh_ref2m(p)
! Downward longwave radiation below the canopy
dlrad(p) = (1._r8-emv(p))*emg(c)*forc_lwrad(g) + &
emv(p)*emg(c)*sb*tlbef(p)**3*(tlbef(p) + 4._r8*dt_veg(p))
! Upward longwave radiation above the canopy
ulrad(p) = ((1._r8-emg(c))*(1._r8-emv(p))*(1._r8-emv(p))*forc_lwrad(g) &
+ emv(p)*(1._r8+(1._r8-emg(c))*(1._r8-emv(p)))*sb*tlbef(p)**3*(tlbef(p) + &
4._r8*dt_veg(p)) + emg(c)*(1._r8-emv(p))*sb*t_grnd(c)**4)
! Derivative of soil energy flux with respect to soil temperature
cgrnds(p) = cgrnds(p) + cpair*forc_rho(g)*wtg(p)*wtal(p)
cgrndl(p) = cgrndl(p) + forc_rho(g)*wtgq(p)*wtalq(p)*dqgdT(c)
cgrnd(p) = cgrnds(p) + cgrndl(p)*htvp(c)
! Update dew accumulation (kg/m2)
h2ocan(p) = max(0._r8,h2ocan(p)+(qflx_tran_veg(p)-qflx_evap_veg(p))*dtime)
! total photosynthesis
fpsn(p) = psnsun(p)*laisun(p) + psnsha(p)*laisha(p)
#if (defined CN) && (defined C13)
! 4/14/05: PET
! Adding isotope code
rc13_canair(p) = c13o2(p)/(co2(p)-c13o2(p))
rc13_psnsun(p) = rc13_canair(p)/alphapsnsun(p)
rc13_psnsha(p) = rc13_canair(p)/alphapsnsha(p)
c13_psnsun(p) = psnsun(p) * (rc13_psnsun(p)/(1._r8+rc13_psnsun(p)))
c13_psnsha(p) = psnsha(p) * (rc13_psnsha(p)/(1._r8+rc13_psnsha(p)))
#endif
end do
! Filter out pfts which have small energy balance errors; report others
fnold = fn
fn = 0
do f = 1, fnold
p = filterp(f)
if (abs(err(p)) > 0.1_r8) then
fn = fn + 1
filterp(fn) = p
end if
end do
do f = 1, fn
p = filterp(f)
write(6,*) 'energy balance in canopy ',p,', err=',err(p)
end do
end subroutine CanopyFluxes
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: Stomata
!
! !INTERFACE:
subroutine Stomata (fn, filterp, lbp, ubp, ei, ea, o2, co2, rb, dayl_factor, phase) 4,6
!
! !DESCRIPTION:
! Leaf stomatal resistance and leaf photosynthesis. Modifications for CN code.
! !REVISION HISTORY:
! 22 January 2004: Created by Peter Thornton
! 4/14/05: Peter Thornton: Converted Ci from local variable to pps struct member
! now returns cisun or cisha per pft as implicit output argument.
! Also sets alphapsnsun and alphapsnsha.
! 4/25/05, Peter Thornton: Adopted as the default code for CLM, together with
! modifications for sun/shade canopy. Renamed from StomataCN to Stomata,
! and eliminating the older Stomata subroutine
! 3/6/09: Peter Thornton; added dayl_factor control on Vcmax, from Bill Bauerle
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use shr_const_mod, only : SHR_CONST_TKFRZ, SHR_CONST_RGAS
use clmtype
use pftvarcon , only : nbrdlf_dcd_tmp_shrub
#ifdef CROP
use pftvarcon , only : nsoybean
#endif
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: fn ! size of pft filter
integer , intent(in) :: filterp(fn) ! pft filter
integer , intent(in) :: lbp, ubp ! pft bounds
real(r8), intent(in) :: ei(lbp:ubp) ! vapor pressure inside leaf (sat vapor press at tl) (pa)
real(r8), intent(in) :: ea(lbp:ubp) ! vapor pressure of canopy air (pa)
real(r8), intent(in) :: o2(lbp:ubp) ! atmospheric o2 concentration (pa)
real(r8), intent(in) :: co2(lbp:ubp) ! atmospheric co2 concentration (pa)
real(r8), intent(inout) :: rb(lbp:ubp) ! boundary layer resistance (s/m)
real(r8), intent(in) :: dayl_factor(lbp:ubp) ! scalar (0-1) for daylength
character(len=*), intent(in) :: phase ! 'sun' or 'sha'
!
! !CALLED FROM:
! subroutine CanopyFluxes in this module
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in variables
! new ecophys variables (leafcn, flnr) added 1/26/04
!
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: pgridcell(:) ! pft's gridcell index
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: qe25(:) ! quantum efficiency at 25C (umol CO2 / umol photon)
real(r8), pointer :: vcmx25(:) ! max rate of carboxylation at 25C (umol CO2/m**2/s)
real(r8), pointer :: c3psn(:) ! photosynthetic pathway: 0. = c4, 1. = c3
real(r8), pointer :: mp(:) ! slope of conductance-to-photosynthesis relationship
real(r8), pointer :: tgcm(:) ! air temperature at agcm reference height (kelvin)
real(r8), pointer :: forc_pbot(:) ! atmospheric pressure (Pa)
real(r8), pointer :: tl(:) ! leaf temperature (Kelvin)
real(r8), pointer :: btran(:) ! soil water transpiration factor (0 to 1)
real(r8), pointer :: apar(:) ! par absorbed per unit lai (w/m**2)
real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN)
real(r8), pointer :: flnr(:) ! fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf)
real(r8), pointer :: sla(:) ! specific leaf area, projected area basis (m^2/gC)
real(r8), pointer :: fnitr(:) ! foliage nitrogen limitation factor (-)
!
! local pointers to implicit inout variables
!
real(r8), pointer :: rs(:) ! leaf stomatal resistance (s/m)
real(r8), pointer :: psn(:) ! foliage photosynthesis (umol co2 /m**2/ s) [always +]
real(r8), pointer :: ci(:) ! intracellular leaf CO2 (Pa)
#if (defined C13)
real(r8), pointer :: alphapsn(:) ! 13C fractionation factor for PSN ()
#endif
!
! local pointers to implicit out variables
!
real(r8), pointer :: lnc(:) ! leaf N concentration per unit projected LAI (gN leaf/m^2)
real(r8), pointer :: vcmx(:) ! maximum rate of carboxylation (umol co2/m**2/s)
!
!
! !LOCAL VARIABLES:
!EOP
!
real(r8), parameter :: mpe = 1.e-6_r8 ! prevents overflow error if division by zero
integer , parameter :: niter = 3 ! number of iterations
integer :: f,p,c,g ! indices
integer :: iter ! iteration index
real(r8) :: ab ! used in statement functions
real(r8) :: bc ! used in statement functions
real(r8) :: f1 ! generic temperature response (statement function)
real(r8) :: f2 ! generic temperature inhibition (statement function)
real(r8) :: tc ! leaf temperature (degree celsius)
real(r8) :: cs ! co2 concentration at leaf surface (pa)
real(r8) :: kc ! co2 michaelis-menten constant (pa)
real(r8) :: ko ! o2 michaelis-menten constant (pa)
real(r8) :: atmp ! intermediate calculations for rs
real(r8) :: btmp ! intermediate calculations for rs
real(r8) :: ctmp ! intermediate calculations for rs
real(r8) :: q ! intermediate calculations for rs
real(r8) :: r1,r2 ! roots for rs
real(r8) :: ppf ! absorb photosynthetic photon flux (umol photons/m**2/s)
real(r8) :: wc ! rubisco limited photosynthesis (umol co2/m**2/s)
real(r8) :: wj ! light limited photosynthesis (umol co2/m**2/s)
real(r8) :: we ! export limited photosynthesis (umol co2/m**2/s)
real(r8) :: cp ! co2 compensation point (pa)
real(r8) :: awc ! intermediate calcuation for wc
real(r8) :: j ! electron transport (umol co2/m**2/s)
real(r8) :: cea ! constrain ea or else model blows up
real(r8) :: cf ! s m**2/umol -> s/m
real(r8) :: rsmax0 ! maximum stomatal resistance [s/m]
real(r8) :: kc25 ! co2 michaelis-menten constant at 25c (pa)
real(r8) :: akc ! q10 for kc25
real(r8) :: ko25 ! o2 michaelis-menten constant at 25c (pa)
real(r8) :: ako ! q10 for ko25
real(r8) :: avcmx ! q10 for vcmx25
real(r8) :: bp ! minimum leaf conductance (umol/m**2/s)
! additional variables for new treatment of Vcmax, Peter Thornton, 1/26/04
real(r8) :: act25 ! (umol/mgRubisco/min) Rubisco activity at 25 C
real(r8) :: act ! (umol/mgRubisco/min) Rubisco activity
real(r8) :: q10act ! (DIM) Q_10 for Rubisco activity
real(r8) :: fnr ! (gRubisco/gN in Rubisco)
!------------------------------------------------------------------------------
! Set statement functions
f1(ab,bc) = ab**((bc-25._r8)/10._r8)
f2(ab) = 1._r8 + exp((-2.2e05_r8+710._r8*(ab+SHR_CONST_TKFRZ))/(SHR_CONST_RGAS*0.001_r8*(ab+SHR_CONST_TKFRZ)))
! Assign local pointers to derived type members (pft-level)
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
ivt => clm3%g%l%c%p%itype
tl => clm3%g%l%c%p%pes%t_veg
btran => clm3%g%l%c%p%pps%btran
if (phase == 'sun') then
apar => clm3%g%l%c%p%pef%parsun
rs => clm3%g%l%c%p%pps%rssun
psn => clm3%g%l%c%p%pcf%psnsun
ci => clm3%g%l%c%p%pps%cisun
#if (defined C13)
alphapsn => clm3%g%l%c%p%pps%alphapsnsun
#endif
sla => clm3%g%l%c%p%pps%slasun
lnc => clm3%g%l%c%p%pps%lncsun
vcmx => clm3%g%l%c%p%pps%vcmxsun
else if (phase == 'sha') then
apar => clm3%g%l%c%p%pef%parsha
rs => clm3%g%l%c%p%pps%rssha
psn => clm3%g%l%c%p%pcf%psnsha
ci => clm3%g%l%c%p%pps%cisha
sla => clm3%g%l%c%p%pps%slasha
#if (defined C13)
alphapsn => clm3%g%l%c%p%pps%alphapsnsha
#endif
lnc => clm3%g%l%c%p%pps%lncsha
vcmx => clm3%g%l%c%p%pps%vcmxsha
end if
! Assign local pointers to derived type members (gridcell-level)
forc_pbot => clm_a2l%forc_pbot
! Assign local pointers to derived type members (column-level)
tgcm => clm3%g%l%c%p%pes%thm
! Assign local pointers to pft constants
! new ecophys constants added 1/26/04
qe25 => pftcon%qe25
vcmx25 => pftcon%vcmx25
c3psn => pftcon%c3psn
mp => pftcon%mp
leafcn => pftcon%leafcn
flnr => pftcon%flnr
fnitr => pftcon%fnitr
! Set constant values
kc25 = 30._r8
akc = 2.1_r8
ko25 = 30000._r8
ako = 1.2_r8
avcmx = 2.4_r8
bp = 2000._r8
! New constants for CN code, added 1/26/04
act25 = 3.6_r8
q10act = 2.4_r8
fnr = 7.16_r8
! Convert rubisco activity units from umol/mgRubisco/min -> umol/gRubisco/s
act25 = act25 * 1000.0_r8 / 60.0_r8
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
g = pgridcell(p)
! Initialize rs=rsmax and psn=0 because calculations are performed only
! when apar > 0, in which case rs <= rsmax and psn >= 0
! Set constants
rsmax0 = 2.e4_r8
cf = forc_pbot(g)/(SHR_CONST_RGAS*0.001_r8*tgcm(p))*1.e06_r8
if (apar(p) <= 0._r8) then ! night time
rs(p) = min(rsmax0, 1._r8/bp * cf)
psn(p) = 0._r8
lnc(p) = 0._r8
vcmx(p) = 0._r8
#if (defined C13)
alphapsn(p) = 1._r8
#endif
else ! day time
tc = tl(p) - SHR_CONST_TKFRZ
ppf = 4.6_r8 * apar(p)
j = ppf * qe25(ivt(p))
kc = kc25 * f1(akc,tc)
ko = ko25 * f1(ako,tc)
awc = kc * (1._r8+o2(p)/ko)
cp = 0.5_r8*kc/ko*o2(p)*0.21_r8
! Modification for shrubs proposed by X.D.Z
! Why does he prefer this line here instead of in subr.
! CanopyFluxes? (slevis)
! Equivalent modification for soy following AgroIBIS
#if (defined CNDV)
if (ivt(p) == nbrdlf_dcd_tmp_shrub) btran(p) = min(1._r8, btran(p) * 3.33_r8)
#endif
#if (defined CROP)
if (ivt(p) == nsoybean) btran(p) = min(1._r8, btran(p) * 1.25_r8)
#endif
! new calculations for vcmax, 1/26/04
lnc(p) = 1._r8 / (sla(p) * leafcn(ivt(p)))
act = act25 * f1(q10act,tc)
#if (defined CN)
vcmx(p) = lnc(p) * flnr(ivt(p)) * fnr * act / f2(tc) * btran(p) * dayl_factor(p)
#else
vcmx(p) = lnc(p) * flnr(ivt(p)) * fnr * act / f2(tc) * btran(p) * dayl_factor(p) * fnitr(ivt(p))
#endif
! First guess ci
ci(p) = 0.7_r8*co2(p)*c3psn(ivt(p)) + 0.4_r8*co2(p)*(1._r8-c3psn(ivt(p)))
! rb: s/m -> s m**2 / umol
rb(p) = rb(p)/cf
! Constrain ea
cea = max(0.25_r8*ei(p)*c3psn(ivt(p))+0.40_r8*ei(p)*(1._r8-c3psn(ivt(p))), min(ea(p),ei(p)) )
! ci iteration for 'actual' photosynthesis
#if (defined NEC_SX)
!NEC NEC NEC
!
! ITER = 1
!
wj = max(ci(p)-cp,0._r8)*j/(ci(p)+2._r8*cp)*c3psn(ivt(p)) + j*(1._r8-c3psn(ivt(p)))
wc = max(ci(p)-cp,0._r8)*vcmx(p)/(ci(p)+awc)*c3psn(ivt(p)) + vcmx(p)*(1._r8-c3psn(ivt(p)))
we = 0.5_r8*vcmx(p)*c3psn(ivt(p)) + 4000._r8*vcmx(p)*ci(p)/forc_pbot(g)*(1._r8-c3psn(ivt(p)))
psn(p) = min(wj,wc,we)
cs = max( co2(p)-1.37_r8*rb(p)*forc_pbot(g)*psn(p), mpe )
atmp = mp(ivt(p))*psn(p)*forc_pbot(g)*cea / (cs*ei(p)) + bp
btmp = ( mp(ivt(p))*psn(p)*forc_pbot(g)/cs + bp ) * rb(p) - 1._r8
ctmp = -rb(p)
if (btmp >= 0._r8) then
q = -0.5_r8*( btmp + sqrt(btmp*btmp-4._r8*atmp*ctmp) )
else
q = -0.5_r8*( btmp - sqrt(btmp*btmp-4._r8*atmp*ctmp) )
end if
r1 = q/atmp
r2 = ctmp/q
rs(p) = max(r1,r2)
ci(p) = max( cs-psn(p)*forc_pbot(g)*1.65_r8*rs(p), 0._r8 )
!
! ITER = 2
!
wj = max(ci(p)-cp,0._r8)*j/(ci(p)+2._r8*cp)*c3psn(ivt(p)) + j*(1._r8-c3psn(ivt(p)))
wc = max(ci(p)-cp,0._r8)*vcmx(p)/(ci(p)+awc)*c3psn(ivt(p)) + vcmx(p)*(1._r8-c3psn(ivt(p)))
we = 0.5_r8*vcmx(p)*c3psn(ivt(p)) + 4000._r8*vcmx(p)*ci(p)/forc_pbot(g)*(1._r8-c3psn(ivt(p)))
psn(p) = min(wj,wc,we)
cs = max( co2(p)-1.37_r8*rb(p)*forc_pbot(g)*psn(p), mpe )
atmp = mp(ivt(p))*psn(p)*forc_pbot(g)*cea / (cs*ei(p)) + bp
btmp = ( mp(ivt(p))*psn(p)*forc_pbot(g)/cs + bp ) * rb(p) - 1._r8
ctmp = -rb(p)
if (btmp >= 0._r8) then
q = -0.5_r8*( btmp + sqrt(btmp*btmp-4._r8*atmp*ctmp) )
else
q = -0.5_r8*( btmp - sqrt(btmp*btmp-4._r8*atmp*ctmp) )
end if
r1 = q/atmp
r2 = ctmp/q
rs(p) = max(r1,r2)
ci(p) = max( cs-psn(p)*forc_pbot(g)*1.65_r8*rs(p), 0._r8 )
!
! ITER = 3
!
wj = max(ci(p)-cp,0._r8)*j/(ci(p)+2._r8*cp)*c3psn(ivt(p)) + j*(1._r8-c3psn(ivt(p)))
wc = max(ci(p)-cp,0._r8)*vcmx(p)/(ci(p)+awc)*c3psn(ivt(p)) + vcmx(p)*(1._r8-c3psn(ivt(p)))
we = 0.5_r8*vcmx(p)*c3psn(ivt(p)) + 4000._r8*vcmx(p)*ci(p)/forc_pbot(g)*(1._r8-c3psn(ivt(p)))
psn(p) = min(wj,wc,we)
cs = max( co2(p)-1.37_r8*rb(p)*forc_pbot(g)*psn(p), mpe )
atmp = mp(ivt(p))*psn(p)*forc_pbot(g)*cea / (cs*ei(p)) + bp
btmp = ( mp(ivt(p))*psn(p)*forc_pbot(g)/cs + bp ) * rb(p) - 1._r8
ctmp = -rb(p)
if (btmp >= 0._r8) then
q = -0.5_r8*( btmp + sqrt(btmp*btmp-4._r8*atmp*ctmp) )
else
q = -0.5_r8*( btmp - sqrt(btmp*btmp-4._r8*atmp*ctmp) )
end if
r1 = q/atmp
r2 = ctmp/q
rs(p) = max(r1,r2)
ci(p) = max( cs-psn(p)*forc_pbot(g)*1.65_r8*rs(p), 0._r8 )
!NEC NEC NEC
#else
do iter = 1, niter
wj = max(ci(p)-cp,0._r8)*j/(ci(p)+2._r8*cp)*c3psn(ivt(p)) + j*(1._r8-c3psn(ivt(p)))
wc = max(ci(p)-cp,0._r8)*vcmx(p)/(ci(p)+awc)*c3psn(ivt(p)) + vcmx(p)*(1._r8-c3psn(ivt(p)))
we = 0.5_r8*vcmx(p)*c3psn(ivt(p)) + 4000._r8*vcmx(p)*ci(p)/forc_pbot(g)*(1._r8-c3psn(ivt(p)))
psn(p) = min(wj,wc,we)
cs = max( co2(p)-1.37_r8*rb(p)*forc_pbot(g)*psn(p), mpe )
atmp = mp(ivt(p))*psn(p)*forc_pbot(g)*cea / (cs*ei(p)) + bp
btmp = ( mp(ivt(p))*psn(p)*forc_pbot(g)/cs + bp ) * rb(p) - 1._r8
ctmp = -rb(p)
if (btmp >= 0._r8) then
q = -0.5_r8*( btmp + sqrt(btmp*btmp-4._r8*atmp*ctmp) )
else
q = -0.5_r8*( btmp - sqrt(btmp*btmp-4._r8*atmp*ctmp) )
end if
r1 = q/atmp
r2 = ctmp/q
rs(p) = max(r1,r2)
ci(p) = max( cs-psn(p)*forc_pbot(g)*1.65_r8*rs(p), 0._r8 )
end do
#endif
! rs, rb: s m**2 / umol -> s/m
rs(p) = min(rsmax0, rs(p)*cf)
rb(p) = rb(p) * cf
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
alphapsn(p) = 1._r8 + (((c3psn(ivt(p)) * (4.4_r8 + (22.6_r8*(ci(p)/co2(p))))) + &
((1._r8 - c3psn(ivt(p))) * 4.4_r8))/1000._r8)
#endif
end if
end do
end subroutine Stomata
end module CanopyFluxesMod
subroutine biochem_to_wrf(htmx_buf,croplive_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf & 1,5
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf &
)
#if (defined CN)
!-----------------------------------------------------------------------
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype
use decompMod, only : get_proc_bounds
use clm_varpar, only: maxpatch
!
! !PUBLIC TYPES:
implicit none
save
!-----------------------------------------------------------------------
! !LOCAL VARIABLES:
integer :: c,p ! indices
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
!-----------------------------------------------------------------------
integer,dimension(maxpatch) :: croplive_buf
real(r8), dimension(maxpatch) :: &
htmx_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf
! Determine necessary subgrid bounds
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
!coloum level
do c=begc,endc
annsum_counter_buf(c) = clm3%g%l%c%cps%annsum_counter(c)
cannsum_npp_buf(c) = clm3%g%l%c%cps%cannsum_npp(c)
cannavg_t2m_buf(c) = clm3%g%l%c%cps%cannavg_t2m(c)
wf_buf(c) = clm3%g%l%c%cps%wf(c)
me_buf(c) = clm3%g%l%c%cps%me(c)
mean_fire_prob_buf(c) = clm3%g%l%c%cps%mean_fire_prob(c)
cwdc_buf(c) = clm3%g%l%c%ccs%cwdc(c)
litr1c_buf(c) = clm3%g%l%c%ccs%litr1c(c)
litr2c_buf(c) = clm3%g%l%c%ccs%litr2c(c)
litr3c_buf(c) = clm3%g%l%c%ccs%litr3c(c)
soil1c_buf(c) = clm3%g%l%c%ccs%soil1c(c)
soil2c_buf(c) = clm3%g%l%c%ccs%soil2c(c)
soil3c_buf(c) = clm3%g%l%c%ccs%soil3c(c)
soil4c_buf(c) = clm3%g%l%c%ccs%soil4c(c)
col_ctrunc_buf(c) = clm3%g%l%c%ccs%col_ctrunc(c)
cwdn_buf(c) = clm3%g%l%c%cns%cwdn(c)
litr1n_buf(c) = clm3%g%l%c%cns%litr1n(c)
litr2n_buf(c) = clm3%g%l%c%cns%litr2n(c)
litr3n_buf(c) = clm3%g%l%c%cns%litr3n(c)
soil1n_buf(c) = clm3%g%l%c%cns%soil1n(c)
soil2n_buf(c) = clm3%g%l%c%cns%soil2n(c)
soil3n_buf(c) = clm3%g%l%c%cns%soil3n(c)
soil4n_buf(c) = clm3%g%l%c%cns%soil4n(c)
col_ntrunc_buf(c) = clm3%g%l%c%cns%col_ntrunc(c)
seedc_buf(c) = clm3%g%l%c%ccs%seedc(c)
prod10c_buf(c) = clm3%g%l%c%ccs%prod10c(c)
prod100c_buf(c) = clm3%g%l%c%ccs%prod100c(c)
seedn_buf(c) = clm3%g%l%c%cns%seedn(c)
prod10n_buf(c) = clm3%g%l%c%cns%prod10n(c)
prod100n_buf(c) = clm3%g%l%c%cns%prod100n(c)
dwt_seedc_to_leaf_buf(c) = clm3%g%l%c%ccf%dwt_seedc_to_leaf(c)
dwt_seedc_to_deadstem_buf(c) = clm3%g%l%c%ccf%dwt_seedc_to_deadstem(c)
dwt_conv_cflux_buf(c) = clm3%g%l%c%ccf%dwt_conv_cflux(c)
dwt_prod10c_gain_buf(c) = clm3%g%l%c%ccf%dwt_prod10c_gain(c)
dwt_prod100c_gain_buf(c) = clm3%g%l%c%ccf%dwt_prod100c_gain(c)
prod100c_loss_buf(c) = clm3%g%l%c%ccf%prod100c_loss(c)
dwt_frootc_to_litr1c_buf(c) = clm3%g%l%c%ccf%dwt_frootc_to_litr1c(c)
dwt_frootc_to_litr2c_buf(c) = clm3%g%l%c%ccf%dwt_frootc_to_litr2c(c)
dwt_frootc_to_litr3c_buf(c) = clm3%g%l%c%ccf%dwt_frootc_to_litr3c(c)
dwt_livecrootc_to_cwdc_buf(c) = clm3%g%l%c%ccf%dwt_livecrootc_to_cwdc(c)
dwt_deadcrootc_to_cwdc_buf(c) = clm3%g%l%c%ccf%dwt_deadcrootc_to_cwdc(c)
dwt_seedn_to_leaf_buf(c) = clm3%g%l%c%cnf%dwt_seedn_to_leaf(c)
dwt_seedn_to_deadstem_buf(c) = clm3%g%l%c%cnf%dwt_seedn_to_deadstem(c)
dwt_conv_nflux_buf(c) = clm3%g%l%c%cnf%dwt_conv_nflux(c)
dwt_prod10n_gain_buf(c) = clm3%g%l%c%cnf%dwt_prod10n_gain(c)
dwt_prod100n_gain_buf(c) = clm3%g%l%c%cnf%dwt_prod100n_gain(c)
prod100n_loss_buf(c) = clm3%g%l%c%cnf%prod100n_loss(c)
dwt_frootn_to_litr1n_buf(c) = clm3%g%l%c%cnf%dwt_frootn_to_litr1n(c)
dwt_frootn_to_litr2n_buf(c) = clm3%g%l%c%cnf%dwt_frootn_to_litr2n(c)
dwt_frootn_to_litr3n_buf(c) = clm3%g%l%c%cnf%dwt_frootn_to_litr3n(c)
dwt_livecrootn_to_cwdn_buf(c) = clm3%g%l%c%cnf%dwt_livecrootn_to_cwdn(c)
dwt_deadcrootn_to_cwdn_buf(c) = clm3%g%l%c%cnf%dwt_deadcrootn_to_cwdn(c)
end do
! pft type dgvm physical state - annpsnpot
do p = begp,endp
leafc_buf(p) = clm3%g%l%c%p%pcs%leafc(p)
leafc_storage_buf(p) = clm3%g%l%c%p%pcs%leafc_storage(p)
leafc_xfer_buf(p) = clm3%g%l%c%p%pcs%leafc_xfer(p)
#if (defined CROP)
grainc_buf(p) = clm3%g%l%c%p%pcs%grainc(p)
grainc_storage_buf(p) = clm3%g%l%c%p%pcs%grainc_storage(p)
grainc_xfer_buf(p) = clm3%g%l%c%p%pcs%grainc_xfer(p)
gdd020_buf(p) = clm3%g%l%c%p%pps%gdd020(p)
gdd820_buf(p) = clm3%g%l%c%p%pps%gdd820(p)
gdd1020_buf(p) = clm3%g%l%c%p%pps%gdd1020(p)
croplive_buf(p) = clm3%g%l%c%p%pps%croplive(p)
htmx_buf(p) = clm3%g%l%c%p%pps%htmx(p)
#endif
frootc_buf(p) = clm3%g%l%c%p%pcs%frootc(p)
frootc_storage_buf(p) = clm3%g%l%c%p%pcs%frootc_storage(p)
frootc_xfer_buf(p) = clm3%g%l%c%p%pcs%frootc_xfer(p)
livestemc_buf(p) = clm3%g%l%c%p%pcs%livestemc(p)
livestemc_storage_buf(p) = clm3%g%l%c%p%pcs%livestemc_storage(p)
livestemc_xfer_buf(p) = clm3%g%l%c%p%pcs%livestemc_xfer(p)
deadstemc_buf(p) = clm3%g%l%c%p%pcs%deadstemc(p)
deadstemc_storage_buf(p) = clm3%g%l%c%p%pcs%deadstemc_storage(p)
deadstemc_xfer_buf(p) = clm3%g%l%c%p%pcs%deadstemc_xfer(p)
livecrootc_buf(p) = clm3%g%l%c%p%pcs%livecrootc(p)
livecrootc_storage_buf(p) = clm3%g%l%c%p%pcs%livecrootc_storage(p)
livecrootc_xfer_buf(p) = clm3%g%l%c%p%pcs%livecrootc_xfer(p)
deadcrootc_buf(p) = clm3%g%l%c%p%pcs%deadcrootc(p)
deadcrootc_storage_buf(p) = clm3%g%l%c%p%pcs%deadcrootc_storage(p)
deadcrootc_xfer_buf(p) = clm3%g%l%c%p%pcs%deadcrootc_xfer(p)
gresp_storage_buf(p) = clm3%g%l%c%p%pcs%gresp_storage(p)
gresp_xfer_buf(p) = clm3%g%l%c%p%pcs%gresp_xfer(p)
cpool_buf(p) = clm3%g%l%c%p%pcs%cpool(p)
xsmrpool_buf(p) = clm3%g%l%c%p%pcs%xsmrpool(p)
leafn_buf(p) = clm3%g%l%c%p%pns%leafn(p)
leafn_storage_buf(p) = clm3%g%l%c%p%pns%leafn_storage(p)
leafn_xfer_buf(p) = clm3%g%l%c%p%pns%leafn_xfer(p)
#if (defined CROP)
grainn_buf(p) = clm3%g%l%c%p%pns%grainn(p)
grainn_storage_buf(p) = clm3%g%l%c%p%pns%grainn_storage(p)
grainn_xfer_buf(p) = clm3%g%l%c%p%pns%grainn_xfer(p)
#endif
frootn_buf(p) = clm3%g%l%c%p%pns%frootn(p)
frootn_storage_buf(p) = clm3%g%l%c%p%pns%frootn_storage(p)
frootn_xfer_buf(p) = clm3%g%l%c%p%pns%frootn_xfer(p)
livestemn_buf(p) = clm3%g%l%c%p%pns%livestemn(p)
livestemn_storage_buf(p) = clm3%g%l%c%p%pns%livestemn_storage(p)
livestemn_xfer_buf(p) = clm3%g%l%c%p%pns%livestemn_xfer(p)
deadstemn_buf(p) = clm3%g%l%c%p%pns%deadstemn(p)
deadstemn_storage_buf(p) = clm3%g%l%c%p%pns%deadstemn_storage(p)
deadstemn_xfer_buf(p) = clm3%g%l%c%p%pns%deadstemn_xfer(p)
livecrootn_buf(p) = clm3%g%l%c%p%pns%livecrootn(p)
livecrootn_storage_buf(p) = clm3%g%l%c%p%pns%livecrootn_storage(p)
livecrootn_xfer_buf(p) = clm3%g%l%c%p%pns%livecrootn_xfer(p)
deadcrootn_buf(p) = clm3%g%l%c%p%pns%deadcrootn(p)
deadcrootn_storage_buf(p) = clm3%g%l%c%p%pns%deadcrootn_storage(p)
deadcrootn_xfer_buf(p) = clm3%g%l%c%p%pns%deadcrootn_xfer(p)
npool_buf(p) = clm3%g%l%c%p%pns%npool(p)
retransn_buf(p) = clm3%g%l%c%p%pns%retransn(p)
days_active_buf(p) = clm3%g%l%c%p%pepv%days_active(p)
onset_flag_buf(p) = clm3%g%l%c%p%pepv%onset_flag(p)
onset_counter_buf(p) = clm3%g%l%c%p%pepv%onset_counter(p)
onset_gddflag_buf(p) = clm3%g%l%c%p%pepv%onset_gddflag(p)
onset_fdd_buf(p) = clm3%g%l%c%p%pepv%onset_fdd(p)
onset_gdd_buf(p) = clm3%g%l%c%p%pepv%onset_gdd(p)
onset_swi_buf(p) = clm3%g%l%c%p%pepv%onset_swi(p)
offset_flag_buf(p) = clm3%g%l%c%p%pepv%offset_flag(p)
offset_counter_buf(p) = clm3%g%l%c%p%pepv%offset_counter(p)
offset_fdd_buf(p) = clm3%g%l%c%p%pepv%offset_fdd(p)
offset_swi_buf(p) = clm3%g%l%c%p%pepv%offset_swi(p)
dayl_buf(p) = clm3%g%l%c%p%pepv%dayl(p)
annavg_t2m_buf(p) = clm3%g%l%c%p%pepv%annavg_t2m(p)
tempavg_t2m_buf(p) = clm3%g%l%c%p%pepv%tempavg_t2m(p)
tempsum_potential_gpp_buf(p) = clm3%g%l%c%p%pepv%tempsum_potential_gpp(p)
annsum_potential_gpp_buf(p) = clm3%g%l%c%p%pepv%annsum_potential_gpp(p)
tempmax_retransn_buf(p) = clm3%g%l%c%p%pepv%tempmax_retransn(p)
annmax_retransn_buf(p) = clm3%g%l%c%p%pepv%annmax_retransn(p)
prev_frootc_to_litter_buf(p) = clm3%g%l%c%p%pepv%prev_frootc_to_litter(p)
prev_leafc_to_litter_buf(p) = clm3%g%l%c%p%pepv%prev_leafc_to_litter(p)
pft_ctrunc_buf(p) = clm3%g%l%c%p%pcs%pft_ctrunc(p)
pft_ntrunc_buf(p) = clm3%g%l%c%p%pns%pft_ntrunc(p)
tempsum_npp_buf(p) = clm3%g%l%c%p%pepv%tempsum_npp(p)
annsum_npp_buf(p) = clm3%g%l%c%p%pepv%annsum_npp(p)
end do
#endif
end subroutine biochem_to_wrf
!------------------------------------------------------------------------
subroutine biophy_to_wrf(snl ,snowdp ,dzclm ,zclm ,& 1,8
ziclm ,h2osno ,h2osoi_liq ,h2osoi_ice ,t_grnd ,&
t_soisno ,t_lake ,t_veg ,h2ocan ,h2ocan_col ,&
h2osoi_vol ,wtc ,wtp ,numc ,nump ,&
htop ,tsai &
,t_ref2m ,znt ,q_ref2m,snw_rds)
!
! !DESCRIPTION:
! Read/Write biogeophysics information to/from restart file.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype
use clm_varpar, only : nlevgrnd,numrad,maxpatch,nlevsno,nlevlak
use clm_varcon, only : denice, denh2o
use nanMod, only : nan
use decompMod , only : get_proc_bounds
use pftvarcon , only : noveg
!
! !ARGUMENTS:
implicit none
! The following vraiables for a WRF restart run
integer :: snl(maxpatch)
integer :: frac_veg_nosno_alb(maxpatch)
real(r8) :: snowdp(maxpatch)
! real(r8) :: snowage(maxpatch)
real(r8) :: frac_sno(maxpatch)
real(r8) :: albd(numrad,maxpatch)
real(r8) :: albi(numrad,maxpatch)
real(r8) :: albgrd(numrad,maxpatch)
real(r8) :: albgri(numrad,maxpatch)
real(r8) :: h2osno(maxpatch)
real(r8) :: t_grnd(maxpatch)
real(r8) :: fwet(maxpatch)
real(r8) :: tlai(maxpatch)
real(r8) :: tsai(maxpatch)
real(r8) :: elai(maxpatch)
real(r8) :: esai(maxpatch)
real(r8) :: fsun(maxpatch)
real(r8) :: htop(maxpatch)
real(r8) :: hbot(maxpatch)
real(r8) :: fabd(numrad,maxpatch)
real(r8) :: fabi(numrad,maxpatch)
real(r8) :: ftdd(numrad,maxpatch)
real(r8) :: ftid(numrad,maxpatch)
real(r8) :: ftii(numrad,maxpatch)
real(r8) :: t_veg(maxpatch)
real(r8) :: h2ocan(maxpatch)
real(r8) :: h2ocan_col(maxpatch)
real(r8) :: wtc(maxpatch)
real(r8) :: wtp(maxpatch)
real(r8) :: snw_rds(maxpatch,-nlevsno+1:0)
real(r8) :: t_lake(maxpatch,nlevlak)
real(r8) :: t_soisno(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: h2osoi_liq(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: h2osoi_ice(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: dzclm(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: zclm(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: ziclm(maxpatch,-nlevsno:nlevgrnd)
real(r8) :: h2osoi_vol(maxpatch,nlevgrnd)
real(r8) :: t_ref2m(maxpatch)
real(r8) :: q_ref2m(maxpatch)
real(r8) :: znt(maxpatch)
!
! !LOCAL VARIABLES:
integer :: g,l,c,p,j ! indices
real(r8):: pftsum ! temporary used for pft averaging for columns
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
integer :: numc, nump
!-----------------------------------------------------------------------
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
numc = endc-begc+1
nump = endp-begp+1
! Column physical state - snl
do c = begc,endc
snl(c) = clm3%g%l%c%cps%snl(c)
end do
! Column physical state - snowdp
do c = begc,endc
snowdp(c) = clm3%g%l%c%cps%snowdp(c)
end do
do j = -nlevsno+1,0
do c = begc,endc
snw_rds(c,j) = clm3%g%l%c%cps%snw_rds(c,j)
end do
end do
! Column physical state - snowage
! do c = begc,endc
! snowage(c) = clm3%g%l%c%cps%snowage(c)
! end do
! Column physical state - frac_sno
do c = begc,endc
frac_sno(c) = clm3%g%l%c%cps%frac_sno(c)
end do
! Column physical state - dz (snow)
do j = -nlevsno+1,0
do c = begc,endc
dzclm(c,j) = clm3%g%l%c%cps%dz(c,j)
end do
end do
! Column physical state - z (snow)
do j = -nlevsno+1,0
do c = begc,endc
zclm(c,j) = clm3%g%l%c%cps%z(c,j)
end do
end do
do j = -nlevsno,0
do c = begc,endc
ziclm(c,j) = clm3%g%l%c%cps%zi(c,j)
end do
end do
!pft type physical state variable - albd
do j = 1,numrad
do p = begp,endp
albd(j,p) = clm3%g%l%c%p%pps%albd(p,j)
end do
end do
!pft type physical state variable - albi
do j = 1,numrad
do p = begp,endp
albi(j,p) = clm3%g%l%c%p%pps%albi(p,j)
end do
end do
!column type physical state variable - albgrd
do j = 1,numrad
do c = begc,endc
albgrd(j,c) = clm3%g%l%c%cps%albgrd(c,j)
end do
end do
!column type physical state variable - albgri
do j = 1,numrad
do c = begc,endc
albgri(j,c) = clm3%g%l%c%cps%albgri(c,j)
end do
end do
! column water state variable - h2osno
do c = begc,endc
h2osno(c) = clm3%g%l%c%cws%h2osno(c)
end do
! column water state variable - h2osoi_liq
do j = -nlevsno+1,nlevgrnd
do c = begc,endc
h2osoi_liq(c,j) = clm3%g%l%c%cws%h2osoi_liq(c,j)
end do
end do
! column water state variable - h2osoi_ice
do j = -nlevsno+1,nlevgrnd
do c = begc,endc
h2osoi_ice(c,j) = clm3%g%l%c%cws%h2osoi_ice(c,j)
end do
end do
! column energy state variable - t_grnd
do c = begc,endc
t_grnd(c) = clm3%g%l%c%ces%t_grnd(c)
end do
! pft energy state variable - t_ref2m
do p = begp,endp
t_ref2m(p) = clm3%g%l%c%p%pes%t_ref2m(p)
end do
! pft energy state variable - q_ref2m
do p = begp,endp
q_ref2m(p) = clm3%g%l%c%p%pes%q_ref2m(p)
end do
! column energy state variable - t_soisno
do j = -nlevsno+1,nlevgrnd
do c = begc,endc
t_soisno(c,j) = clm3%g%l%c%ces%t_soisno(c,j)
end do
end do
!column type energy state variable - t_lake
do j = 1,nlevlak
do c = begc,endc
t_lake(c,j) = clm3%g%l%c%ces%t_lake(c,j)
end do
end do
! pft type physical state variable - frac_veg_nosno_alb
do p = begp,endp
frac_veg_nosno_alb(p) = clm3%g%l%c%p%pps%frac_veg_nosno_alb(p)
end do
! pft type physical state variable - fwet
do p = begp,endp
fwet(p) = clm3%g%l%c%p%pps%fwet(p)
end do
! pft type physical state variable - tlai
do p = begp,endp
tlai(p) = clm3%g%l%c%p%pps%tlai(p)
end do
! pft type physical state variable - tsai
do p = begp,endp
tsai(p) = clm3%g%l%c%p%pps%tsai(p)
end do
! pft type physical state variable - elai
do p = begp,endp
elai(p) = clm3%g%l%c%p%pps%elai(p)
end do
! pft type physical state variable - esai
do p = begp,endp
esai(p)= clm3%g%l%c%p%pps%esai(p)
end do
! pft type physical state variable - fsun
do p = begp,endp
fsun(p)= clm3%g%l%c%p%pps%fsun(p)
end do
! pft type physical state variable - htop
do p = begp,endp
htop(p)= clm3%g%l%c%p%pps%htop(p)
end do
! pft type physical state variable - hbot
do p = begp,endp
hbot(p)= clm3%g%l%c%p%pps%hbot(p)
end do
! pft type physical state variable - fabd
do j = 1,numrad
do p = begp,endp
fabd(j,p) = clm3%g%l%c%p%pps%fabd(p,j)
end do
end do
! pft type physical state variable - fabi
do j = 1,numrad
do p = begp,endp
fabi(j,p) = clm3%g%l%c%p%pps%fabi(p,j)
end do
end do
! pft type physical state variable - ftdd
do j = 1,numrad
do p = begp,endp
ftdd(j,p) = clm3%g%l%c%p%pps%ftdd(p,j)
end do
end do
! pft type physical state variable - ftid
do j = 1,numrad
do p = begp,endp
ftid(j,p) = clm3%g%l%c%p%pps%ftid(p,j)
end do
end do
! pft type physical state variable - ftii
do j = 1,numrad
do p = begp,endp
ftii(j,p) = clm3%g%l%c%p%pps%ftii(p,j)
end do
end do
! pft type energy state variable - t_veg
do p = begp,endp
t_veg(p) = clm3%g%l%c%p%pes%t_veg(p)
end do
! pft type water state variable - h2ocan
do p = begp,endp
h2ocan(p) = clm3%g%l%c%p%pws%h2ocan(p)
end do
do p = begp,endp
c = clm3%g%l%c%p%column(p)
if(clm3%g%l%c%p%itype(p)/=noveg) then
znt(p) = clm3%g%l%c%p%pps%z0mv(p)
else
znt(p) = clm3%g%l%c%cps%z0mg(c)
end if
end do
! For read only:
! Determine average over all column pfts for h2ocan, needed by begwb
! computation in routine driver.F90) - this needs to be done after the
! weights are reset in the DGVM case
! The following should not be vectorized
do c = begc,endc
clm3%g%l%c%cws%pws_a%h2ocan(c) = 0.
end do
do p = begp,endp
c = clm3%g%l%c%p%column(p)
clm3%g%l%c%cws%pws_a%h2ocan(c) = clm3%g%l%c%cws%pws_a%h2ocan(c) &
+ clm3%g%l%c%p%pws%h2ocan(p) * clm3%g%l%c%p%wtcol(p)
h2ocan_col(c) = clm3%g%l%c%cws%pws_a%h2ocan(c)
end do
! For read only:
! Determine volumetric soil water
do j = 1,nlevgrnd
do c = begc,endc
clm3%g%l%c%cws%h2osoi_vol(c,j) = &
clm3%g%l%c%cws%h2osoi_liq(c,j)/(clm3%g%l%c%cps%dz(c,j)*denh2o) &
+ clm3%g%l%c%cws%h2osoi_ice(c,j)/(clm3%g%l%c%cps%dz(c,j)*denice)
h2osoi_vol(c,j) = clm3%g%l%c%cws%h2osoi_vol(c,j)
end do
end do
do c = begc,endc
wtc(c) = clm3%g%l%c%wtgcell(c)
end do
do p = begp,endp
wtp(p) = clm3%g%l%c%p%wtgcell(p)
end do
end subroutine biophy_to_wrf
!===========================================================================================================
module BalanceCheckMod 1,2
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: BalanceCheckMod
!
! !DESCRIPTION:
! Water and energy balance check.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use module_cam_support, only: endrun
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: BeginWaterBalance ! Initialize water balance check
public :: BalanceCheck ! Water and energy balance check
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: BeginWaterBalance
!
! !INTERFACE:
subroutine BeginWaterBalance(lbc, ubc, lbp, ubp, & 1,6
num_nolakec, filter_nolakec, num_lakec, filter_lakec, &
num_hydrologyc, filter_hydrologyc)
!
! !DESCRIPTION:
! Initialize column-level water balance at beginning of time step
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use clm_varpar , only : nlevgrnd, nlevsoi
use subgridAveMod, only : p2c
use clm_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, &
icol_road_imperv
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column-index bounds
integer, intent(in) :: lbp, ubp ! pft-index bounds
integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
integer, intent(in) :: num_lakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_lakec(ubc-lbc+1) ! column filter for non-lake points
integer , intent(in) :: num_hydrologyc ! number of column soil points in column filter
integer , intent(in) :: filter_hydrologyc(ubc-lbc+1) ! column filter for soil points
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
!EOP
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in variables
!
real(r8), pointer :: h2osno(:) ! snow water (mm H2O)
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
real(r8), pointer :: h2ocan_pft(:) ! canopy water (mm H2O) (pft-level)
real(r8), pointer :: wa(:) ! water in the unconfined aquifer (mm)
integer , pointer :: ctype(:) ! column type
real(r8), pointer :: zwt(:) ! water table depth (m)
real(r8), pointer :: zi(:,:) ! interface level below a "z" level (m)
!
! local pointers to original implicit out variables
!
real(r8), pointer :: h2ocan_col(:) ! canopy water (mm H2O) (column level)
real(r8), pointer :: begwb(:) ! water mass begining of the time step
!
! !OTHER LOCAL VARIABLES:
!
integer :: c, p, f, j, fc ! indices
!-----------------------------------------------------------------------
! Assign local pointers to derived type members (column-level)
h2osno => clm3%g%l%c%cws%h2osno
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
begwb => clm3%g%l%c%cwbal%begwb
h2ocan_col => clm3%g%l%c%cws%pws_a%h2ocan
wa => clm3%g%l%c%cws%wa
ctype => clm3%g%l%c%itype
zwt => clm3%g%l%c%cws%zwt
zi => clm3%g%l%c%cps%zi
! Assign local pointers to derived type members (pft-level)
h2ocan_pft => clm3%g%l%c%p%pws%h2ocan
! Determine beginning water balance for time step
! pft-level canopy water averaged to column
call p2c(num_nolakec, filter_nolakec, h2ocan_pft, h2ocan_col)
do f = 1, num_hydrologyc
c = filter_hydrologyc(f)
if(zwt(c) <= zi(c,nlevsoi)) then
wa(c) = 5000._r8
end if
end do
do f = 1, num_nolakec
c = filter_nolakec(f)
if (ctype(c) == icol_roof .or. ctype(c) == icol_sunwall &
.or. ctype(c) == icol_shadewall .or. ctype(c) == icol_road_imperv) then
begwb(c) = h2ocan_col(c) + h2osno(c)
else
begwb(c) = h2ocan_col(c) + h2osno(c) + wa(c)
end if
end do
do j = 1, nlevgrnd
do f = 1, num_nolakec
c = filter_nolakec(f)
begwb(c) = begwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
end do
end do
do f = 1, num_lakec
c = filter_lakec(f)
begwb(c) = h2osno(c)
end do
end subroutine BeginWaterBalance
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: BalanceCheck
!
! !INTERFACE:
subroutine BalanceCheck(lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg) 1,13
!
! !DESCRIPTION:
! This subroutine accumulates the numerical truncation errors of the water
! and energy balance calculation. It is helpful to see the performance of
! the process of integration.
!
! The error for energy balance:
!
! error = abs(Net radiation - change of internal energy - Sensible heat
! - Latent heat)
!
! The error for water balance:
!
! error = abs(precipitation - change of water storage - evaporation - runoff)
!
! !USES:
use clmtype
use subgridAveMod
use globals , only :nstep, dtime
use clm_varcon , only : isturb, icol_roof, icol_sunwall, icol_shadewall, &
spval, icol_road_perv, icol_road_imperv
!
! !ARGUMENTS:
implicit none
integer :: lbp, ubp ! pft-index bounds
integer :: lbc, ubc ! column-index bounds
integer :: lbl, ubl ! landunit-index bounds
integer :: lbg, ubg ! grid-index bounds
!
! !CALLED FROM:
! subroutine clm_driver
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 10 November 2000: Mariana Vertenstein
! Migrated to new data structures by Mariana Vertenstein and
! Peter Thornton
!
! !LOCAL VARIABLES:
!
! local pointers to original implicit in arguments
!
integer , pointer :: pgridcell(:) ! pft's gridcell index
integer , pointer :: plandunit(:) ! pft's landunit index
integer , pointer :: cgridcell(:) ! column's gridcell index
integer , pointer :: ltype(:) ! landunit type
integer , pointer :: ctype(:) ! column type
real(r8), pointer :: pwtgcell(:) ! pft's weight relative to corresponding gridcell
real(r8), pointer :: cwtgcell(:) ! column's weight relative to corresponding gridcell
real(r8), pointer :: forc_rain(:) ! rain rate [mm/s]
real(r8), pointer :: forc_snow(:) ! snow rate [mm/s]
real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2)
real(r8), pointer :: endwb(:) ! water mass end of the time step
real(r8), pointer :: begwb(:) ! water mass begining of the time step
real(r8), pointer :: fsa(:) ! solar radiation absorbed (total) (W/m**2)
real(r8), pointer :: fsr(:) ! solar radiation reflected (W/m**2)
real(r8), pointer :: eflx_lwrad_out(:) ! emitted infrared (longwave) radiation (W/m**2)
real(r8), pointer :: eflx_lwrad_net(:) ! net infrared (longwave) rad (W/m**2) [+ = to atm]
real(r8), pointer :: sabv(:) ! solar radiation absorbed by vegetation (W/m**2)
real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2)
real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_totg(:) ! total sensible heat flux at grid level (W/m**2) [+ to atm]
real(r8), pointer :: eflx_dynbal(:) ! energy conversion flux due to dynamic land cover change(W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_tot(:) ! total latent heat flux (W/m8*2) [+ to atm]
real(r8), pointer :: eflx_soil_grnd(:) ! soil heat flux (W/m**2) [+ = into soil]
real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
real(r8), pointer :: qflx_surf(:) ! surface runoff (mm H2O /s)
real(r8), pointer :: qflx_qrgwl(:) ! qflx_surf at glaciers, wetlands, lakes
real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s)
real(r8), pointer :: qflx_runoff(:) ! total runoff (mm H2O /s)
real(r8), pointer :: qflx_runoffg(:) ! total runoff at gridcell level inc land cover change flux (mm H2O /s)
real(r8), pointer :: qflx_liq_dynbal(:) ! liq runoff due to dynamic land cover change (mm H2O /s)
real(r8), pointer :: qflx_snwcp_ice(:) ! excess snowfall due to snow capping (mm H2O /s) [+]`
real(r8), pointer :: qflx_snwcp_iceg(:) ! excess snowfall due to snow cap inc land cover change flux (mm H20/s)
real(r8), pointer :: qflx_ice_dynbal(:) ! ice runoff due to dynamic land cover change (mm H2O /s)
real(r8), pointer :: forc_solad(:,:) ! direct beam radiation (vis=forc_sols , nir=forc_soll )
real(r8), pointer :: forc_solai(:,:) ! diffuse radiation (vis=forc_solsd, nir=forc_solld)
real(r8), pointer :: eflx_traffic_pft(:) ! traffic sensible heat flux (W/m**2)
real(r8), pointer :: eflx_wasteheat_pft(:) ! sensible heat flux from urban heating/cooling sources of waste heat (W/m**2)
real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width
real(r8), pointer :: eflx_heat_from_ac_pft(:) !sensible heat flux put back into canyon due to removal by AC (W/m**2)
!
! local pointers to original implicit out arguments
!
real(r8), pointer :: errh2o(:) ! water conservation error (mm H2O)
real(r8), pointer :: errsol(:) ! solar radiation conservation error (W/m**2)
real(r8), pointer :: errlon(:) ! longwave radiation conservation error (W/m**2)
real(r8), pointer :: errseb(:) ! surface energy conservation error (W/m**2)
real(r8), pointer :: netrad(:) ! net radiation (positive downward) (W/m**2)
real(r8), pointer :: errsoi_col(:) ! column-level soil/lake energy conservation error (W/m**2)
!
!EOP
!
! !OTHER LOCAL VARIABLES:
integer :: p,c,l,g ! indices
logical :: found ! flag in search loop
integer :: indexp,indexc,indexl,indexg ! index of first found in search loop
real(r8) :: forc_rain_col(lbc:ubc) ! column level rain rate [mm/s]
real(r8) :: forc_snow_col(lbc:ubc) ! column level snow rate [mm/s]
!-----------------------------------------------------------------------
! Assign local pointers to derived type scalar members (gridcell-level)
forc_rain => clm_a2l%forc_rain
forc_snow => clm_a2l%forc_snow
forc_lwrad => clm_a2l%forc_lwrad
forc_solad => clm_a2l%forc_solad
forc_solai => clm_a2l%forc_solai
! Assign local pointers to derived type scalar members (landunit-level)
ltype => clm3%g%l%itype
canyon_hwr => clm3%g%l%canyon_hwr
! Assign local pointers to derived type scalar members (column-level)
ctype => clm3%g%l%c%itype
cgridcell => clm3%g%l%c%gridcell
cwtgcell => clm3%g%l%c%wtgcell
endwb => clm3%g%l%c%cwbal%endwb
begwb => clm3%g%l%c%cwbal%begwb
qflx_surf => clm3%g%l%c%cwf%qflx_surf
qflx_qrgwl => clm3%g%l%c%cwf%qflx_qrgwl
qflx_drain => clm3%g%l%c%cwf%qflx_drain
qflx_runoff => clm3%g%l%c%cwf%qflx_runoff
qflx_snwcp_ice => clm3%g%l%c%cwf%pwf_a%qflx_snwcp_ice
qflx_evap_tot => clm3%g%l%c%cwf%pwf_a%qflx_evap_tot
errh2o => clm3%g%l%c%cwbal%errh2o
errsoi_col => clm3%g%l%c%cebal%errsoi
! Assign local pointers to derived type scalar members (pft-level)
pgridcell => clm3%g%l%c%p%gridcell
plandunit => clm3%g%l%c%p%landunit
pwtgcell => clm3%g%l%c%p%wtgcell
fsa => clm3%g%l%c%p%pef%fsa
fsr => clm3%g%l%c%p%pef%fsr
eflx_lwrad_out => clm3%g%l%c%p%pef%eflx_lwrad_out
eflx_lwrad_net => clm3%g%l%c%p%pef%eflx_lwrad_net
sabv => clm3%g%l%c%p%pef%sabv
sabg => clm3%g%l%c%p%pef%sabg
eflx_sh_tot => clm3%g%l%c%p%pef%eflx_sh_tot
eflx_lh_tot => clm3%g%l%c%p%pef%eflx_lh_tot
eflx_soil_grnd => clm3%g%l%c%p%pef%eflx_soil_grnd
errsol => clm3%g%l%c%p%pebal%errsol
errseb => clm3%g%l%c%p%pebal%errseb
errlon => clm3%g%l%c%p%pebal%errlon
netrad => clm3%g%l%c%p%pef%netrad
eflx_wasteheat_pft => clm3%g%l%c%p%pef%eflx_wasteheat_pft
eflx_heat_from_ac_pft => clm3%g%l%c%p%pef%eflx_heat_from_ac_pft
eflx_traffic_pft => clm3%g%l%c%p%pef%eflx_traffic_pft
! Assign local pointers to derived type scalar members (gridcell-level)
qflx_runoffg => clm3%g%gwf%qflx_runoffg
qflx_liq_dynbal => clm3%g%gwf%qflx_liq_dynbal
qflx_snwcp_iceg => clm3%g%gwf%qflx_snwcp_iceg
qflx_ice_dynbal => clm3%g%gwf%qflx_ice_dynbal
eflx_sh_totg => clm3%g%gef%eflx_sh_totg
eflx_dynbal => clm3%g%gef%eflx_dynbal
! Get step size and time step
! Determine column level incoming snow and rain
! Assume no incident precipitation on urban wall columns (as in Hydrology1Mod.F90).
do c = lbc,ubc
g = cgridcell(c)
if (ctype(c) == icol_sunwall .or. ctype(c) == icol_shadewall) then
forc_rain_col(c) = 0.
forc_snow_col(c) = 0.
else
forc_rain_col(c) = forc_rain(g)
forc_snow_col(c) = forc_snow(g)
end if
end do
! Water balance check
do c = lbc, ubc
g = cgridcell(c)
errh2o(c) = endwb(c) - begwb(c) &
- (forc_rain_col(c) + forc_snow_col(c) - qflx_evap_tot(c) - qflx_surf(c) &
- qflx_qrgwl(c) - qflx_drain(c) - qflx_snwcp_ice(c)) * dtime
end do
found = .false.
do c = lbc, ubc
if (cwtgcell(c) > 0._r8 .and. abs(errh2o(c)) > 1e-7_r8) then
found = .true.
indexc = c
end if
end do
if ( found ) then
! write(6,*)'WARNING: water balance error ',&
! ' nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc)
if ((ctype(indexc) .eq. icol_roof .or. ctype(indexc) .eq. icol_road_imperv .or. &
ctype(indexc) .eq. icol_road_perv) .and. abs(errh2o(indexc)) > 1.e-1 .and. (nstep > 2) ) then
write(6,*)'clm urban model is stopping - error is greater than 1.e-1'
write(6,*)'nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc)
write(6,*)'ctype(indexc): ',ctype(indexc)
write(6,*)'forc_rain = ',forc_rain_col(indexc)
write(6,*)'forc_snow = ',forc_snow_col(indexc)
write(6,*)'endwb = ',endwb(indexc)
write(6,*)'begwb = ',begwb(indexc)
write(6,*)'qflx_evap_tot= ',qflx_evap_tot(indexc)
write(6,*)'qflx_surf = ',qflx_surf(indexc)
write(6,*)'qflx_qrgwl = ',qflx_qrgwl(indexc)
write(6,*)'qflx_drain = ',qflx_drain(indexc)
write(6,*)'qflx_snwcp_ice = ',qflx_snwcp_ice(indexc)
write(6,*)'clm model is stopping'
call endrun()
else if (abs(errh2o(indexc)) > .10_r8 .and. (nstep > 2) ) then
write(6,*)'clm model is stopping - error is greater than .10'
write(6,*)'nstep = ',nstep,' indexc= ',indexc,' errh2o= ',errh2o(indexc)
write(6,*)'ctype(indexc): ',ctype(indexc)
write(6,*)'forc_rain = ',forc_rain_col(indexc)
write(6,*)'forc_snow = ',forc_snow_col(indexc)
write(6,*)'endwb = ',endwb(indexc)
write(6,*)'begwb = ',begwb(indexc)
write(6,*)'qflx_evap_tot= ',qflx_evap_tot(indexc)
write(6,*)'qflx_surf = ',qflx_surf(indexc)
write(6,*)'qflx_qrgwl = ',qflx_qrgwl(indexc)
write(6,*)'qflx_drain = ',qflx_drain(indexc)
write(6,*)'qflx_snwcp_ice = ',qflx_snwcp_ice(indexc)
write(6,*)'clm model is stopping'
call endrun()
end if
end if
! Energy balance checks
do p = lbp, ubp
if (pwtgcell(p)>0._r8) then
g = pgridcell(p)
l = plandunit(p)
! Solar radiation energy balance
! Do not do this check for an urban pft since it will not balance on a per-column
! level because of interactions between columns and since a separate check is done
! in the urban radiation module
if (ltype(l) /= isturb) then
errsol(p) = fsa(p) + fsr(p) &
- (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2))
else
errsol(p) = spval
end if
! Longwave radiation energy balance
! Do not do this check for an urban pft since it will not balance on a per-column
! level because of interactions between columns and since a separate check is done
! in the urban radiation module
if (ltype(l) /= isturb) then
errlon(p) = eflx_lwrad_out(p) - eflx_lwrad_net(p) - forc_lwrad(g)
else
errlon(p) = spval
end if
! Surface energy balance
! Changed to using (eflx_lwrad_net) here instead of (forc_lwrad - eflx_lwrad_out) because
! there are longwave interactions between urban columns (and therefore pfts).
! For surfaces other than urban, (eflx_lwrad_net) equals (forc_lwrad - eflx_lwrad_out),
! and a separate check is done above for these terms.
if (ltype(l) /= isturb) then
errseb(p) = sabv(p) + sabg(p) + forc_lwrad(g) - eflx_lwrad_out(p) &
- eflx_sh_tot(p) - eflx_lh_tot(p) - eflx_soil_grnd(p)
else
errseb(p) = sabv(p) + sabg(p) &
- eflx_lwrad_net(p) &
- eflx_sh_tot(p) - eflx_lh_tot(p) - eflx_soil_grnd(p) &
+ eflx_wasteheat_pft(p) + eflx_heat_from_ac_pft(p) + eflx_traffic_pft(p)
end if
netrad(p) = fsa(p) - eflx_lwrad_net(p)
end if
end do
! Solar radiation energy balance check
found = .false.
do p = lbp, ubp
if (pwtgcell(p)>0._r8) then
if ( (errsol(p) /= spval) .and. (abs(errsol(p)) > .10_r8) ) then
found = .true.
indexp = p
indexg = pgridcell(p)
end if
end if
end do
if ( found .and. (nstep > 2) ) then
write(6,100)'BalanceCheck: solar radiation balance error', nstep, indexp, errsol(indexp)
write(6,*)'fsa = ',fsa(indexp)
write(6,*)'fsr = ',fsr(indexp)
write(6,*)'forc_solad(1)= ',forc_solad(indexg,1)
write(6,*)'forc_solad(2)= ',forc_solad(indexg,2)
write(6,*)'forc_solai(1)= ',forc_solai(indexg,1)
write(6,*)'forc_solai(2)= ',forc_solai(indexg,2)
write(6,*)'forc_tot = ',forc_solad(indexg,1)+forc_solad(indexg,2)&
+forc_solai(indexg,1)+forc_solai(indexg,2)
write(6,*)'clm model is stopping'
call endrun()
end if
! Longwave radiation energy balance check
found = .false.
do p = lbp, ubp
if (pwtgcell(p)>0._r8) then
if ( (errlon(p) /= spval) .and. (abs(errlon(p)) > .10_r8) ) then
found = .true.
indexp = p
end if
end if
end do
if ( found .and. (nstep > 2) ) then
write(6,100)'BalanceCheck: longwave enery balance error',nstep,indexp,errlon(indexp)
write(6,*)'clm model is stopping'
call endrun()
end if
! Surface energy balance check
found = .false.
do p = lbp, ubp
if (pwtgcell(p)>0._r8) then
if (abs(errseb(p)) > .10_r8 ) then
found = .true.
indexp = p
end if
end if
end do
if ( found .and. (nstep > 2) ) then
write(6,100)'BalanceCheck: surface flux energy balance error',nstep,indexp,errseb(indexp)
write(6,*)' sabv = ',sabv(indexp)
write(6,*)' sabg = ',sabg(indexp)
write(6,*)' eflx_lwrad_net = ',eflx_lwrad_net(indexp)
write(6,*)' eflx_sh_tot = ',eflx_sh_tot(indexp)
write(6,*)' eflx_lh_tot = ',eflx_lh_tot(indexp)
write(6,*)' eflx_soil_grnd = ',eflx_soil_grnd(indexp)
write(6,*)'clm model is stopping'
call endrun()
end if
! Soil energy balance check
found = .false.
do c = lbc, ubc
if (abs(errsoi_col(c)) > 1.0e-7_r8 ) then
found = .true.
indexc = c
end if
end do
if ( found ) then
write(6,100)'BalanceCheck: soil balance error',nstep,indexc,errsoi_col(indexc)
if (abs(errsoi_col(indexc)) > .10_r8 .and. (nstep > 2) ) then
write(6,*)'clm model is stopping'
call endrun()
end if
end if
! Update SH and RUNOFF for dynamic land cover change energy and water fluxes
call c2g( lbc, ubc, lbl, ubl, lbg, ubg, &
qflx_runoff(lbc:ubc), qflx_runoffg(lbg:ubg), &
c2l_scale_type= 'urbanf', l2g_scale_type='unity' )
do g = lbg, ubg
qflx_runoffg(g) = qflx_runoffg(g) - qflx_liq_dynbal(g)
enddo
call c2g( lbc, ubc, lbl, ubl, lbg, ubg, &
qflx_snwcp_ice(lbc:ubc), qflx_snwcp_iceg(lbg:ubg), &
c2l_scale_type= 'urbanf', l2g_scale_type='unity' )
do g = lbg, ubg
qflx_snwcp_iceg(g) = qflx_snwcp_iceg(g) - qflx_ice_dynbal(g)
enddo
call p2g( lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg, &
eflx_sh_tot(lbp:ubp), eflx_sh_totg(lbg:ubg), &
p2c_scale_type='unity',c2l_scale_type='urbanf',l2g_scale_type='unity')
do g = lbg, ubg
eflx_sh_totg(g) = eflx_sh_totg(g) - eflx_dynbal(g)
enddo
100 format (1x,a,' nstep =',i10,' point =',i6,' imbalance =',f12.6,' W/m2')
200 format (1x,a,' nstep =',i10,' point =',i6,' imbalance =',f12.6,' mm')
end subroutine BalanceCheck
end module BalanceCheckMod
!=================================================================================================
module BareGroundFluxesMod 1,1
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: BareGroundFluxesMod
!
! !DESCRIPTION:
! Compute sensible and latent fluxes and their derivatives with respect
! to ground temperature using ground temperatures from previous time step.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: BareGroundFluxes ! Calculate sensible and latent heat fluxes
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------------
contains
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: BareGroundFluxes
!
! !INTERFACE:
subroutine BareGroundFluxes(lbp, ubp, num_nolakep, filter_nolakep) 1,11
!
! !DESCRIPTION:
! Compute sensible and latent fluxes and their derivatives with respect
! to ground temperature using ground temperatures from previous time step.
!
! !USES:
use clmtype
use clm_varpar , only : nlevgrnd
use clm_varcon , only : cpair, vkc, grav, denice, denh2o, istsoil
#ifdef CROP
use clm_varcon , only : istcrop
#endif
use shr_const_mod , only : SHR_CONST_RGAS
use FrictionVelocityMod, only : FrictionVelocity, MoninObukIni
use QSatMod , only : QSat
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbp, ubp ! pft bounds
integer, intent(in) :: num_nolakep ! number of pft non-lake points in pft filter
integer, intent(in) :: filter_nolakep(ubp-lbp+1) ! pft filter for non-lake points
!
! !CALLED FROM:
! subroutine Biogeophysics1 in module Biogeophysics1Mod
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! 12/19/01, Peter Thornton
! This routine originally had a long list of parameters, and also a reference to
! the entire clm derived type. For consistency, only the derived type reference
! is passed (now pointing to the current column and pft), and the other original
! parameters are initialized locally. Using t_grnd instead of tg (tg eliminated
! as redundant).
! 1/23/02, PET: Added pft reference as parameter. All outputs will be written
! to the pft data structures, and averaged to the column level outside of
! this routine.
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: pgridcell(:) ! pft's gridcell index
integer , pointer :: plandunit(:) ! pft's landunit index
integer , pointer :: ltype(:) ! landunit type
integer , pointer :: frac_veg_nosno(:) ! fraction of vegetation not covered by snow (0 OR 1) [-]
real(r8), pointer :: t_grnd(:) ! ground surface temperature [K]
real(r8), pointer :: thm(:) ! intermediate variable (forc_t+0.0098*forc_hgt_t_pft)
real(r8), pointer :: qg(:) ! specific humidity at ground surface [kg/kg]
real(r8), pointer :: thv(:) ! virtual potential temperature (kelvin)
real(r8), pointer :: dqgdT(:) ! temperature derivative of "qg"
real(r8), pointer :: htvp(:) ! latent heat of evaporation (/sublimation) [J/kg]
real(r8), pointer :: beta(:) ! coefficient of conective velocity [-]
real(r8), pointer :: zii(:) ! convective boundary height [m]
real(r8), pointer :: forc_u(:) ! atmospheric wind speed in east direction (m/s)
real(r8), pointer :: forc_v(:) ! atmospheric wind speed in north direction (m/s)
real(r8), pointer :: forc_t(:) ! atmospheric temperature (Kelvin)
real(r8), pointer :: forc_th(:) ! atmospheric potential temperature (Kelvin)
real(r8), pointer :: forc_q(:) ! atmospheric specific humidity (kg/kg)
real(r8), pointer :: forc_rho(:) ! density (kg/m**3)
real(r8), pointer :: forc_pbot(:) ! atmospheric pressure (Pa)
real(r8), pointer :: forc_hgt_u_pft(:) ! observational height of wind at pft level [m]
real(r8), pointer :: psnsun(:) ! sunlit leaf photosynthesis (umol CO2 /m**2/ s)
real(r8), pointer :: psnsha(:) ! shaded leaf photosynthesis (umol CO2 /m**2/ s)
real(r8), pointer :: z0mg_col(:) ! roughness length, momentum [m]
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
real(r8), pointer :: dz(:,:) ! layer depth (m)
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity)
real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1)
real(r8), pointer :: soilbeta(:) ! soil wetness relative to field capacity
!
! local pointers to implicit inout arguments
!
real(r8), pointer :: z0hg_col(:) ! roughness length, sensible heat [m]
real(r8), pointer :: z0qg_col(:) ! roughness length, latent heat [m]
!
! local pointers to implicit out arguments
!
real(r8), pointer :: dlrad(:) ! downward longwave radiation below the canopy [W/m2]
real(r8), pointer :: ulrad(:) ! upward longwave radiation above the canopy [W/m2]
real(r8), pointer :: cgrnds(:) ! deriv, of soil sensible heat flux wrt soil temp [w/m2/k]
real(r8), pointer :: cgrndl(:) ! deriv of soil latent heat flux wrt soil temp [w/m**2/k]
real(r8), pointer :: cgrnd(:) ! deriv. of soil energy flux wrt to soil temp [w/m2/k]
real(r8), pointer :: taux(:) ! wind (shear) stress: e-w (kg/m/s**2)
real(r8), pointer :: tauy(:) ! wind (shear) stress: n-s (kg/m/s**2)
real(r8), pointer :: eflx_sh_grnd(:) ! sensible heat flux from ground (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: qflx_evap_soi(:) ! soil evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (Kelvin)
real(r8), pointer :: q_ref2m(:) ! 2 m height surface specific humidity (kg/kg)
real(r8), pointer :: t_ref2m_r(:) ! Rural 2 m height surface air temperature (Kelvin)
real(r8), pointer :: rh_ref2m_r(:) ! Rural 2 m height surface relative humidity (%)
real(r8), pointer :: rh_ref2m(:) ! 2 m height surface relative humidity (%)
real(r8), pointer :: t_veg(:) ! vegetation temperature (Kelvin)
real(r8), pointer :: btran(:) ! transpiration wetness factor (0 to 1)
real(r8), pointer :: rssun(:) ! sunlit stomatal resistance (s/m)
real(r8), pointer :: rssha(:) ! shaded stomatal resistance (s/m)
real(r8), pointer :: ram1(:) ! aerodynamical resistance (s/m)
real(r8), pointer :: fpsn(:) ! photosynthesis (umol CO2 /m**2 /s)
real(r8), pointer :: rootr(:,:) ! effective fraction of roots in each soil layer
real(r8), pointer :: rresis(:,:) ! root resistance by layer (0-1) (nlevgrnd)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer, parameter :: niters = 3 ! maximum number of iterations for surface temperature
integer :: p,c,g,f,j,l ! indices
integer :: filterp(ubp-lbp+1) ! pft filter for vegetated pfts
integer :: fn ! number of values in local pft filter
integer :: fp ! lake filter pft index
integer :: iter ! iteration index
real(r8) :: zldis(lbp:ubp) ! reference height "minus" zero displacement height [m]
real(r8) :: displa(lbp:ubp) ! displacement height [m]
real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory
real(r8) :: wc ! convective velocity [m/s]
real(r8) :: dth(lbp:ubp) ! diff of virtual temp. between ref. height and surface
real(r8) :: dthv ! diff of vir. poten. temp. between ref. height and surface
real(r8) :: dqh(lbp:ubp) ! diff of humidity between ref. height and surface
real(r8) :: obu(lbp:ubp) ! Monin-Obukhov length (m)
real(r8) :: ur(lbp:ubp) ! wind speed at reference height [m/s]
real(r8) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s]
real(r8) :: temp1(lbp:ubp) ! relation for potential temperature profile
real(r8) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m
real(r8) :: temp2(lbp:ubp) ! relation for specific humidity profile
real(r8) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m
real(r8) :: ustar(lbp:ubp) ! friction velocity [m/s]
real(r8) :: tstar ! temperature scaling parameter
real(r8) :: qstar ! moisture scaling parameter
real(r8) :: thvstar ! virtual potential temperature scaling parameter
real(r8) :: cf ! heat transfer coefficient from leaves [-]
real(r8) :: ram ! aerodynamical resistance [s/m]
real(r8) :: rah ! thermal resistance [s/m]
real(r8) :: raw ! moisture resistance [s/m]
real(r8) :: raih ! temporary variable [kg/m2/s]
real(r8) :: raiw ! temporary variable [kg/m2/s]
real(r8) :: fm(lbp:ubp) ! needed for BGC only to diagnose 10m wind speed
real(r8) :: z0mg_pft(lbp:ubp)
real(r8) :: z0hg_pft(lbp:ubp)
real(r8) :: z0qg_pft(lbp:ubp)
real(r8) :: e_ref2m ! 2 m height surface saturated vapor pressure [Pa]
real(r8) :: de2mdT ! derivative of 2 m height surface saturated vapor pressure on t_ref2m
real(r8) :: qsat_ref2m ! 2 m height surface saturated specific humidity [kg/kg]
real(r8) :: dqsat2mdT ! derivative of 2 m height surface saturated specific humidity on t_ref2m
real(r8) :: www ! surface soil wetness [-]
!------------------------------------------------------------------------------
! Assign local pointers to derived type members (gridcell-level)
forc_th => clm_a2l%forc_th
forc_pbot => clm_a2l%forc_pbot
forc_t => clm_a2l%forc_t
forc_u => clm_a2l%forc_u
forc_v => clm_a2l%forc_v
forc_rho => clm_a2l%forc_rho
forc_q => clm_a2l%forc_q
! Assign local pointers to derived type members (landunit-level)
ltype => clm3%g%l%itype
! Assign local pointers to derived type members (column-level)
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
frac_veg_nosno => clm3%g%l%c%p%pps%frac_veg_nosno
dlrad => clm3%g%l%c%p%pef%dlrad
ulrad => clm3%g%l%c%p%pef%ulrad
t_grnd => clm3%g%l%c%ces%t_grnd
qg => clm3%g%l%c%cws%qg
z0mg_col => clm3%g%l%c%cps%z0mg
z0hg_col => clm3%g%l%c%cps%z0hg
z0qg_col => clm3%g%l%c%cps%z0qg
thv => clm3%g%l%c%ces%thv
beta => clm3%g%l%c%cps%beta
zii => clm3%g%l%c%cps%zii
ram1 => clm3%g%l%c%p%pps%ram1
cgrnds => clm3%g%l%c%p%pef%cgrnds
cgrndl => clm3%g%l%c%p%pef%cgrndl
cgrnd => clm3%g%l%c%p%pef%cgrnd
dqgdT => clm3%g%l%c%cws%dqgdT
htvp => clm3%g%l%c%cps%htvp
watsat => clm3%g%l%c%cps%watsat
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
dz => clm3%g%l%c%cps%dz
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
frac_sno => clm3%g%l%c%cps%frac_sno
soilbeta => clm3%g%l%c%cws%soilbeta
! Assign local pointers to derived type members (pft-level)
taux => clm3%g%l%c%p%pmf%taux
tauy => clm3%g%l%c%p%pmf%tauy
eflx_sh_grnd => clm3%g%l%c%p%pef%eflx_sh_grnd
eflx_sh_tot => clm3%g%l%c%p%pef%eflx_sh_tot
qflx_evap_soi => clm3%g%l%c%p%pwf%qflx_evap_soi
qflx_evap_tot => clm3%g%l%c%p%pwf%qflx_evap_tot
t_ref2m => clm3%g%l%c%p%pes%t_ref2m
q_ref2m => clm3%g%l%c%p%pes%q_ref2m
t_ref2m_r => clm3%g%l%c%p%pes%t_ref2m_r
rh_ref2m_r => clm3%g%l%c%p%pes%rh_ref2m_r
plandunit => clm3%g%l%c%p%landunit
rh_ref2m => clm3%g%l%c%p%pes%rh_ref2m
t_veg => clm3%g%l%c%p%pes%t_veg
thm => clm3%g%l%c%p%pes%thm
btran => clm3%g%l%c%p%pps%btran
rssun => clm3%g%l%c%p%pps%rssun
rssha => clm3%g%l%c%p%pps%rssha
rootr => clm3%g%l%c%p%pps%rootr
rresis => clm3%g%l%c%p%pps%rresis
psnsun => clm3%g%l%c%p%pcf%psnsun
psnsha => clm3%g%l%c%p%pcf%psnsha
fpsn => clm3%g%l%c%p%pcf%fpsn
forc_hgt_u_pft => clm3%g%l%c%p%pps%forc_hgt_u_pft
! Filter pfts where frac_veg_nosno is zero
fn = 0
do fp = 1,num_nolakep
p = filter_nolakep(fp)
if (frac_veg_nosno(p) == 0) then
fn = fn + 1
filterp(fn) = p
end if
end do
! Compute sensible and latent fluxes and their derivatives with respect
! to ground temperature using ground temperatures from previous time step
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
g = pgridcell(p)
! Initialization variables
displa(p) = 0._r8
dlrad(p) = 0._r8
ulrad(p) = 0._r8
ur(p) = max(1.0_r8,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g)))
dth(p) = thm(p)-t_grnd(c)
dqh(p) = forc_q(g)-qg(c)
dthv = dth(p)*(1._r8+0.61_r8*forc_q(g))+0.61_r8*forc_th(g)*dqh(p)
zldis(p) = forc_hgt_u_pft(p)
! Copy column roughness to local pft-level arrays
z0mg_pft(p) = z0mg_col(c)
z0hg_pft(p) = z0hg_col(c)
z0qg_pft(p) = z0qg_col(c)
! Initialize Monin-Obukhov length and wind speed
call MoninObukIni(ur(p), thv(c), dthv, zldis(p), z0mg_pft(p), um(p), obu(p))
end do
! Perform stability iteration
! Determine friction velocity, and potential temperature and humidity
! profiles of the surface boundary layer
do iter = 1, niters
call FrictionVelocity(lbp, ubp, fn, filterp, &
displa, z0mg_pft, z0hg_pft, z0qg_pft, &
obu, iter, ur, um, ustar, &
temp1, temp2, temp12m, temp22m, fm)
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
g = pgridcell(p)
tstar = temp1(p)*dth(p)
qstar = temp2(p)*dqh(p)
z0hg_pft(p) = z0mg_pft(p)/exp(0.13_r8 * (ustar(p)*z0mg_pft(p)/1.5e-5_r8)**0.45_r8)
z0qg_pft(p) = z0hg_pft(p)
thvstar = tstar*(1._r8+0.61_r8*forc_q(g)) + 0.61_r8*forc_th(g)*qstar
zeta = zldis(p)*vkc*grav*thvstar/(ustar(p)**2*thv(c))
if (zeta >= 0._r8) then !stable
zeta = min(2._r8,max(zeta,0.01_r8))
um(p) = max(ur(p),0.1_r8)
else !unstable
zeta = max(-100._r8,min(zeta,-0.01_r8))
wc = beta(c)*(-grav*ustar(p)*thvstar*zii(c)/thv(c))**0.333_r8
um(p) = sqrt(ur(p)*ur(p) + wc*wc)
end if
obu(p) = zldis(p)/zeta
end do
end do ! end stability iteration
do j = 1, nlevgrnd
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
rootr(p,j) = 0._r8
rresis(p,j) = 0._r8
end do
end do
!dir$ prefervector
!dir$ concurrent
!cdir nodep
do f = 1, fn
p = filterp(f)
c = pcolumn(p)
g = pgridcell(p)
l = plandunit(p)
! Determine aerodynamic resistances
ram = 1._r8/(ustar(p)*ustar(p)/um(p))
rah = 1._r8/(temp1(p)*ustar(p))
raw = 1._r8/(temp2(p)*ustar(p))
raih = forc_rho(g)*cpair/rah
! Soil evaporation resistance
www = (h2osoi_liq(c,1)/denh2o+h2osoi_ice(c,1)/denice)/dz(c,1)/watsat(c,1)
www = min(max(www,0.0_r8),1._r8)
!changed by K.Sakaguchi. Soilbeta is used for evaporation
if (dqh(p) .gt. 0._r8) then !dew (beta is not applied, just like rsoil used to be)
raiw = forc_rho(g)/(raw)
else
! Lee and Pielke 1992 beta is applied
raiw = soilbeta(c)*forc_rho(g)/(raw)
end if
ram1(p) = ram !pass value to global variable
! Output to pft-level data structures
! Derivative of fluxes with respect to ground temperature
cgrnds(p) = raih
cgrndl(p) = raiw*dqgdT(c)
cgrnd(p) = cgrnds(p) + htvp(c)*cgrndl(p)
! Surface fluxes of momentum, sensible and latent heat
! using ground temperatures from previous time step
taux(p) = -forc_rho(g)*forc_u(g)/ram
tauy(p) = -forc_rho(g)*forc_v(g)/ram
eflx_sh_grnd(p) = -raih*dth(p)
eflx_sh_tot(p) = eflx_sh_grnd(p)
qflx_evap_soi(p) = -raiw*dqh(p)
qflx_evap_tot(p) = qflx_evap_soi(p)
! 2 m height air temperature
t_ref2m(p) = thm(p) + temp1(p)*dth(p)*(1._r8/temp12m(p) - 1._r8/temp1(p))
! 2 m height specific humidity
q_ref2m(p) = forc_q(g) + temp2(p)*dqh(p)*(1._r8/temp22m(p) - 1._r8/temp2(p))
! 2 m height relative humidity
call QSat(t_ref2m(p), forc_pbot(g), e_ref2m, de2mdT, qsat_ref2m, dqsat2mdT)
rh_ref2m(p) = min(100._r8, q_ref2m(p) / qsat_ref2m * 100._r8)
#ifndef CROP
if (ltype(l) == istsoil) then
#else
if (ltype(l) == istsoil .or. ltype(l) == istcrop) then
#endif
rh_ref2m_r(p) = rh_ref2m(p)
t_ref2m_r(p) = t_ref2m(p)
end if
! Variables needed by history tape
t_veg(p) = forc_t(g)
btran(p) = 0._r8
cf = forc_pbot(g)/(SHR_CONST_RGAS*0.001_r8*thm(p))*1.e06_r8
rssun(p) = 1._r8/1.e15_r8 * cf
rssha(p) = 1._r8/1.e15_r8 * cf
! Add the following to avoid NaN
psnsun(p) = 0._r8
psnsha(p) = 0._r8
fpsn(p) = 0._r8
clm3%g%l%c%p%pps%lncsun(p) = 0._r8
clm3%g%l%c%p%pps%lncsha(p) = 0._r8
clm3%g%l%c%p%pps%vcmxsun(p) = 0._r8
clm3%g%l%c%p%pps%vcmxsha(p) = 0._r8
! adding code for isotopes, 8/17/05, PET
clm3%g%l%c%p%pps%cisun(p) = 0._r8
clm3%g%l%c%p%pps%cisha(p) = 0._r8
#if (defined C13)
clm3%g%l%c%p%pps%alphapsnsun(p) = 0._r8
clm3%g%l%c%p%pps%alphapsnsha(p) = 0._r8
clm3%g%l%c%p%pepv%rc13_canair(p) = 0._r8
clm3%g%l%c%p%pepv%rc13_psnsun(p) = 0._r8
clm3%g%l%c%p%pepv%rc13_psnsha(p) = 0._r8
clm3%g%l%c%p%pc13f%psnsun(p) = 0._r8
clm3%g%l%c%p%pc13f%psnsha(p) = 0._r8
clm3%g%l%c%p%pc13f%fpsn(p) = 0._r8
#endif
end do
end subroutine BareGroundFluxes
end module BareGroundFluxesMod
module Biogeophysics1Mod 1,2
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: Biogeophysics1Mod
!
! !DESCRIPTION:
! Performs calculation of leaf temperature and surface fluxes.
! Biogeophysics2.F90 then determines soil/snow and ground
! temperatures and updates the surface fluxes for the new ground
! temperature.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use globals , only:nstep
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: Biogeophysics1 ! Calculate leaf temperature and surface fluxes
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!------------------------------------------------------------------------------
contains
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: Biogeophysics1
!
! !INTERFACE:
subroutine Biogeophysics1(lbg, ubg, lbc, ubc, lbp, ubp, & 1,7
num_nolakec, filter_nolakec, num_nolakep, filter_nolakep)
!
! !DESCRIPTION:
! This is the main subroutine to execute the calculation of leaf temperature
! and surface fluxes. Biogeophysics2.F90 then determines soil/snow and ground
! temperatures and updates the surface fluxes for the new ground
! temperature.
!
! Calling sequence is:
! Biogeophysics1: surface biogeophysics driver
! -> QSat: saturated vapor pressure, specific humidity, and
! derivatives at ground surface and derivatives at
! leaf surface using updated leaf temperature
! Leaf temperature
! Foliage energy conservation is given by the foliage energy budget
! equation:
! Rnet - Hf - LEf = 0
! The equation is solved by Newton-Raphson iteration, in which this
! iteration includes the calculation of the photosynthesis and
! stomatal resistance, and the integration of turbulent flux profiles.
! The sensible and latent heat transfer between foliage and atmosphere
! and ground is linked by the equations:
! Ha = Hf + Hg and Ea = Ef + Eg
!
! !USES:
use clmtype
use clm_varcon , only : denh2o, denice, roverg, hvap, hsub, &
istice, istwet, istsoil, isturb, istdlak, &
zlnd, zsno, tfrz, &
icol_roof, icol_sunwall, icol_shadewall, &
icol_road_imperv, icol_road_perv, tfrz, spval, istdlak
#ifdef CROP
use clm_varcon , only : istcrop
#endif
use clm_varpar , only : nlevgrnd, nlevurb, nlevsno, max_pft_per_gcell, nlevsoi
use QSatMod , only : QSat
use shr_const_mod , only : SHR_CONST_PI
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbg, ubg ! gridcell-index bounds
integer, intent(in) :: lbc, ubc ! column-index bounds
integer, intent(in) :: lbp, ubp ! pft-index bounds
integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
integer, intent(in) :: num_nolakep ! number of column non-lake points in pft filter
integer, intent(in) :: filter_nolakep(ubp-lbp+1) ! pft filter for non-lake points
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! Migrated to clm2.0 by Keith Oleson and Mariana Vertenstein
! Migrated to clm2.1 new data structures by Peter Thornton and M. Vertenstein
! 27 February 2008: Keith Oleson; weighted soil/snow emissivity
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: ivt(:) !pft vegetation type
integer , pointer :: ityplun(:) !landunit type
integer , pointer :: clandunit(:) !column's landunit index
integer , pointer :: cgridcell(:) !column's gridcell index
real(r8), pointer :: pwtgcell(:) !weight relative to gridcell for each pft
integer , pointer :: ctype(:) !column type
real(r8), pointer :: forc_pbot(:) !atmospheric pressure (Pa)
real(r8), pointer :: forc_q(:) !atmospheric specific humidity (kg/kg)
real(r8), pointer :: forc_t(:) !atmospheric temperature (Kelvin)
real(r8), pointer :: forc_hgt_t(:) !observational height of temperature [m]
real(r8), pointer :: forc_hgt_u(:) !observational height of wind [m]
real(r8), pointer :: forc_hgt_q(:) !observational height of specific humidity [m]
integer , pointer :: npfts(:) !number of pfts on gridcell
integer , pointer :: pfti(:) !initial pft on gridcell
integer , pointer :: plandunit(:) !pft's landunit index
real(r8), pointer :: forc_hgt_u_pft(:) !observational height of wind at pft level [m]
real(r8), pointer :: forc_hgt_t_pft(:) !observational height of temperature at pft level [m]
real(r8), pointer :: forc_hgt_q_pft(:) !observational height of specific humidity at pft level [m]
integer , pointer :: frac_veg_nosno(:) !fraction of vegetation not covered by snow (0 OR 1) [-]
integer , pointer :: pgridcell(:) !pft's gridcell index
integer , pointer :: pcolumn(:) !pft's column index
real(r8), pointer :: z_0_town(:) !momentum roughness length of urban landunit (m)
real(r8), pointer :: z_d_town(:) !displacement height of urban landunit (m)
real(r8), pointer :: forc_th(:) !atmospheric potential temperature (Kelvin)
real(r8), pointer :: forc_u(:) !atmospheric wind speed in east direction (m/s)
real(r8), pointer :: forc_v(:) !atmospheric wind speed in north direction (m/s)
real(r8), pointer :: smpmin(:) !restriction for min of soil potential (mm)
integer , pointer :: snl(:) !number of snow layers
real(r8), pointer :: frac_sno(:) !fraction of ground covered by snow (0 to 1)
real(r8), pointer :: h2osno(:) !snow water (mm H2O)
real(r8), pointer :: elai(:) !one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) !one-sided stem area index with burying by snow
real(r8), pointer :: z0mr(:) !ratio of momentum roughness length to canopy top height (-)
real(r8), pointer :: displar(:) !ratio of displacement height to canopy top height (-)
real(r8), pointer :: htop(:) !canopy top (m)
real(r8), pointer :: dz(:,:) !layer depth (m)
real(r8), pointer :: t_soisno(:,:) !soil temperature (Kelvin)
real(r8), pointer :: h2osoi_liq(:,:) !liquid water (kg/m2)
real(r8), pointer :: h2osoi_ice(:,:) !ice lens (kg/m2)
real(r8), pointer :: watsat(:,:) !volumetric soil water at saturation (porosity)
real(r8), pointer :: sucsat(:,:) !minimum soil suction (mm)
real(r8), pointer :: bsw(:,:) !Clapp and Hornberger "b"
real(r8), pointer :: watfc(:,:) !volumetric soil water at field capacity
real(r8), pointer :: watopt(:,:) !volumetric soil moisture corresponding to no restriction on ET from urban pervious surface
real(r8), pointer :: watdry(:,:) !volumetric soil moisture corresponding to no restriction on ET from urban pervious surface
real(r8), pointer :: rootfr_road_perv(:,:) !fraction of roots in each soil layer for urban pervious road
real(r8), pointer :: rootr_road_perv(:,:) !effective fraction of roots in each soil layer for urban pervious road
!
! local pointers to implicit out arguments
!
real(r8), pointer :: t_grnd(:) !ground temperature (Kelvin)
real(r8), pointer :: qg(:) !ground specific humidity [kg/kg]
real(r8), pointer :: dqgdT(:) !d(qg)/dT
real(r8), pointer :: emg(:) !ground emissivity
real(r8), pointer :: htvp(:) !latent heat of vapor of water (or sublimation) [j/kg]
real(r8), pointer :: beta(:) !coefficient of convective velocity [-]
real(r8), pointer :: zii(:) !convective boundary height [m]
real(r8), pointer :: thm(:) !intermediate variable (forc_t+0.0098*forc_hgt_t_pft)
real(r8), pointer :: thv(:) !virtual potential temperature (kelvin)
real(r8), pointer :: z0mg(:) !roughness length over ground, momentum [m]
real(r8), pointer :: z0hg(:) !roughness length over ground, sensible heat [m]
real(r8), pointer :: z0qg(:) !roughness length over ground, latent heat [m]
real(r8), pointer :: emv(:) !vegetation emissivity
real(r8), pointer :: z0m(:) !momentum roughness length (m)
real(r8), pointer :: displa(:) !displacement height (m)
real(r8), pointer :: z0mv(:) !roughness length over vegetation, momentum [m]
real(r8), pointer :: z0hv(:) !roughness length over vegetation, sensible heat [m]
real(r8), pointer :: z0qv(:) !roughness length over vegetation, latent heat [m]
real(r8), pointer :: eflx_sh_tot(:) !total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_tot_u(:) !urban total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_tot_r(:) !rural total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_tot(:) !total latent heat flux (W/m8*2) [+ to atm]
real(r8), pointer :: eflx_lh_tot_u(:) !urban total latent heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_tot_r(:) !rural total latent heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_veg(:) !sensible heat flux from leaves (W/m**2) [+ to atm]
real(r8), pointer :: qflx_evap_tot(:) !qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
real(r8), pointer :: qflx_evap_veg(:) !vegetation evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_tran_veg(:) !vegetation transpiration (mm H2O/s) (+ = to atm)
real(r8), pointer :: cgrnd(:) !deriv. of soil energy flux wrt to soil temp [w/m2/k]
real(r8), pointer :: cgrnds(:) !deriv. of soil sensible heat flux wrt soil temp [w/m2/k]
real(r8), pointer :: cgrndl(:) !deriv. of soil latent heat flux wrt soil temp [w/m**2/k]
real(r8) ,pointer :: tssbef(:,:) !soil/snow temperature before update
real(r8) ,pointer :: soilalpha(:) !factor that reduces ground saturated specific humidity (-)
real(r8) ,pointer :: soilbeta(:) !factor that reduces ground evaporation
real(r8) ,pointer :: soilalpha_u(:) !Urban factor that reduces ground saturated specific humidity (-)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: g,l,c,p !indices
integer :: j !soil/snow level index
integer :: fp !lake filter pft index
integer :: fc !lake filter column index
real(r8) :: qred !soil surface relative humidity
real(r8) :: avmuir !ir inverse optical depth per unit leaf area
real(r8) :: eg !water vapor pressure at temperature T [pa]
real(r8) :: qsatg !saturated humidity [kg/kg]
real(r8) :: degdT !d(eg)/dT
real(r8) :: qsatgdT !d(qsatg)/dT
real(r8) :: fac !soil wetness of surface layer
real(r8) :: psit !negative potential of soil
real(r8) :: hr !relative humidity
real(r8) :: hr_road_perv !relative humidity for urban pervious road
real(r8) :: wx !partial volume of ice and water of surface layer
real(r8) :: fac_fc !soil wetness of surface layer relative to field capacity
real(r8) :: eff_porosity ! effective porosity in layer
real(r8) :: vol_ice ! partial volume of ice lens in layer
real(r8) :: vol_liq ! partial volume of liquid water in layer
integer :: pi !index
!------------------------------------------------------------------------------
! Assign local pointers to derived type members (gridcell-level)
forc_hgt_t => clm_a2l%forc_hgt_t
forc_pbot => clm_a2l%forc_pbot
forc_q => clm_a2l%forc_q
forc_t => clm_a2l%forc_t
forc_th => clm_a2l%forc_th
forc_u => clm_a2l%forc_u
forc_v => clm_a2l%forc_v
forc_hgt_u => clm_a2l%forc_hgt_u
forc_hgt_q => clm_a2l%forc_hgt_q
npfts => clm3%g%npfts
pfti => clm3%g%pfti
! Assign local pointers to derived type members (landunit-level)
ityplun => clm3%g%l%itype
z_0_town => clm3%g%l%z_0_town
z_d_town => clm3%g%l%z_d_town
! Assign local pointers to derived type members (column-level)
cgridcell => clm3%g%l%c%gridcell
clandunit => clm3%g%l%c%landunit
ctype => clm3%g%l%c%itype
beta => clm3%g%l%c%cps%beta
dqgdT => clm3%g%l%c%cws%dqgdT
emg => clm3%g%l%c%cps%emg
frac_sno => clm3%g%l%c%cps%frac_sno
h2osno => clm3%g%l%c%cws%h2osno
htvp => clm3%g%l%c%cps%htvp
qg => clm3%g%l%c%cws%qg
smpmin => clm3%g%l%c%cps%smpmin
snl => clm3%g%l%c%cps%snl
t_grnd => clm3%g%l%c%ces%t_grnd
thv => clm3%g%l%c%ces%thv
z0hg => clm3%g%l%c%cps%z0hg
z0mg => clm3%g%l%c%cps%z0mg
z0qg => clm3%g%l%c%cps%z0qg
zii => clm3%g%l%c%cps%zii
bsw => clm3%g%l%c%cps%bsw
dz => clm3%g%l%c%cps%dz
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
soilalpha => clm3%g%l%c%cws%soilalpha
soilbeta => clm3%g%l%c%cws%soilbeta
soilalpha_u => clm3%g%l%c%cws%soilalpha_u
sucsat => clm3%g%l%c%cps%sucsat
t_soisno => clm3%g%l%c%ces%t_soisno
tssbef => clm3%g%l%c%ces%tssbef
watsat => clm3%g%l%c%cps%watsat
watfc => clm3%g%l%c%cps%watfc
watdry => clm3%g%l%c%cps%watdry
watopt => clm3%g%l%c%cps%watopt
rootfr_road_perv => clm3%g%l%c%cps%rootfr_road_perv
rootr_road_perv => clm3%g%l%c%cps%rootr_road_perv
! Assign local pointers to derived type members (pft-level)
ivt => clm3%g%l%c%p%itype
elai => clm3%g%l%c%p%pps%elai
esai => clm3%g%l%c%p%pps%esai
htop => clm3%g%l%c%p%pps%htop
emv => clm3%g%l%c%p%pps%emv
z0m => clm3%g%l%c%p%pps%z0m
displa => clm3%g%l%c%p%pps%displa
z0mv => clm3%g%l%c%p%pps%z0mv
z0hv => clm3%g%l%c%p%pps%z0hv
z0qv => clm3%g%l%c%p%pps%z0qv
eflx_sh_tot => clm3%g%l%c%p%pef%eflx_sh_tot
eflx_sh_tot_u => clm3%g%l%c%p%pef%eflx_sh_tot_u
eflx_sh_tot_r => clm3%g%l%c%p%pef%eflx_sh_tot_r
eflx_lh_tot => clm3%g%l%c%p%pef%eflx_lh_tot
eflx_lh_tot_u => clm3%g%l%c%p%pef%eflx_lh_tot_u
eflx_lh_tot_r => clm3%g%l%c%p%pef%eflx_lh_tot_r
eflx_sh_veg => clm3%g%l%c%p%pef%eflx_sh_veg
qflx_evap_tot => clm3%g%l%c%p%pwf%qflx_evap_tot
qflx_evap_veg => clm3%g%l%c%p%pwf%qflx_evap_veg
qflx_tran_veg => clm3%g%l%c%p%pwf%qflx_tran_veg
cgrnd => clm3%g%l%c%p%pef%cgrnd
cgrnds => clm3%g%l%c%p%pef%cgrnds
cgrndl => clm3%g%l%c%p%pef%cgrndl
forc_hgt_u_pft => clm3%g%l%c%p%pps%forc_hgt_u_pft
forc_hgt_t_pft => clm3%g%l%c%p%pps%forc_hgt_t_pft
forc_hgt_q_pft => clm3%g%l%c%p%pps%forc_hgt_q_pft
plandunit => clm3%g%l%c%p%landunit
frac_veg_nosno => clm3%g%l%c%p%pps%frac_veg_nosno
thm => clm3%g%l%c%p%pes%thm
pgridcell => clm3%g%l%c%p%gridcell
pcolumn => clm3%g%l%c%p%column
pwtgcell => clm3%g%l%c%p%wtgcell
! Assign local pointers to derived type members (ecophysiological)
z0mr => pftcon%z0mr
displar => pftcon%displar
do j = -nlevsno+1, nlevgrnd
do fc = 1,num_nolakec
c = filter_nolakec(fc)
tssbef(c,j) = t_soisno(c,j)
end do
end do
do fc = 1,num_nolakec
c = filter_nolakec(fc)
l = clandunit(c)
g = cgridcell(c)
if (ctype(c) == icol_road_perv) then
hr_road_perv = 0._r8
end if
! begin calculations that relate only to the column level
! Ground and soil temperatures from previous time step
t_grnd(c) = t_soisno(c,snl(c)+1)
! Saturated vapor pressure, specific humidity and their derivatives
! at ground surface
qred = 1._r8
if (ityplun(l)/=istwet .AND. ityplun(l)/=istice) then
#ifndef CROP
if (ityplun(l) == istsoil) then
#else
if (ityplun(l) == istsoil .or. ityplun(l) == istcrop) then
#endif
wx = (h2osoi_liq(c,1)/denh2o+h2osoi_ice(c,1)/denice)/dz(c,1)
fac = min(1._r8, wx/watsat(c,1))
fac = max( fac, 0.01_r8 )
psit = -sucsat(c,1) * fac ** (-bsw(c,1))
psit = max(smpmin(c), psit)
hr = exp(psit/roverg/t_grnd(c))
qred = (1.-frac_sno(c))*hr + frac_sno(c)
!! Lee and Pielke 1992 beta, added by K.Sakaguchi
if (wx < watfc(c,1) ) then !when water content of ths top layer is less than that at F.C.
fac_fc = min(1._r8, wx/watfc(c,1)) !eqn5.66 but divided by theta at field capacity
fac_fc = max( fac_fc, 0.01_r8 )
! modifiy soil beta by snow cover. soilbeta for snow surface is one
soilbeta(c) = (1._r8-frac_sno(c))*0.25_r8*(1._r8 - cos(SHR_CONST_PI*fac_fc))**2._r8 &
+ frac_sno(c)
else !when water content of ths top layer is more than that at F.C.
soilbeta(c) = 1._r8
end if
soilalpha(c) = qred
! Pervious road depends on water in total soil column
else if (ctype(c) == icol_road_perv) then
do j = 1, nlevsoi
if (t_soisno(c,j) >= tfrz) then
vol_ice = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice))
eff_porosity = watsat(c,j)-vol_ice
vol_liq = min(eff_porosity, h2osoi_liq(c,j)/(dz(c,j)*denh2o))
fac = min( max(vol_liq-watdry(c,j),0._r8) / (watopt(c,j)-watdry(c,j)), 1._r8 )
else
fac = 0._r8
end if
rootr_road_perv(c,j) = rootfr_road_perv(c,j)*fac
hr_road_perv = hr_road_perv + rootr_road_perv(c,j)
end do
! Allows for sublimation of snow or dew on snow
qred = (1.-frac_sno(c))*hr_road_perv + frac_sno(c)
! Normalize root resistances to get layer contribution to total ET
if (hr_road_perv .gt. 0._r8) then
do j = 1, nlevsoi
rootr_road_perv(c,j) = rootr_road_perv(c,j)/hr_road_perv
end do
end if
soilalpha_u(c) = qred
soilbeta(c) = 0._r8
else if (ctype(c) == icol_sunwall .or. ctype(c) == icol_shadewall) then
qred = 0._r8
soilbeta(c) = 0._r8
soilalpha_u(c) = spval
else if (ctype(c) == icol_roof .or. ctype(c) == icol_road_imperv) then
qred = 1._r8
soilbeta(c) = 0._r8
soilalpha_u(c) = spval
end if
else
soilalpha(c) = spval
soilbeta(c) = 1._r8
end if
call QSat(t_grnd(c), forc_pbot(g), eg, degdT, qsatg, qsatgdT)
qg(c) = qred*qsatg
dqgdT(c) = qred*qsatgdT
if (qsatg > forc_q(g) .and. forc_q(g) > qred*qsatg) then
qg(c) = forc_q(g)
dqgdT(c) = 0._r8
end if
! Ground emissivity - only calculate for non-urban landunits
! Urban emissivities are currently read in from data file
if (ityplun(l) /= isturb) then
if (ityplun(l)==istice) then
emg(c) = 0.97_r8
else
emg(c) = (1._r8-frac_sno(c))*0.96_r8 + frac_sno(c)*0.97_r8
end if
end if
! Latent heat. We arbitrarily assume that the sublimation occurs
! only as h2osoi_liq = 0
htvp(c) = hvap
if (h2osoi_liq(c,snl(c)+1) <= 0._r8 .and. h2osoi_ice(c,snl(c)+1) > 0._r8) htvp(c) = hsub
! Switch between vaporization and sublimation causes rapid solution
! separation in perturbation growth test
#if (defined PERGRO)
htvp(c) = hvap
#endif
! Ground roughness lengths over non-lake columns (includes bare ground, ground
! underneath canopy, wetlands, etc.)
if (frac_sno(c) > 0._r8) then
z0mg(c) = zsno
else
z0mg(c) = zlnd
end if
z0hg(c) = z0mg(c) ! initial set only
z0qg(c) = z0mg(c) ! initial set only
! Potential, virtual potential temperature, and wind speed at the
! reference height
beta(c) = 1._r8
zii(c) = 1000._r8
thv(c) = forc_th(g)*(1._r8+0.61_r8*forc_q(g))
end do ! (end of columns loop)
! Initialization
do fp = 1,num_nolakep
p = filter_nolakep(fp)
! Initial set (needed for history tape fields)
eflx_sh_tot(p) = 0._r8
l = plandunit(p)
if (ityplun(l) == isturb) then
eflx_sh_tot_u(p) = 0._r8
#ifndef CROP
else if (ityplun(l) == istsoil) then
#else
else if (ityplun(l) == istsoil .or. ityplun(l) == istcrop) then
#endif
eflx_sh_tot_r(p) = 0._r8
end if
eflx_lh_tot(p) = 0._r8
if (ityplun(l) == isturb) then
eflx_lh_tot_u(p) = 0._r8
#ifndef CROP
else if (ityplun(l) == istsoil) then
#else
else if (ityplun(l) == istsoil .or. ityplun(l) == istcrop) then
#endif
eflx_lh_tot_r(p) = 0._r8
end if
eflx_sh_veg(p) = 0._r8
qflx_evap_tot(p) = 0._r8
qflx_evap_veg(p) = 0._r8
qflx_tran_veg(p) = 0._r8
! Initial set for calculation
cgrnd(p) = 0._r8
cgrnds(p) = 0._r8
cgrndl(p) = 0._r8
! Vegetation Emissivity
avmuir = 1._r8
emv(p) = 1._r8-exp(-(elai(p)+esai(p))/avmuir)
! Roughness lengths over vegetation
z0m(p) = z0mr(ivt(p)) * htop(p)
displa(p) = displar(ivt(p)) * htop(p)
z0mv(p) = z0m(p)
z0hv(p) = z0mv(p)
z0qv(p) = z0mv(p)
end do
! Make forcing height a pft-level quantity that is the atmospheric forcing
! height plus each pft's z0m+displa
do pi = 1,max_pft_per_gcell
do g = lbg, ubg
if (pi <= npfts(g)) then
p = pfti(g) + pi - 1
if (pwtgcell(p) > 0._r8) then
l = plandunit(p)
c = pcolumn(p)
#ifndef CROP
if (ityplun(l) == istsoil) then
#else
if (ityplun(l) == istsoil .or. ityplun(l) == istcrop) then
#endif
if (frac_veg_nosno(p) == 0) then
forc_hgt_u_pft(p) = forc_hgt_u(g) + z0mg(c) + displa(p)
forc_hgt_t_pft(p) = forc_hgt_t(g) + z0mg(c) + displa(p)
forc_hgt_q_pft(p) = forc_hgt_q(g) + z0mg(c) + displa(p)
else
forc_hgt_u_pft(p) = forc_hgt_u(g) + z0m(p) + displa(p)
forc_hgt_t_pft(p) = forc_hgt_t(g) + z0m(p) + displa(p)
forc_hgt_q_pft(p) = forc_hgt_q(g) + z0m(p) + displa(p)
end if
else if (ityplun(l) == istice .or. ityplun(l) == istwet) then
forc_hgt_u_pft(p) = forc_hgt_u(g) + z0mg(c)
forc_hgt_t_pft(p) = forc_hgt_t(g) + z0mg(c)
forc_hgt_q_pft(p) = forc_hgt_q(g) + z0mg(c)
else if (ityplun(l) == istdlak) then
! Should change the roughness lengths to shared constants
if (t_grnd(c) >= tfrz) then
forc_hgt_u_pft(p) = forc_hgt_u(g) + 0.01_r8
forc_hgt_t_pft(p) = forc_hgt_t(g) + 0.01_r8
forc_hgt_q_pft(p) = forc_hgt_q(g) + 0.01_r8
else
forc_hgt_u_pft(p) = forc_hgt_u(g) + 0.04_r8
forc_hgt_t_pft(p) = forc_hgt_t(g) + 0.04_r8
forc_hgt_q_pft(p) = forc_hgt_q(g) + 0.04_r8
end if
else if (ityplun(l) == isturb) then
forc_hgt_u_pft(p) = forc_hgt_u(g) + z_0_town(l) + z_d_town(l)
forc_hgt_t_pft(p) = forc_hgt_t(g) + z_0_town(l) + z_d_town(l)
forc_hgt_q_pft(p) = forc_hgt_q(g) + z_0_town(l) + z_d_town(l)
end if
end if
end if
end do
end do
do fp = 1,num_nolakep
p = filter_nolakep(fp)
g = pgridcell(p)
thm(p) = forc_t(g) + 0.0098_r8*forc_hgt_t_pft(p)
end do
end subroutine Biogeophysics1
end module Biogeophysics1Mod
!=================================================================================================
module Biogeophysics2Mod 1,2
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: Biogeophysics2Mod
!
! !DESCRIPTION:
! Performs the calculation of soil/snow and ground temperatures
! and updates surface fluxes based on the new ground temperature.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use globals, only: nstep
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: Biogeophysics2 ! Calculate soil/snow and ground temperatures
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: Biogeophysics2
!
! !INTERFACE:
subroutine Biogeophysics2 (lbl, ubl, lbc, ubc, lbp, ubp, & 1,9
num_urbanl, filter_urbanl, num_nolakec, filter_nolakec, &
num_nolakep, filter_nolakep)
!
! !DESCRIPTION:
! This is the main subroutine to execute the calculation of soil/snow and
! ground temperatures and update surface fluxes based on the new ground
! temperature
!
! Calling sequence is:
! Biogeophysics2: surface biogeophysics driver
! -> SoilTemperature: soil/snow and ground temperatures
! -> SoilTermProp thermal conductivities and heat capacities
! -> Tridiagonal tridiagonal matrix solution
! -> PhaseChange phase change of liquid/ice contents
!
! (1) Snow and soil temperatures
! o The volumetric heat capacity is calculated as a linear combination
! in terms of the volumetric fraction of the constituent phases.
! o The thermal conductivity of soil is computed from
! the algorithm of Johansen (as reported by Farouki 1981), and the
! conductivity of snow is from the formulation used in
! SNTHERM (Jordan 1991).
! o Boundary conditions:
! F = Rnet - Hg - LEg (top), F= 0 (base of the soil column).
! o Soil / snow temperature is predicted from heat conduction
! in 10 soil layers and up to 5 snow layers.
! The thermal conductivities at the interfaces between two
! neighboring layers (j, j+1) are derived from an assumption that
! the flux across the interface is equal to that from the node j
! to the interface and the flux from the interface to the node j+1.
! The equation is solved using the Crank-Nicholson method and
! results in a tridiagonal system equation.
!
! (2) Phase change (see PhaseChange.F90)
!
! !USES:
use clmtype
use clm_varcon , only : hvap, cpair, grav, vkc, tfrz, sb, &
isturb, icol_roof, icol_sunwall, icol_shadewall, istsoil
#ifdef CROP
use clm_varcon , only : istcrop
#endif
use clm_varpar , only : nlevsno, nlevgrnd, max_pft_per_col
use SoilTemperatureMod, only : SoilTemperature
use subgridAveMod , only : p2c
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbp, ubp ! pft bounds
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: lbl, ubl ! landunit bounds
integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points
integer, intent(in) :: num_urbanl ! number of urban landunits in clump
integer, intent(in) :: filter_urbanl(ubl-lbl+1) ! urban landunit filter
integer, intent(in) :: num_nolakep ! number of column non-lake points in pft filter
integer, intent(in) :: filter_nolakep(ubp-lbp+1) ! pft filter for non-lake points
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! Migrated to clm2.0 by Keith Oleson and Mariana Vertenstein
! Migrated to clm2.1 new data structures by Peter Thornton and M. Vertenstein
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: ctype(:) ! column type
integer , pointer :: ltype(:) ! landunit type
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: plandunit(:) ! pft's landunit index
integer , pointer :: pgridcell(:) ! pft's gridcell index
real(r8), pointer :: pwtgcell(:) ! pft's weight relative to corresponding column
integer , pointer :: npfts(:) ! column's number of pfts
integer , pointer :: pfti(:) ! column's beginning pft index
integer , pointer :: snl(:) ! number of snow layers
logical , pointer :: do_capsnow(:) ! true => do snow capping
real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2)
real(r8), pointer :: emg(:) ! ground emissivity
real(r8), pointer :: htvp(:) ! latent heat of vapor of water (or sublimation) [j/kg]
real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin)
integer , pointer :: frac_veg_nosno(:) ! fraction of vegetation not covered by snow (0 OR 1 now) [-]
real(r8), pointer :: cgrnds(:) ! deriv, of soil sensible heat flux wrt soil temp [w/m2/k]
real(r8), pointer :: cgrndl(:) ! deriv of soil latent heat flux wrt soil temp [w/m**2/k]
real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2)
real(r8), pointer :: dlrad(:) ! downward longwave radiation below the canopy [W/m2]
real(r8), pointer :: ulrad(:) ! upward longwave radiation above the canopy [W/m2]
real(r8), pointer :: eflx_sh_veg(:) ! sensible heat flux from leaves (W/m**2) [+ to atm]
real(r8), pointer :: qflx_evap_veg(:) ! vegetation evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_tran_veg(:) ! vegetation transpiration (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_evap_can(:) ! evaporation from leaves and stems (mm H2O/s) (+ = to atm)
real(r8), pointer :: wtcol(:) ! pft weight relative to column
real(r8), pointer :: tssbef(:,:) ! soil/snow temperature before update
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin)
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2) (new)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) (new)
real(r8), pointer :: eflx_building_heat(:) ! heat flux from urban building interior to walls, roof
real(r8), pointer :: eflx_traffic_pft(:) ! traffic sensible heat flux (W/m**2)
real(r8), pointer :: eflx_wasteheat_pft(:) ! sensible heat flux from urban heating/cooling sources of waste heat (W/m**2)
real(r8), pointer :: eflx_heat_from_ac_pft(:) ! sensible heat flux put back into canyon due to removal by AC (W/m**2)
real(r8), pointer :: canyon_hwr(:) ! ratio of building height to street width (-)
! local pointers to implicit inout arguments
!
real(r8), pointer :: eflx_sh_grnd(:) ! sensible heat flux from ground (W/m**2) [+ to atm]
real(r8), pointer :: qflx_evap_soi(:) ! soil evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_snwcp_liq(:) ! excess rainfall due to snow capping (mm H2O /s)
real(r8), pointer :: qflx_snwcp_ice(:) ! excess snowfall due to snow capping (mm H2O /s)
!
! local pointers to implicit out arguments
!
real(r8), pointer :: dt_grnd(:) ! change in t_grnd, last iteration (Kelvin)
real(r8), pointer :: eflx_soil_grnd(:) ! soil heat flux (W/m**2) [+ = into soil]
real(r8), pointer :: eflx_soil_grnd_u(:)! urban soil heat flux (W/m**2) [+ = into soil]
real(r8), pointer :: eflx_soil_grnd_r(:)! rural soil heat flux (W/m**2) [+ = into soil]
real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_tot_u(:) ! urban total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_sh_tot_r(:) ! rural total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
real(r8), pointer :: eflx_lh_tot(:) ! total latent heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_tot_u(:) ! urban total latent heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_tot_r(:) ! rural total latent heat flux (W/m**2) [+ to atm]
real(r8), pointer :: qflx_evap_grnd(:) ! ground surface evaporation rate (mm H2O/s) [+]
real(r8), pointer :: qflx_sub_snow(:) ! sublimation rate from snow pack (mm H2O /s) [+]
real(r8), pointer :: qflx_dew_snow(:) ! surface dew added to snow pack (mm H2O /s) [+]
real(r8), pointer :: qflx_dew_grnd(:) ! ground surface dew formation (mm H2O /s) [+]
real(r8), pointer :: eflx_lwrad_out(:) ! emitted infrared (longwave) radiation (W/m**2)
real(r8), pointer :: eflx_lwrad_net(:) ! net infrared (longwave) rad (W/m**2) [+ = to atm]
real(r8), pointer :: eflx_lwrad_net_u(:) ! urban net infrared (longwave) rad (W/m**2) [+ = to atm]
real(r8), pointer :: eflx_lwrad_net_r(:) ! rural net infrared (longwave) rad (W/m**2) [+ = to atm]
real(r8), pointer :: eflx_lh_vege(:) ! veg evaporation heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_vegt(:) ! veg transpiration heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_grnd(:) ! ground evaporation heat flux (W/m**2) [+ to atm]
real(r8), pointer :: errsoi_pft(:) ! pft-level soil/lake energy conservation error (W/m**2)
real(r8), pointer :: errsoi_col(:) ! column-level soil/lake energy conservation error (W/m**2)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer :: p,c,g,j,pi,l ! indices
integer :: fc,fp ! lake filtered column and pft indices
real(r8) :: egsmax(lbc:ubc) ! max. evaporation which soil can provide at one time step
real(r8) :: egirat(lbc:ubc) ! ratio of topsoil_evap_tot : egsmax
real(r8) :: tinc(lbc:ubc) ! temperature difference of two time step
real(r8) :: xmf(lbc:ubc) ! total latent heat of phase change of ground water
real(r8) :: sumwt(lbc:ubc) ! temporary
real(r8) :: evaprat(lbp:ubp) ! ratio of qflx_evap_soi/topsoil_evap_tot
real(r8) :: save_qflx_evap_soi ! temporary storage for qflx_evap_soi
real(r8) :: topsoil_evap_tot(lbc:ubc) ! column-level total evaporation from top soil layer
real(r8) :: fact(lbc:ubc, -nlevsno+1:nlevgrnd) ! used in computing tridiagonal matrix
real(r8) :: eflx_lwrad_del(lbp:ubp) ! update due to eflx_lwrad
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (gridcell-level)
forc_lwrad => clm_a2l%forc_lwrad
! Assign local pointers to derived subtypes components (landunit-level)
ltype => clm3%g%l%itype
canyon_hwr => clm3%g%l%canyon_hwr
! Assign local pointers to derived subtypes components (column-level)
ctype => clm3%g%l%c%itype
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
snl => clm3%g%l%c%cps%snl
do_capsnow => clm3%g%l%c%cps%do_capsnow
htvp => clm3%g%l%c%cps%htvp
emg => clm3%g%l%c%cps%emg
t_grnd => clm3%g%l%c%ces%t_grnd
dt_grnd => clm3%g%l%c%ces%dt_grnd
t_soisno => clm3%g%l%c%ces%t_soisno
tssbef => clm3%g%l%c%ces%tssbef
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
errsoi_col => clm3%g%l%c%cebal%errsoi
eflx_building_heat => clm3%g%l%c%cef%eflx_building_heat
! Assign local pointers to derived subtypes components (pft-level)
pcolumn => clm3%g%l%c%p%column
plandunit => clm3%g%l%c%p%landunit
pgridcell => clm3%g%l%c%p%gridcell
pwtgcell => clm3%g%l%c%p%wtgcell
frac_veg_nosno => clm3%g%l%c%p%pps%frac_veg_nosno
sabg => clm3%g%l%c%p%pef%sabg
dlrad => clm3%g%l%c%p%pef%dlrad
ulrad => clm3%g%l%c%p%pef%ulrad
eflx_sh_grnd => clm3%g%l%c%p%pef%eflx_sh_grnd
eflx_sh_veg => clm3%g%l%c%p%pef%eflx_sh_veg
qflx_evap_soi => clm3%g%l%c%p%pwf%qflx_evap_soi
qflx_evap_veg => clm3%g%l%c%p%pwf%qflx_evap_veg
qflx_tran_veg => clm3%g%l%c%p%pwf%qflx_tran_veg
qflx_evap_can => clm3%g%l%c%p%pwf%qflx_evap_can
qflx_snwcp_liq => clm3%g%l%c%p%pwf%qflx_snwcp_liq
qflx_snwcp_ice => clm3%g%l%c%p%pwf%qflx_snwcp_ice
qflx_evap_tot => clm3%g%l%c%p%pwf%qflx_evap_tot
qflx_evap_grnd => clm3%g%l%c%p%pwf%qflx_evap_grnd
qflx_sub_snow => clm3%g%l%c%p%pwf%qflx_sub_snow
qflx_dew_snow => clm3%g%l%c%p%pwf%qflx_dew_snow
qflx_dew_grnd => clm3%g%l%c%p%pwf%qflx_dew_grnd
eflx_soil_grnd => clm3%g%l%c%p%pef%eflx_soil_grnd
eflx_soil_grnd_u => clm3%g%l%c%p%pef%eflx_soil_grnd_u
eflx_soil_grnd_r => clm3%g%l%c%p%pef%eflx_soil_grnd_r
eflx_sh_tot => clm3%g%l%c%p%pef%eflx_sh_tot
eflx_sh_tot_u => clm3%g%l%c%p%pef%eflx_sh_tot_u
eflx_sh_tot_r => clm3%g%l%c%p%pef%eflx_sh_tot_r
eflx_lh_tot => clm3%g%l%c%p%pef%eflx_lh_tot
eflx_lh_tot_u => clm3%g%l%c%p%pef%eflx_lh_tot_u
eflx_lh_tot_r => clm3%g%l%c%p%pef%eflx_lh_tot_r
eflx_lwrad_out => clm3%g%l%c%p%pef%eflx_lwrad_out
eflx_lwrad_net => clm3%g%l%c%p%pef%eflx_lwrad_net
eflx_lwrad_net_u => clm3%g%l%c%p%pef%eflx_lwrad_net_u
eflx_lwrad_net_r => clm3%g%l%c%p%pef%eflx_lwrad_net_r
eflx_lh_vege => clm3%g%l%c%p%pef%eflx_lh_vege
eflx_lh_vegt => clm3%g%l%c%p%pef%eflx_lh_vegt
eflx_lh_grnd => clm3%g%l%c%p%pef%eflx_lh_grnd
cgrnds => clm3%g%l%c%p%pef%cgrnds
cgrndl => clm3%g%l%c%p%pef%cgrndl
eflx_sh_grnd => clm3%g%l%c%p%pef%eflx_sh_grnd
qflx_evap_soi => clm3%g%l%c%p%pwf%qflx_evap_soi
errsoi_pft => clm3%g%l%c%p%pebal%errsoi
wtcol => clm3%g%l%c%p%wtcol
eflx_wasteheat_pft => clm3%g%l%c%p%pef%eflx_wasteheat_pft
eflx_heat_from_ac_pft => clm3%g%l%c%p%pef%eflx_heat_from_ac_pft
eflx_traffic_pft => clm3%g%l%c%p%pef%eflx_traffic_pft
! Determine soil temperatures including surface soil temperature
call SoilTemperature(lbl, ubl, lbc, ubc, num_urbanl, filter_urbanl, &
num_nolakec, filter_nolakec, xmf , fact)
do fc = 1,num_nolakec
c = filter_nolakec(fc)
j = snl(c)+1
! Calculate difference in soil temperature from last time step, for
! flux corrections
tinc(c) = t_soisno(c,j) - tssbef(c,j)
! Determine ratio of topsoil_evap_tot
egsmax(c) = (h2osoi_ice(c,j)+h2osoi_liq(c,j)) / dtime
! added to trap very small negative soil water,ice
if (egsmax(c) < 0._r8) then
egsmax(c) = 0._r8
end if
end do
! A preliminary pft loop to determine if corrections are required for
! excess evaporation from the top soil layer... Includes new logic
! to distribute the corrections between pfts on the basis of their
! evaporative demands.
! egirat holds the ratio of demand to availability if demand is
! greater than availability, or 1.0 otherwise.
! Correct fluxes to present soil temperature
do fp = 1,num_nolakep
p = filter_nolakep(fp)
c = pcolumn(p)
eflx_sh_grnd(p) = eflx_sh_grnd(p) + tinc(c)*cgrnds(p)
qflx_evap_soi(p) = qflx_evap_soi(p) + tinc(c)*cgrndl(p)
end do
! Set the column-average qflx_evap_soi as the weighted average over all pfts
! but only count the pfts that are evaporating
do fc = 1,num_nolakec
c = filter_nolakec(fc)
topsoil_evap_tot(c) = 0._r8
sumwt(c) = 0._r8
end do
do pi = 1,max_pft_per_col
do fc = 1,num_nolakec
c = filter_nolakec(fc)
if ( pi <= npfts(c) ) then
p = pfti(c) + pi - 1
if (pwtgcell(p)>0._r8) then
topsoil_evap_tot(c) = topsoil_evap_tot(c) + qflx_evap_soi(p) * wtcol(p)
end if
end if
end do
end do
! Calculate ratio for rescaling pft-level fluxes to meet availability
do fc = 1,num_nolakec
c = filter_nolakec(fc)
if (topsoil_evap_tot(c) > egsmax(c)) then
egirat(c) = (egsmax(c)/topsoil_evap_tot(c))
else
egirat(c) = 1.0_r8
end if
end do
do fp = 1,num_nolakep
p = filter_nolakep(fp)
c = pcolumn(p)
l = plandunit(p)
g = pgridcell(p)
j = snl(c)+1
! Correct soil fluxes for possible evaporation in excess of top layer water
! excess energy is added to the sensible heat flux from soil
if (egirat(c) < 1.0_r8) then
save_qflx_evap_soi = qflx_evap_soi(p)
qflx_evap_soi(p) = qflx_evap_soi(p) * egirat(c)
eflx_sh_grnd(p) = eflx_sh_grnd(p) + (save_qflx_evap_soi - qflx_evap_soi(p))*htvp(c)
end if
! Ground heat flux
if (ltype(l) /= isturb) then
eflx_soil_grnd(p) = sabg(p) + dlrad(p) &
+ (1-frac_veg_nosno(p))*emg(c)*forc_lwrad(g) &
- emg(c)*sb*tssbef(c,j)**3*(tssbef(c,j) + 4._r8*tinc(c)) &
- (eflx_sh_grnd(p) + qflx_evap_soi(p)*htvp(c))
#ifndef CROP
if (ltype(l) == istsoil) then
#else
if (ltype(l) == istsoil .or. ltype(l) == istcrop) then
#endif
eflx_soil_grnd_r(p) = eflx_soil_grnd(p)
end if
else
! For all urban columns we use the net longwave radiation (eflx_lwrad_net) since
! the term (emg*sb*tssbef(snl+1)**4) is not the upward longwave flux because of
! interactions between urban columns.
eflx_lwrad_del(p) = 4._r8*emg(c)*sb*tssbef(c,j)**3*tinc(c)
! Include transpiration term because needed for pervious road
! and wasteheat and traffic flux
eflx_soil_grnd(p) = sabg(p) + dlrad(p) &
- eflx_lwrad_net(p) - eflx_lwrad_del(p) &
- (eflx_sh_grnd(p) + qflx_evap_soi(p)*htvp(c) + qflx_tran_veg(p)*hvap) &
+ eflx_wasteheat_pft(p) + eflx_heat_from_ac_pft(p) + eflx_traffic_pft(p)
eflx_soil_grnd_u(p) = eflx_soil_grnd(p)
end if
! Total fluxes (vegetation + ground)
eflx_sh_tot(p) = eflx_sh_veg(p) + eflx_sh_grnd(p)
qflx_evap_tot(p) = qflx_evap_veg(p) + qflx_evap_soi(p)
eflx_lh_tot(p)= hvap*qflx_evap_veg(p) + htvp(c)*qflx_evap_soi(p)
#ifndef CROP
if (ltype(l) == istsoil) then
#else
if (ltype(l) == istsoil .or. ltype(l) == istcrop) then
#endif
eflx_lh_tot_r(p)= eflx_lh_tot(p)
eflx_sh_tot_r(p)= eflx_sh_tot(p)
else if (ltype(l) == isturb) then
eflx_lh_tot_u(p)= eflx_lh_tot(p)
eflx_sh_tot_u(p)= eflx_sh_tot(p)
end if
! Assign ground evaporation to sublimation from soil ice or to dew
! on snow or ground
qflx_evap_grnd(p) = 0._r8
qflx_sub_snow(p) = 0._r8
qflx_dew_snow(p) = 0._r8
qflx_dew_grnd(p) = 0._r8
if (qflx_evap_soi(p) >= 0._r8) then
! for evaporation partitioning between liquid evap and ice sublimation,
! use the ratio of liquid to (liquid+ice) in the top layer to determine split
if ((h2osoi_liq(c,j)+h2osoi_ice(c,j)) > 0.) then
qflx_evap_grnd(p) = max(qflx_evap_soi(p)*(h2osoi_liq(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))), 0._r8)
else
qflx_evap_grnd(p) = 0.
end if
qflx_sub_snow(p) = qflx_evap_soi(p) - qflx_evap_grnd(p)
else
if (t_grnd(c) < tfrz) then
qflx_dew_snow(p) = abs(qflx_evap_soi(p))
else
qflx_dew_grnd(p) = abs(qflx_evap_soi(p))
end if
end if
! Update the pft-level qflx_snwcp
! This was moved in from Hydrology2 to keep all pft-level
! calculations out of Hydrology2
if (snl(c) < 0 .and. do_capsnow(c)) then
qflx_snwcp_liq(p) = qflx_snwcp_liq(p) + qflx_dew_grnd(p)
qflx_snwcp_ice(p) = qflx_snwcp_ice(p) + qflx_dew_snow(p)
end if
! Variables needed by history tape
qflx_evap_can(p) = qflx_evap_veg(p) - qflx_tran_veg(p)
eflx_lh_vege(p) = (qflx_evap_veg(p) - qflx_tran_veg(p)) * hvap
eflx_lh_vegt(p) = qflx_tran_veg(p) * hvap
eflx_lh_grnd(p) = qflx_evap_soi(p) * htvp(c)
end do
! Soil Energy balance check
do fp = 1,num_nolakep
p = filter_nolakep(fp)
c = pcolumn(p)
errsoi_pft(p) = eflx_soil_grnd(p) - xmf(c)
! For urban sunwall, shadewall, and roof columns, the "soil" energy balance check
! must include the heat flux from the interior of the building.
if (ctype(c)==icol_sunwall .or. ctype(c)==icol_shadewall .or. ctype(c)==icol_roof) then
errsoi_pft(p) = errsoi_pft(p) + eflx_building_heat(c)
end if
end do
do j = -nlevsno+1,nlevgrnd
do fp = 1,num_nolakep
p = filter_nolakep(fp)
c = pcolumn(p)
if (j >= snl(c)+1) then
errsoi_pft(p) = errsoi_pft(p) - (t_soisno(c,j)-tssbef(c,j))/fact(c,j)
end if
end do
end do
! Outgoing long-wave radiation from vegetation + ground
! For conservation we put the increase of ground longwave to outgoing
! For urban pfts, ulrad=0 and (1-fracveg_nosno)=1, and eflx_lwrad_out and eflx_lwrad_net
! are calculated in UrbanRadiation. The increase of ground longwave is added directly
! to the outgoing longwave and the net longwave.
do fp = 1,num_nolakep
p = filter_nolakep(fp)
c = pcolumn(p)
l = plandunit(p)
g = pgridcell(p)
j = snl(c)+1
if (ltype(l) /= isturb) then
eflx_lwrad_out(p) = ulrad(p) &
+ (1-frac_veg_nosno(p))*(1.-emg(c))*forc_lwrad(g) &
+ (1-frac_veg_nosno(p))*emg(c)*sb*tssbef(c,j)**4 &
+ 4.*emg(c)*sb*tssbef(c,j)**3*tinc(c)
eflx_lwrad_net(p) = eflx_lwrad_out(p) - forc_lwrad(g)
#ifndef CROP
if (ltype(l) == istsoil) then
#else
if (ltype(l) == istsoil .or. ltype(l) == istcrop) then
#endif
eflx_lwrad_net_r(p) = eflx_lwrad_out(p) - forc_lwrad(g)
end if
else
eflx_lwrad_out(p) = eflx_lwrad_out(p) + eflx_lwrad_del(p)
eflx_lwrad_net(p) = eflx_lwrad_net(p) + eflx_lwrad_del(p)
eflx_lwrad_net_u(p) = eflx_lwrad_net_u(p) + eflx_lwrad_del(p)
end if
end do
! lake balance for errsoi is not over pft
! therefore obtain column-level radiative temperature
call p2c(num_nolakec, filter_nolakec, errsoi_pft, errsoi_col)
end subroutine Biogeophysics2
end module Biogeophysics2Mod
!=================================================================================================
module BiogeophysicsLakeMod 1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: BiogeophysicsLakeMod
!
! !DESCRIPTION:
! Calculates lake temperatures and surface fluxes.
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: BiogeophysicsLake
! !REVISION HISTORY:
! Created by Mariana Vertenstein
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: BiogeophysicsLake
!
! !INTERFACE:
subroutine BiogeophysicsLake(lbc, ubc, lbp, ubp, num_lakec, filter_lakec, & 1,15
num_lakep, filter_lakep)
!
! !DESCRIPTION:
! Calculates lake temperatures and surface fluxes.
! Lake temperatures are determined from a one-dimensional thermal
! stratification model based on eddy diffusion concepts to
! represent vertical mixing of heat.
!
! d ts d d ts 1 ds
! ---- = -- [(km + ke) ----] + -- --
! dt dz dz cw dz
!
! where: ts = temperature (kelvin)
! t = time (s)
! z = depth (m)
! km = molecular diffusion coefficient (m**2/s)
! ke = eddy diffusion coefficient (m**2/s)
! cw = heat capacity (j/m**3/kelvin)
! s = heat source term (w/m**2)
!
! There are two types of lakes:
! Deep lakes are 50 m.
! Shallow lakes are 10 m deep.
!
! For unfrozen deep lakes: ke > 0 and convective mixing
! For unfrozen shallow lakes: ke = 0 and no convective mixing
!
! Use the Crank-Nicholson method to set up tridiagonal system of equations to
! solve for ts at time n+1, where the temperature equation for layer i is
! r_i = a_i [ts_i-1] n+1 + b_i [ts_i] n+1 + c_i [ts_i+1] n+1
!
! The solution conserves energy as:
!
! cw*([ts( 1)] n+1 - [ts( 1)] n)*dz( 1)/dt + ... +
! cw*([ts(nlevlak)] n+1 - [ts(nlevlak)] n)*dz(nlevlak)/dt = fin
!
! where:
! [ts] n = old temperature (kelvin)
! [ts] n+1 = new temperature (kelvin)
! fin = heat flux into lake (w/m**2)
! = beta*sabg + forc_lwrad - eflx_lwrad_out - eflx_sh_tot - eflx_lh_tot
! - hm + phi(1) + ... + phi(nlevlak)
!
! WARNING: This subroutine assumes lake columns have one and only one pft.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clmtype
use clm_varpar , only : nlevlak
use clm_varcon , only : hvap, hsub, hfus, cpair, cpliq, cpice, tkwat, tkice, &
sb, vkc, grav, denh2o, tfrz, spval
use QSatMod , only : QSat
use FrictionVelocityMod, only : FrictionVelocity, MoninObukIni
use TridiagonalMod , only : Tridiagonal
use globals , only : dtime
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column-index bounds
integer, intent(in) :: lbp, ubp ! pft-index bounds
integer, intent(in) :: num_lakec ! number of column non-lake points in column filter
integer, intent(in) :: filter_lakec(ubc-lbc+1) ! column filter for non-lake points
integer, intent(in) :: num_lakep ! number of column non-lake points in pft filter
integer, intent(in) :: filter_lakep(ubp-lbp+1) ! pft filter for non-lake points
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! Author: Gordon Bonan
! 15 September 1999: Yongjiu Dai; Initial code
! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision
! Migrated to clm2.1 new data structures by Peter Thornton and M. Vertenstein
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: pgridcell(:) ! pft's gridcell index
integer , pointer :: cgridcell(:) ! column's gridcell index
real(r8), pointer :: forc_t(:) ! atmospheric temperature (Kelvin)
real(r8), pointer :: forc_pbot(:) ! atmospheric pressure (Pa)
real(r8), pointer :: forc_hgt_u_pft(:) ! observational height of wind at pft level [m]
real(r8), pointer :: forc_hgt_t_pft(:) ! observational height of temperature at pft level [m]
real(r8), pointer :: forc_hgt_q_pft(:) ! observational height of specific humidity at pft level [m]
real(r8), pointer :: forc_th(:) ! atmospheric potential temperature (Kelvin)
real(r8), pointer :: forc_q(:) ! atmospheric specific humidity (kg/kg)
real(r8), pointer :: forc_u(:) ! atmospheric wind speed in east direction (m/s)
real(r8), pointer :: forc_v(:) ! atmospheric wind speed in north direction (m/s)
real(r8), pointer :: forc_lwrad(:) ! downward infrared (longwave) radiation (W/m**2)
real(r8), pointer :: forc_rho(:) ! density (kg/m**3)
real(r8), pointer :: forc_snow(:) ! snow rate [mm/s]
real(r8), pointer :: forc_rain(:) ! rain rate [mm/s]
real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin)
real(r8), pointer :: hc_soisno(:) ! soil plus snow plus lake heat content (MJ/m2)
real(r8), pointer :: h2osno(:) ! snow water (mm H2O)
real(r8), pointer :: snowdp(:) ! snow height (m)
real(r8), pointer :: sabg(:) ! solar radiation absorbed by ground (W/m**2)
real(r8), pointer :: lat(:) ! latitude (radians)
real(r8), pointer :: dz(:,:) ! layer thickness (m)
real(r8), pointer :: z(:,:) ! layer depth (m)
!
! local pointers to implicit out arguments
!
real(r8), pointer :: qflx_prec_grnd(:) ! water onto ground including canopy runoff [kg/(m2 s)]
real(r8), pointer :: qflx_evap_soi(:) ! soil evaporation (mm H2O/s) (+ = to atm)
real(r8), pointer :: qflx_evap_tot(:) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
real(r8), pointer :: qflx_snwcp_liq(:) ! excess rainfall due to snow capping (mm H2O /s) [+]`
real(r8), pointer :: qflx_snwcp_ice(:) ! excess snowfall due to snow capping (mm H2O /s) [+]`
real(r8), pointer :: eflx_sh_grnd(:) ! sensible heat flux from ground (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lwrad_out(:) ! emitted infrared (longwave) radiation (W/m**2)
real(r8), pointer :: eflx_lwrad_net(:) ! net infrared (longwave) rad (W/m**2) [+ = to atm]
real(r8), pointer :: eflx_soil_grnd(:) ! soil heat flux (W/m**2) [+ = into soil]
real(r8), pointer :: eflx_sh_tot(:) ! total sensible heat flux (W/m**2) [+ to atm]
real(r8), pointer :: eflx_lh_tot(:) ! total latent heat flux (W/m8*2) [+ to atm]
real(r8), pointer :: eflx_lh_grnd(:) ! ground evaporation heat flux (W/m**2) [+ to atm]
real(r8), pointer :: t_veg(:) ! vegetation temperature (Kelvin)
real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (Kelvin)
real(r8), pointer :: q_ref2m(:) ! 2 m height surface specific humidity (kg/kg)
real(r8), pointer :: rh_ref2m(:) ! 2 m height surface relative humidity (%)
real(r8), pointer :: taux(:) ! wind (shear) stress: e-w (kg/m/s**2)
real(r8), pointer :: tauy(:) ! wind (shear) stress: n-s (kg/m/s**2)
real(r8), pointer :: qmelt(:) ! snow melt [mm/s]
real(r8), pointer :: ram1(:) ! aerodynamical resistance (s/m)
real(r8), pointer :: errsoi(:) ! soil/lake energy conservation error (W/m**2)
real(r8), pointer :: t_lake(:,:) ! lake temperature (Kelvin)
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!
integer , parameter :: idlak = 1 ! index of lake, 1 = deep lake, 2 = shallow lake
integer , parameter :: niters = 3 ! maximum number of iterations for surface temperature
real(r8), parameter :: beta1 = 1._r8 ! coefficient of connective velocity (in computing W_*) [-]
real(r8), parameter :: emg = 0.97_r8 ! ground emissivity (0.97 for snow)
real(r8), parameter :: zii = 1000._r8 ! convective boundary height [m]
real(r8), parameter :: p0 = 1._r8 ! neutral value of turbulent prandtl number
integer :: i,j,fc,fp,g,c,p ! do loop or array index
integer :: fncopy ! number of values in pft filter copy
integer :: fnold ! previous number of pft filter values
integer :: fpcopy(num_lakep) ! pft filter copy for iteration loop
integer :: num_unfrzc ! number of values in unfrozen column filter
integer :: filter_unfrzc(ubc-lbc+1)! unfrozen column filter
integer :: iter ! iteration index
integer :: nmozsgn(lbp:ubp) ! number of times moz changes sign
integer :: jtop(lbc:ubc) ! number of levels for each column (all 1)
real(r8) :: ax !
real(r8) :: bx !
real(r8) :: degdT ! d(eg)/dT
real(r8) :: dqh(lbp:ubp) ! diff of humidity between ref. height and surface
real(r8) :: dth(lbp:ubp) ! diff of virtual temp. between ref. height and surface
real(r8) :: dthv ! diff of vir. poten. temp. between ref. height and surface
real(r8) :: dzsur(lbc:ubc) !
real(r8) :: eg ! water vapor pressure at temperature T [pa]
real(r8) :: hm ! energy residual [W/m2]
real(r8) :: htvp(lbc:ubc) ! latent heat of vapor of water (or sublimation) [j/kg]
real(r8) :: obu(lbp:ubp) ! monin-obukhov length (m)
real(r8) :: obuold(lbp:ubp) ! monin-obukhov length of previous iteration
real(r8) :: qsatg(lbc:ubc) ! saturated humidity [kg/kg]
real(r8) :: qsatgdT(lbc:ubc) ! d(qsatg)/dT
real(r8) :: qstar ! moisture scaling parameter
real(r8) :: ram(lbp:ubp) ! aerodynamical resistance [s/m]
real(r8) :: rah(lbp:ubp) ! thermal resistance [s/m]
real(r8) :: raw(lbp:ubp) ! moisture resistance [s/m]
real(r8) :: stftg3(lbp:ubp) ! derivative of fluxes w.r.t ground temperature
real(r8) :: temp1(lbp:ubp) ! relation for potential temperature profile
real(r8) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m
real(r8) :: temp2(lbp:ubp) ! relation for specific humidity profile
real(r8) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m
real(r8) :: tgbef(lbc:ubc) ! initial ground temperature
real(r8) :: thm(lbp:ubp) ! intermediate variable (forc_t+0.0098*forc_hgt_t_pft)
real(r8) :: thv(lbc:ubc) ! virtual potential temperature (kelvin)
real(r8) :: thvstar ! virtual potential temperature scaling parameter
real(r8) :: tksur ! thermal conductivity of snow/soil (w/m/kelvin)
real(r8) :: tstar ! temperature scaling parameter
real(r8) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s]
real(r8) :: ur(lbp:ubp) ! wind speed at reference height [m/s]
real(r8) :: ustar(lbp:ubp) ! friction velocity [m/s]
real(r8) :: wc ! convective velocity [m/s]
real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory
real(r8) :: zldis(lbp:ubp) ! reference height "minus" zero displacement height [m]
real(r8) :: displa(lbp:ubp) ! displacement (always zero) [m]
real(r8) :: z0mg(lbp:ubp) ! roughness length over ground, momentum [m]
real(r8) :: z0hg(lbp:ubp) ! roughness length over ground, sensible heat [m]
real(r8) :: z0qg(lbp:ubp) ! roughness length over ground, latent heat [m]
real(r8) :: beta(2) ! fraction solar rad absorbed at surface: depends on lake type
real(r8) :: za(2) ! base of surface absorption layer (m): depends on lake type
real(r8) :: eta(2) ! light extinction coefficient (/m): depends on lake type
real(r8) :: a(lbc:ubc,nlevlak) ! "a" vector for tridiagonal matrix
real(r8) :: b(lbc:ubc,nlevlak) ! "b" vector for tridiagonal matrix
real(r8) :: c1(lbc:ubc,nlevlak) ! "c" vector for tridiagonal matrix
real(r8) :: r(lbc:ubc,nlevlak) ! "r" vector for tridiagonal solution
real(r8) :: rhow(lbc:ubc,nlevlak) ! density of water (kg/m**3)
real(r8) :: phi(lbc:ubc,nlevlak) ! solar radiation absorbed by layer (w/m**2)
real(r8) :: kme(lbc:ubc,nlevlak) ! molecular + eddy diffusion coefficient (m**2/s)
real(r8) :: cwat ! specific heat capacity of water (j/m**3/kelvin)
real(r8) :: ws(lbc:ubc) ! surface friction velocity (m/s)
real(r8) :: ks(lbc:ubc) ! coefficient
real(r8) :: in ! relative flux of solar radiation into layer
real(r8) :: out ! relative flux of solar radiation out of layer
real(r8) :: ri ! richardson number
real(r8) :: fin(lbc:ubc) ! heat flux into lake - flux out of lake (w/m**2)
real(r8) :: ocvts(lbc:ubc) ! (cwat*(t_lake[n ])*dz
real(r8) :: ncvts(lbc:ubc) ! (cwat*(t_lake[n+1])*dz
real(r8) :: m1 ! intermediate variable for calculating r, a, b, c
real(r8) :: m2 ! intermediate variable for calculating r, a, b, c
real(r8) :: m3 ! intermediate variable for calculating r, a, b, c
real(r8) :: ke ! eddy diffusion coefficient (m**2/s)
real(r8) :: km ! molecular diffusion coefficient (m**2/s)
real(r8) :: zin ! depth at top of layer (m)
real(r8) :: zout ! depth at bottom of layer (m)
real(r8) :: drhodz ! d [rhow] /dz (kg/m**4)
real(r8) :: n2 ! brunt-vaisala frequency (/s**2)
real(r8) :: num ! used in calculating ri
real(r8) :: den ! used in calculating ri
real(r8) :: tav(lbc:ubc) ! used in aver temp for convectively mixed layers
real(r8) :: nav(lbc:ubc) ! used in aver temp for convectively mixed layers
real(r8) :: phidum ! temporary value of phi
real(r8) :: u2m ! 2 m wind speed (m/s)
real(r8) :: fm(lbp:ubp) ! needed for BGC only to diagnose 10m wind speed
real(r8) :: e_ref2m ! 2 m height surface saturated vapor pressure [Pa]
real(r8) :: de2mdT ! derivative of 2 m height surface saturated vapor pressure on t_ref2m
real(r8) :: qsat_ref2m ! 2 m height surface saturated specific humidity [kg/kg]
real(r8) :: dqsat2mdT ! derivative of 2 m height surface saturated specific humidity on t_ref2m
!
! Constants for lake temperature model
!
data beta/0.4_r8, 0.4_r8/ ! (deep lake, shallow lake)
data za /0.6_r8, 0.5_r8/
data eta /0.1_r8, 0.5_r8/
!-----------------------------------------------------------------------
! Assign local pointers to derived type members (gridcell-level)
forc_t => clm_a2l%forc_t
forc_pbot => clm_a2l%forc_pbot
forc_th => clm_a2l%forc_th
forc_q => clm_a2l%forc_q
forc_u => clm_a2l%forc_u
forc_v => clm_a2l%forc_v
forc_rho => clm_a2l%forc_rho
forc_lwrad => clm_a2l%forc_lwrad
forc_snow => clm_a2l%forc_snow
forc_rain => clm_a2l%forc_rain
lat => clm3%g%lat
! Assign local pointers to derived type members (column-level)
cgridcell => clm3%g%l%c%gridcell
dz => clm3%g%l%c%cps%dz
z => clm3%g%l%c%cps%z
t_lake => clm3%g%l%c%ces%t_lake
h2osno => clm3%g%l%c%cws%h2osno
snowdp => clm3%g%l%c%cps%snowdp
t_grnd => clm3%g%l%c%ces%t_grnd
hc_soisno => clm3%g%l%c%ces%hc_soisno
errsoi => clm3%g%l%c%cebal%errsoi
qmelt => clm3%g%l%c%cwf%qmelt
! Assign local pointers to derived type members (pft-level)
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
sabg => clm3%g%l%c%p%pef%sabg
t_ref2m => clm3%g%l%c%p%pes%t_ref2m
q_ref2m => clm3%g%l%c%p%pes%q_ref2m
rh_ref2m => clm3%g%l%c%p%pes%rh_ref2m
t_veg => clm3%g%l%c%p%pes%t_veg
eflx_lwrad_out => clm3%g%l%c%p%pef%eflx_lwrad_out
eflx_lwrad_net => clm3%g%l%c%p%pef%eflx_lwrad_net
eflx_soil_grnd => clm3%g%l%c%p%pef%eflx_soil_grnd
eflx_lh_tot => clm3%g%l%c%p%pef%eflx_lh_tot
eflx_lh_grnd => clm3%g%l%c%p%pef%eflx_lh_grnd
eflx_sh_grnd => clm3%g%l%c%p%pef%eflx_sh_grnd
eflx_sh_tot => clm3%g%l%c%p%pef%eflx_sh_tot
ram1 => clm3%g%l%c%p%pps%ram1
taux => clm3%g%l%c%p%pmf%taux
tauy => clm3%g%l%c%p%pmf%tauy
qflx_prec_grnd => clm3%g%l%c%p%pwf%qflx_prec_grnd
qflx_evap_soi => clm3%g%l%c%p%pwf%qflx_evap_soi
qflx_evap_tot => clm3%g%l%c%p%pwf%qflx_evap_tot
forc_hgt_u_pft => clm3%g%l%c%p%pps%forc_hgt_u_pft
forc_hgt_t_pft => clm3%g%l%c%p%pps%forc_hgt_t_pft
forc_hgt_q_pft => clm3%g%l%c%p%pps%forc_hgt_q_pft
qflx_snwcp_ice => clm3%g%l%c%p%pwf%qflx_snwcp_ice
qflx_snwcp_liq => clm3%g%l%c%p%pwf%qflx_snwcp_liq
! Begin calculations
do fc = 1, num_lakec
c = filter_lakec(fc)
g = cgridcell(c)
! Initialize quantities computed below
ocvts(c) = 0._r8
ncvts(c) = 0._r8
hc_soisno(c) = 0._r8
! Surface temperature and fluxes
dzsur(c) = dz(c,1) + snowdp(c)
! Saturated vapor pressure, specific humidity and their derivatives
! at lake surface
call QSat(t_grnd(c), forc_pbot(g), eg, degdT, qsatg(c), qsatgdT(c))
! Potential, virtual potential temperature, and wind speed at the
! reference height
!zii = 1000. ! m (pbl height)
thv(c) = forc_th(g)*(1._r8+0.61_r8*forc_q(g)) ! virtual potential T
end do
do fp = 1, num_lakep
p = filter_lakep(fp)
c = pcolumn(p)
g = pgridcell(p)
nmozsgn(p) = 0
obuold(p) = 0._r8
displa(p) = 0._r8
thm(p) = forc_t(g) + 0.0098_r8*forc_hgt_t_pft(p) ! intermediate variable
! Roughness lengths
if (t_grnd(c) >= tfrz) then ! for unfrozen lake
z0mg(p) = 0.01_r8
else ! for frozen lake
z0mg(p) = 0.04_r8
end if
z0hg(p) = z0mg(p)
z0qg(p) = z0mg(p)
! Latent heat
#if (defined PERGRO)
htvp(c) = hvap
#else
if (forc_t(g) > tfrz) then
htvp(c) = hvap
else
htvp(c) = hsub
end if
#endif
! Initialize stability variables
ur(p) = max(1.0_r8,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g)))
dth(p) = thm(p)-t_grnd(c)
dqh(p) = forc_q(g)-qsatg(c)
dthv = dth(p)*(1._r8+0.61_r8*forc_q(g))+0.61_r8*forc_th(g)*dqh(p)
zldis(p) = forc_hgt_u_pft(p) - 0._r8
! Initialize Monin-Obukhov length and wind speed
call MoninObukIni(ur(p), thv(c), dthv, zldis(p), z0mg(p), um(p), obu(p))
end do
iter = 1
fncopy = num_lakep
fpcopy(1:num_lakep) = filter_lakep(1:num_lakep)
! Begin stability iteration
ITERATION : do while (iter <= niters .and. fncopy > 0)
! Determine friction velocity, and potential temperature and humidity
! profiles of the surface boundary layer
call FrictionVelocity(lbp, ubp, fncopy, fpcopy, &
displa, z0mg, z0hg, z0qg, &
obu, iter, ur, um, ustar, &
temp1, temp2, temp12m, temp22m, fm)
do fp = 1, fncopy
p = fpcopy(fp)
c = pcolumn(p)
g = pgridcell(p)
tgbef(c) = t_grnd(c)
if (t_grnd(c) > tfrz) then
tksur = tkwat
else
tksur = tkice
end if
! Determine aerodynamic resistances
ram(p) = 1._r8/(ustar(p)*ustar(p)/um(p))
rah(p) = 1._r8/(temp1(p)*ustar(p))
raw(p) = 1._r8/(temp2(p)*ustar(p))
ram1(p) = ram(p) !pass value to global variable
! Get derivative of fluxes with respect to ground temperature
stftg3(p) = emg*sb*tgbef(c)*tgbef(c)*tgbef(c)
ax = sabg(p) + emg*forc_lwrad(g) + 3._r8*stftg3(p)*tgbef(c) &
+ forc_rho(g)*cpair/rah(p)*thm(p) &
- htvp(c)*forc_rho(g)/raw(p)*(qsatg(c)-qsatgdT(c)*tgbef(c) - forc_q(g)) &
+ tksur*t_lake(c,1)/dzsur(c)
bx = 4._r8*stftg3(p) + forc_rho(g)*cpair/rah(p) &
+ htvp(c)*forc_rho(g)/raw(p)*qsatgdT(c) + tksur/dzsur(c)
t_grnd(c) = ax/bx
! Surface fluxes of momentum, sensible and latent heat
! using ground temperatures from previous time step
eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(p))/rah(p)
qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-tgbef(c))-forc_q(g))/raw(p)
! Re-calculate saturated vapor pressure, specific humidity and their
! derivatives at lake surface
call QSat(t_grnd(c), forc_pbot(g), eg, degdT, qsatg(c), qsatgdT(c))
dth(p)=thm(p)-t_grnd(c)
dqh(p)=forc_q(g)-qsatg(c)
tstar = temp1(p)*dth(p)
qstar = temp2(p)*dqh(p)
!not used
!dthv=dth(p)*(1.+0.61*forc_q(g))+0.61*forc_th(g)*dqh(p)
thvstar=tstar*(1._r8+0.61_r8*forc_q(g)) + 0.61_r8*forc_th(g)*qstar
zeta=zldis(p)*vkc * grav*thvstar/(ustar(p)**2*thv(c))
if (zeta >= 0._r8) then !stable
zeta = min(2._r8,max(zeta,0.01_r8))
um(p) = max(ur(p),0.1_r8)
else !unstable
zeta = max(-100._r8,min(zeta,-0.01_r8))
wc = beta1*(-grav*ustar(p)*thvstar*zii/thv(c))**0.333_r8
um(p) = sqrt(ur(p)*ur(p)+wc*wc)
end if
obu(p) = zldis(p)/zeta
if (obuold(p)*obu(p) < 0._r8) nmozsgn(p) = nmozsgn(p)+1
obuold(p) = obu(p)
end do ! end of filtered pft loop
iter = iter + 1
if (iter <= niters ) then
! Rebuild copy of pft filter for next pass through the ITERATION loop
fnold = fncopy
fncopy = 0
do fp = 1, fnold
p = fpcopy(fp)
if (nmozsgn(p) < 3) then
fncopy = fncopy + 1
fpcopy(fncopy) = p
end if
end do ! end of filtered pft loop
end if
end do ITERATION ! end of stability iteration
do fp = 1, num_lakep
p = filter_lakep(fp)
c = pcolumn(p)
g = pgridcell(p)
! initialize snow cap terms to zero for lake columns
qflx_snwcp_ice(p) = 0._r8
qflx_snwcp_liq(p) = 0._r8
! If there is snow on the ground and t_grnd > tfrz: reset t_grnd = tfrz.
! Re-evaluate ground fluxes. Energy imbalance used to melt snow.
! h2osno > 0.5 prevents spurious fluxes.
! note that qsatg and qsatgdT should be f(tgbef) (PET: not sure what this
! comment means)
if (h2osno(c) > 0.5_r8 .AND. t_grnd(c) > tfrz) then
t_grnd(c) = tfrz
eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(p))/rah(p)
qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-tgbef(c)) - forc_q(g))/raw(p)
end if
! Net longwave from ground to atmosphere
eflx_lwrad_out(p) = (1._r8-emg)*forc_lwrad(g) + stftg3(p)*(-3._r8*tgbef(c)+4._r8*t_grnd(c))
! Ground heat flux
eflx_soil_grnd(p) = sabg(p) + forc_lwrad(g) - eflx_lwrad_out(p) - &
eflx_sh_grnd(p) - htvp(c)*qflx_evap_soi(p)
taux(p) = -forc_rho(g)*forc_u(g)/ram(p)
tauy(p) = -forc_rho(g)*forc_v(g)/ram(p)
eflx_sh_tot(p) = eflx_sh_grnd(p)
qflx_evap_tot(p) = qflx_evap_soi(p)
eflx_lh_tot(p) = htvp(c)*qflx_evap_soi(p)
eflx_lh_grnd(p) = htvp(c)*qflx_evap_soi(p)
! 2 m height air temperature
t_ref2m(p) = thm(p) + temp1(p)*dth(p)*(1._r8/temp12m(p) - 1._r8/temp1(p))
! 2 m height specific humidity
q_ref2m(p) = forc_q(g) + temp2(p)*dqh(p)*(1._r8/temp22m(p) - 1._r8/temp2(p))
! 2 m height relative humidity
call QSat(t_ref2m(p), forc_pbot(g), e_ref2m, de2mdT, qsat_ref2m, dqsat2mdT)
rh_ref2m(p) = min(100._r8, q_ref2m(p) / qsat_ref2m * 100._r8)
! Energy residual used for melting snow
if (h2osno(c) > 0._r8 .AND. t_grnd(c) >= tfrz) then
hm = min(h2osno(c)*hfus/dtime, max(eflx_soil_grnd(p),0._r8))
else
hm = 0._r8
end if
qmelt(c) = hm/hfus ! snow melt (mm/s)
! Prepare for lake layer temperature calculations below
fin(c) = beta(idlak) * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + &
eflx_sh_tot(p) + eflx_lh_tot(p) + hm)
u2m = max(1.0_r8,ustar(p)/vkc*log(2._r8/z0mg(p)))
ws(c) = 1.2e-03_r8 * u2m
ks(c) = 6.6_r8*sqrt(abs(sin(lat(g))))*(u2m**(-1.84_r8))
end do
! Eddy diffusion + molecular diffusion coefficient (constants):
! eddy diffusion coefficient used for unfrozen deep lakes only
cwat = cpliq*denh2o ! a constant
km = tkwat/cwat ! a constant
! Lake density
do j = 1, nlevlak
do fc = 1, num_lakec
c = filter_lakec(fc)
rhow(c,j) = 1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,j)-277._r8))**1.68_r8 )
end do
end do
do j = 1, nlevlak-1
do fc = 1, num_lakec
c = filter_lakec(fc)
drhodz = (rhow(c,j+1)-rhow(c,j)) / (z(c,j+1)-z(c,j))
n2 = -grav / rhow(c,j) * drhodz
num = 40._r8 * n2 * (vkc*z(c,j))**2
den = max( (ws(c)**2) * exp(-2._r8*ks(c)*z(c,j)), 1.e-10_r8 )
ri = ( -1._r8 + sqrt( max(1._r8+num/den, 0._r8) ) ) / 20._r8
if (t_grnd(c) > tfrz) then
! valid for deep lake only (idlak == 1)
ke = vkc*ws(c)*z(c,j)/p0 * exp(-ks(c)*z(c,j)) / (1._r8+37._r8*ri*ri)
else
ke = 0._r8
end if
kme(c,j) = km + ke
end do
end do
do fc = 1, num_lakec
c = filter_lakec(fc)
kme(c,nlevlak) = kme(c,nlevlak-1)
! set number of column levels for use by Tridiagonal below
jtop(c) = 1
end do
! Heat source term: unfrozen lakes only
do j = 1, nlevlak
do fp = 1, num_lakep
p = filter_lakep(fp)
c = pcolumn(p)
zin = z(c,j) - 0.5_r8*dz(c,j)
zout = z(c,j) + 0.5_r8*dz(c,j)
in = exp( -eta(idlak)*max( zin-za(idlak),0._r8 ) )
out = exp( -eta(idlak)*max( zout-za(idlak),0._r8 ) )
! Assume solar absorption is only in the considered depth
if (j == nlevlak) out = 0._r8
if (t_grnd(c) > tfrz) then
phidum = (in-out) * sabg(p) * (1._r8-beta(idlak))
else if (j == 1) then
phidum = sabg(p) * (1._r8-beta(idlak))
else
phidum = 0._r8
end if
phi(c,j) = phidum
end do
end do
! Sum cwat*t_lake*dz for energy check
do j = 1, nlevlak
do fc = 1, num_lakec
c = filter_lakec(fc)
ocvts(c) = ocvts(c) + cwat*t_lake(c,j)*dz(c,j)
end do
end do
! Set up vector r and vectors a, b, c that define tridiagonal matrix
do fc = 1, num_lakec
c = filter_lakec(fc)
j = 1
m2 = dz(c,j)/kme(c,j) + dz(c,j+1)/kme(c,j+1)
m3 = dtime/dz(c,j)
r(c,j) = t_lake(c,j) + (fin(c)+phi(c,j))*m3/cwat - (t_lake(c,j)-t_lake(c,j+1))*m3/m2
a(c,j) = 0._r8
b(c,j) = 1._r8 + m3/m2
c1(c,j) = -m3/m2
j = nlevlak
m1 = dz(c,j-1)/kme(c,j-1) + dz(c,j)/kme(c,j)
m3 = dtime/dz(c,j)
r(c,j) = t_lake(c,j) + phi(c,j)*m3/cwat + (t_lake(c,j-1)-t_lake(c,j))*m3/m1
a(c,j) = -m3/m1
b(c,j) = 1._r8 + m3/m1
c1(c,j) = 0._r8
end do
do j = 2, nlevlak-1
do fc = 1, num_lakec
c = filter_lakec(fc)
m1 = dz(c,j-1)/kme(c,j-1) + dz(c,j )/kme(c,j )
m2 = dz(c,j )/kme(c,j ) + dz(c,j+1)/kme(c,j+1)
m3 = dtime/dz(c,j)
r(c,j) = t_lake(c,j) + phi(c,j)*m3/cwat + &
(t_lake(c,j-1) - t_lake(c,j ))*m3/m1 - &
(t_lake(c,j ) - t_lake(c,j+1))*m3/m2
a(c,j) = -m3/m1
b(c,j) = 1._r8 + m3/m1 + m3/m2
c1(c,j) = -m3/m2
end do
end do
! Solve for t_lake: a, b, c, r, u
call Tridiagonal(lbc, ubc, 1, nlevlak, jtop, num_lakec, filter_lakec, &
a, b, c1, r, t_lake(lbc:ubc,1:nlevlak))
! Convective mixing: make sure cwat*dz*ts is conserved. Valid only for
! deep lakes (idlak == 1).
num_unfrzc = 0
do fc = 1, num_lakec
c = filter_lakec(fc)
if (t_grnd(c) > tfrz) then
num_unfrzc = num_unfrzc + 1
filter_unfrzc(num_unfrzc) = c
end if
end do
do j = 1, nlevlak-1
do fc = 1, num_unfrzc
c = filter_unfrzc(fc)
tav(c) = 0._r8
nav(c) = 0._r8
end do
do i = 1, j+1
do fc = 1, num_unfrzc
c = filter_unfrzc(fc)
if (rhow(c,j) > rhow(c,j+1)) then
tav(c) = tav(c) + t_lake(c,i)*dz(c,i)
nav(c) = nav(c) + dz(c,i)
end if
end do
end do
do fc = 1, num_unfrzc
c = filter_unfrzc(fc)
if (rhow(c,j) > rhow(c,j+1)) then
tav(c) = tav(c)/nav(c)
end if
end do
do i = 1, j+1
do fc = 1, num_unfrzc
c = filter_unfrzc(fc)
if (nav(c) > 0._r8) then
t_lake(c,i) = tav(c)
rhow(c,i) = 1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,i)-277._r8))**1.68_r8 )
end if
end do
end do
end do
! Sum cwat*t_lake*dz and total energy into lake for energy check
do j = 1, nlevlak
do fc = 1, num_lakec
c = filter_lakec(fc)
ncvts(c) = ncvts(c) + cwat*t_lake(c,j)*dz(c,j)
hc_soisno(c) = hc_soisno(c) + cwat*t_lake(c,j)*dz(c,j) /1.e6_r8
if (j == nlevlak) then
hc_soisno(c) = hc_soisno(c) + &
cpice*h2osno(c)*t_grnd(c)*snowdp(c) /1.e6_r8
endif
fin(c) = fin(c) + phi(c,j)
end do
end do
! The following are needed for global average on history tape.
do fp = 1, num_lakep
p = filter_lakep(fp)
c = pcolumn(p)
g = pgridcell(p)
errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c)
t_veg(p) = forc_t(g)
eflx_lwrad_net(p) = eflx_lwrad_out(p) - forc_lwrad(g)
qflx_prec_grnd(p) = forc_rain(g) + forc_snow(g)
end do
end subroutine BiogeophysicsLake
end module BiogeophysicsLakeMod
!========================================================================================
module CNAllocationMod 2,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNAllocationMod
!
! !DESCRIPTION:
! Module holding routines used in allocation model for coupled carbon
! nitrogen code.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: CNAllocation
!
! !REVISION HISTORY:
! 8/5/03: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNAllocation
!
! !INTERFACE:
subroutine CNAllocation (lbp, ubp, lbc, ubc, & 1,5
num_soilc, filter_soilc, num_soilp, filter_soilp)
!
! !DESCRIPTION:
!
! !USES:
use clmtype
! use clm_varctl, only: iulog
! use shr_sys_mod, only: shr_sys_flush
! use clm_time_manager, only: get_step_size
use globals, only : dt
use pft2colMod, only: p2c
#if (defined CROP)
use pftvarcon , only: npcropmin, declfact, bfact, aleaff, arootf, astemf, arooti, fleafi, allconsl, allconss
#endif
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbp, ubp ! pft-index bounds
integer, intent(in) :: lbc, ubc ! column-index bounds
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNdecompAlloc in module CNdecompMod.F90
!
! !REVISION HISTORY:
! 8/5/03: Created by Peter Thornton
! 10/23/03, Peter Thornton: migrated to vector data structures
!
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
!
! pft level
integer , pointer :: ivt(:) ! pft vegetation type
integer , pointer :: pcolumn(:) ! pft's column index
real(r8), pointer :: lgsf(:) ! long growing season factor [0-1]
real(r8), pointer :: xsmrpool(:) ! (kgC/m2) temporary photosynthate C pool
real(r8), pointer :: retransn(:) ! (kgN/m2) plant pool of retranslocated N
real(r8), pointer :: psnsun(:) ! sunlit leaf-level photosynthesis (umol CO2 /m**2/ s)
real(r8), pointer :: psnsha(:) ! shaded leaf-level photosynthesis (umol CO2 /m**2/ s)
#if (defined C13)
real(r8), pointer :: c13_psnsun(:) ! C13 sunlit leaf-level photosynthesis (umol CO2 /m**2/ s)
real(r8), pointer :: c13_psnsha(:) ! C13 shaded leaf-level photosynthesis (umol CO2 /m**2/ s)
#endif
real(r8), pointer :: laisun(:) ! sunlit projected leaf area index
real(r8), pointer :: laisha(:) ! shaded projected leaf area index
real(r8), pointer :: leaf_mr(:)
real(r8), pointer :: froot_mr(:)
real(r8), pointer :: livestem_mr(:)
real(r8), pointer :: livecroot_mr(:)
real(r8), pointer :: leaf_curmr(:)
real(r8), pointer :: froot_curmr(:)
real(r8), pointer :: livestem_curmr(:)
real(r8), pointer :: livecroot_curmr(:)
real(r8), pointer :: leaf_xsmr(:)
real(r8), pointer :: froot_xsmr(:)
real(r8), pointer :: livestem_xsmr(:)
real(r8), pointer :: livecroot_xsmr(:)
! column level
real(r8), pointer :: sminn(:) ! (kgN/m2) soil mineral N
! ecophysiological constants
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
real(r8), pointer :: froot_leaf(:) ! allocation parameter: new fine root C per new leaf C (gC/gC)
real(r8), pointer :: croot_stem(:) ! allocation parameter: new coarse root C per new stem C (gC/gC)
real(r8), pointer :: stem_leaf(:) ! allocation parameter: new stem c per new leaf C (gC/gC)
real(r8), pointer :: flivewd(:) ! allocation parameter: fraction of new wood that is live (phloem and ray parenchyma) (no units)
real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN)
real(r8), pointer :: frootcn(:) ! fine root C:N (gC/gN)
real(r8), pointer :: livewdcn(:) ! live wood (phloem and ray parenchyma) C:N (gC/gN)
real(r8), pointer :: deadwdcn(:) ! dead wood (xylem and heartwood) C:N (gC/gN)
real(r8), pointer :: fcur2(:) ! allocation parameter: fraction of allocation that goes to currently displayed growth, remainder to storage
integer, pointer :: plandunit(:) ! index into landunit level quantities
integer, pointer :: clandunit(:) ! index into landunit level quantities
integer , pointer :: itypelun(:) ! landunit type
#if (defined CROP)
integer , pointer :: croplive(:) ! planted, not harvested = 1; else 0
integer , pointer :: peaklai(:) ! 1: max allowed lai; 0: not at max
real(r8), pointer :: gddmaturity(:)! gdd needed to harvest
real(r8), pointer :: huileaf(:) ! heat unit index needed from planting to leaf emergence
real(r8), pointer :: huigrain(:) ! same to reach vegetative maturity
real(r8), pointer :: hui(:) ! =gdd since planting (gddplant)
real(r8), pointer :: leafout(:) ! =gdd from top soil layer temperature
real(r8), pointer :: aleafi(:) ! saved allocation coefficient from phase 2
real(r8), pointer :: astemi(:) ! saved allocation coefficient from phase 2
real(r8), pointer :: aleaf(:) ! leaf allocation coefficient
real(r8), pointer :: astem(:) ! stem allocation coefficient
real(r8), pointer :: graincn(:) ! grain C:N (gC/gN)
#endif
!
! local pointers to implicit in/out arrays
!
! pft level
real(r8), pointer :: gpp(:) ! GPP flux before downregulation (gC/m2/s)
real(r8), pointer :: availc(:) ! C flux available for allocation (gC/m2/s)
real(r8), pointer :: xsmrpool_recover(:) ! C flux assigned to recovery of negative cpool (gC/m2/s)
real(r8), pointer :: c_allometry(:) ! C allocation index (DIM)
real(r8), pointer :: n_allometry(:) ! N allocation index (DIM)
real(r8), pointer :: plant_ndemand(:) ! N flux required to support initial GPP (gN/m2/s)
real(r8), pointer :: tempsum_potential_gpp(:) ! temporary annual sum of potential GPP
real(r8), pointer :: tempmax_retransn(:) ! temporary annual max of retranslocated N pool (gN/m2)
real(r8), pointer :: annsum_potential_gpp(:) ! annual sum of potential GPP
real(r8), pointer :: avail_retransn(:) ! N flux available from retranslocation pool (gN/m2/s)
real(r8), pointer :: annmax_retransn(:) ! annual max of retranslocated N pool
real(r8), pointer :: plant_nalloc(:) ! total allocated N flux (gN/m2/s)
real(r8), pointer :: plant_calloc(:) ! total allocated C flux (gC/m2/s)
real(r8), pointer :: excess_cflux(:) ! C flux not allocated due to downregulation (gC/m2/s)
real(r8), pointer :: downreg(:) ! fractional reduction in GPP due to N limitation (DIM)
real(r8), pointer :: annsum_npp(:) ! annual sum of NPP, for wood allocation
real(r8), pointer :: cpool_to_xsmrpool(:)
real(r8), pointer :: psnsun_to_cpool(:)
real(r8), pointer :: psnshade_to_cpool(:)
#if (defined C13)
real(r8), pointer :: c13_psnsun_to_cpool(:)
real(r8), pointer :: c13_psnshade_to_cpool(:)
#endif
real(r8), pointer :: cpool_to_leafc(:)
real(r8), pointer :: cpool_to_leafc_storage(:)
real(r8), pointer :: cpool_to_frootc(:)
real(r8), pointer :: cpool_to_frootc_storage(:)
real(r8), pointer :: cpool_to_livestemc(:)
real(r8), pointer :: cpool_to_livestemc_storage(:)
real(r8), pointer :: cpool_to_deadstemc(:)
real(r8), pointer :: cpool_to_deadstemc_storage(:)
real(r8), pointer :: cpool_to_livecrootc(:)
real(r8), pointer :: cpool_to_livecrootc_storage(:)
real(r8), pointer :: cpool_to_deadcrootc(:)
real(r8), pointer :: cpool_to_deadcrootc_storage(:)
real(r8), pointer :: cpool_to_gresp_storage(:)
real(r8), pointer :: retransn_to_npool(:)
real(r8), pointer :: sminn_to_npool(:)
#if (defined CROP)
real(r8), pointer :: cpool_to_grainc(:)
real(r8), pointer :: cpool_to_grainc_storage(:)
real(r8), pointer :: npool_to_grainn(:)
real(r8), pointer :: npool_to_grainn_storage(:)
#endif
real(r8), pointer :: npool_to_leafn(:)
real(r8), pointer :: npool_to_leafn_storage(:)
real(r8), pointer :: npool_to_frootn(:)
real(r8), pointer :: npool_to_frootn_storage(:)
real(r8), pointer :: npool_to_livestemn(:)
real(r8), pointer :: npool_to_livestemn_storage(:)
real(r8), pointer :: npool_to_deadstemn(:)
real(r8), pointer :: npool_to_deadstemn_storage(:)
real(r8), pointer :: npool_to_livecrootn(:)
real(r8), pointer :: npool_to_livecrootn_storage(:)
real(r8), pointer :: npool_to_deadcrootn(:)
real(r8), pointer :: npool_to_deadcrootn_storage(:)
! column level
real(r8), pointer :: fpi(:) ! fraction of potential immobilization (no units)
real(r8), pointer :: fpg(:) ! fraction of potential gpp (no units)
real(r8), pointer :: potential_immob(:)
real(r8), pointer :: actual_immob(:)
real(r8), pointer :: sminn_to_plant(:)
real(r8), pointer :: sminn_to_denit_excess(:)
real(r8), pointer :: supplement_to_sminn(:)
!
! local pointers to implicit out arrays
!
!
! !OTHER LOCAL VARIABLES:
integer :: c,p !indices
integer :: fp !lake filter pft index
integer :: fc !lake filter column index
! real(r8):: dt !decomp timestep (seconds)
integer :: nlimit !flag for N limitation
real(r8), pointer:: col_plant_ndemand(:) !column-level plant N demand
real(r8):: dayscrecover !number of days to recover negative cpool
real(r8):: mr !maintenance respiration (gC/m2/s)
real(r8):: f1,f2,f3,f4,g1,g2 !allocation parameters
real(r8):: cnl,cnfr,cnlw,cndw !C:N ratios for leaf, fine root, and wood
real(r8):: grperc, grpnow !growth respirarion parameters
real(r8):: fcur !fraction of current psn displayed as growth
real(r8):: sum_ndemand !total column N demand (gN/m2/s)
real(r8):: gresp_storage !temporary variable for growth resp to storage
real(r8):: nlc !temporary variable for total new leaf carbon allocation
real(r8):: bdnr !bulk denitrification rate (1/s)
real(r8):: curmr, curmr_ratio !xsmrpool temporary variables
#if (defined CROP)
real(r8) f5 !grain allocation parameter
real(r8) cng !C:N ratio for grain (= cnlw for now; slevis)
real(r8) fleaf !fraction allocated to leaf
real(r8), pointer :: arepr(:) !reproduction allocation coefficient
real(r8), pointer :: aroot(:) !root allocation coefficient
#endif
!EOP
!-----------------------------------------------------------------------
! Assign local pointers to derived type arrays (in)
ivt => clm3%g%l%c%p%itype
pcolumn => clm3%g%l%c%p%column
plandunit => clm3%g%l%c%p%landunit
clandunit => clm3%g%l%c%landunit
itypelun => clm3%g%l%itype
lgsf => clm3%g%l%c%p%pepv%lgsf
xsmrpool => clm3%g%l%c%p%pcs%xsmrpool
retransn => clm3%g%l%c%p%pns%retransn
psnsun => clm3%g%l%c%p%pcf%psnsun
psnsha => clm3%g%l%c%p%pcf%psnsha
#if (defined C13)
c13_psnsun => clm3%g%l%c%p%pc13f%psnsun
c13_psnsha => clm3%g%l%c%p%pc13f%psnsha
#endif
laisun => clm3%g%l%c%p%pps%laisun
laisha => clm3%g%l%c%p%pps%laisha
leaf_mr => clm3%g%l%c%p%pcf%leaf_mr
froot_mr => clm3%g%l%c%p%pcf%froot_mr
livestem_mr => clm3%g%l%c%p%pcf%livestem_mr
livecroot_mr => clm3%g%l%c%p%pcf%livecroot_mr
leaf_curmr => clm3%g%l%c%p%pcf%leaf_curmr
froot_curmr => clm3%g%l%c%p%pcf%froot_curmr
livestem_curmr => clm3%g%l%c%p%pcf%livestem_curmr
livecroot_curmr => clm3%g%l%c%p%pcf%livecroot_curmr
leaf_xsmr => clm3%g%l%c%p%pcf%leaf_xsmr
froot_xsmr => clm3%g%l%c%p%pcf%froot_xsmr
livestem_xsmr => clm3%g%l%c%p%pcf%livestem_xsmr
livecroot_xsmr => clm3%g%l%c%p%pcf%livecroot_xsmr
sminn => clm3%g%l%c%cns%sminn
woody => pftcon%woody
froot_leaf => pftcon%froot_leaf
croot_stem => pftcon%croot_stem
stem_leaf => pftcon%stem_leaf
flivewd => pftcon%flivewd
leafcn => pftcon%leafcn
frootcn => pftcon%frootcn
livewdcn => pftcon%livewdcn
deadwdcn => pftcon%deadwdcn
fcur2 => pftcon%fcur
#if (defined CROP)
gddmaturity => clm3%g%l%c%p%pps%gddmaturity
huileaf => clm3%g%l%c%p%pps%huileaf
huigrain => clm3%g%l%c%p%pps%huigrain
hui => clm3%g%l%c%p%pps%gddplant
leafout => clm3%g%l%c%p%pps%gddtsoi
croplive => clm3%g%l%c%p%pps%croplive
peaklai => clm3%g%l%c%p%pps%peaklai
graincn => pftcon%graincn
#endif
! Assign local pointers to derived type arrays (out)
gpp => clm3%g%l%c%p%pepv%gpp
availc => clm3%g%l%c%p%pepv%availc
xsmrpool_recover => clm3%g%l%c%p%pepv%xsmrpool_recover
c_allometry => clm3%g%l%c%p%pepv%c_allometry
n_allometry => clm3%g%l%c%p%pepv%n_allometry
plant_ndemand => clm3%g%l%c%p%pepv%plant_ndemand
tempsum_potential_gpp => clm3%g%l%c%p%pepv%tempsum_potential_gpp
tempmax_retransn => clm3%g%l%c%p%pepv%tempmax_retransn
annsum_potential_gpp => clm3%g%l%c%p%pepv%annsum_potential_gpp
avail_retransn => clm3%g%l%c%p%pepv%avail_retransn
annmax_retransn => clm3%g%l%c%p%pepv%annmax_retransn
plant_nalloc => clm3%g%l%c%p%pepv%plant_nalloc
plant_calloc => clm3%g%l%c%p%pepv%plant_calloc
excess_cflux => clm3%g%l%c%p%pepv%excess_cflux
downreg => clm3%g%l%c%p%pepv%downreg
annsum_npp => clm3%g%l%c%p%pepv%annsum_npp
cpool_to_xsmrpool => clm3%g%l%c%p%pcf%cpool_to_xsmrpool
psnsun_to_cpool => clm3%g%l%c%p%pcf%psnsun_to_cpool
psnshade_to_cpool => clm3%g%l%c%p%pcf%psnshade_to_cpool
#if (defined C13)
c13_psnsun_to_cpool => clm3%g%l%c%p%pc13f%psnsun_to_cpool
c13_psnshade_to_cpool => clm3%g%l%c%p%pc13f%psnshade_to_cpool
#endif
cpool_to_leafc => clm3%g%l%c%p%pcf%cpool_to_leafc
cpool_to_leafc_storage => clm3%g%l%c%p%pcf%cpool_to_leafc_storage
cpool_to_frootc => clm3%g%l%c%p%pcf%cpool_to_frootc
cpool_to_frootc_storage => clm3%g%l%c%p%pcf%cpool_to_frootc_storage
cpool_to_livestemc => clm3%g%l%c%p%pcf%cpool_to_livestemc
cpool_to_livestemc_storage => clm3%g%l%c%p%pcf%cpool_to_livestemc_storage
cpool_to_deadstemc => clm3%g%l%c%p%pcf%cpool_to_deadstemc
cpool_to_deadstemc_storage => clm3%g%l%c%p%pcf%cpool_to_deadstemc_storage
cpool_to_livecrootc => clm3%g%l%c%p%pcf%cpool_to_livecrootc
cpool_to_livecrootc_storage => clm3%g%l%c%p%pcf%cpool_to_livecrootc_storage
cpool_to_deadcrootc => clm3%g%l%c%p%pcf%cpool_to_deadcrootc
cpool_to_deadcrootc_storage => clm3%g%l%c%p%pcf%cpool_to_deadcrootc_storage
cpool_to_gresp_storage => clm3%g%l%c%p%pcf%cpool_to_gresp_storage
#if (defined CROP)
cpool_to_grainc => clm3%g%l%c%p%pcf%cpool_to_grainc
cpool_to_grainc_storage => clm3%g%l%c%p%pcf%cpool_to_grainc_storage
npool_to_grainn => clm3%g%l%c%p%pnf%npool_to_grainn
npool_to_grainn_storage => clm3%g%l%c%p%pnf%npool_to_grainn_storage
#endif
retransn_to_npool => clm3%g%l%c%p%pnf%retransn_to_npool
sminn_to_npool => clm3%g%l%c%p%pnf%sminn_to_npool
npool_to_leafn => clm3%g%l%c%p%pnf%npool_to_leafn
npool_to_leafn_storage => clm3%g%l%c%p%pnf%npool_to_leafn_storage
npool_to_frootn => clm3%g%l%c%p%pnf%npool_to_frootn
npool_to_frootn_storage => clm3%g%l%c%p%pnf%npool_to_frootn_storage
npool_to_livestemn => clm3%g%l%c%p%pnf%npool_to_livestemn
npool_to_livestemn_storage => clm3%g%l%c%p%pnf%npool_to_livestemn_storage
npool_to_deadstemn => clm3%g%l%c%p%pnf%npool_to_deadstemn
npool_to_deadstemn_storage => clm3%g%l%c%p%pnf%npool_to_deadstemn_storage
npool_to_livecrootn => clm3%g%l%c%p%pnf%npool_to_livecrootn
npool_to_livecrootn_storage => clm3%g%l%c%p%pnf%npool_to_livecrootn_storage
npool_to_deadcrootn => clm3%g%l%c%p%pnf%npool_to_deadcrootn
npool_to_deadcrootn_storage => clm3%g%l%c%p%pnf%npool_to_deadcrootn_storage
fpi => clm3%g%l%c%cps%fpi
fpg => clm3%g%l%c%cps%fpg
potential_immob => clm3%g%l%c%cnf%potential_immob
actual_immob => clm3%g%l%c%cnf%actual_immob
sminn_to_plant => clm3%g%l%c%cnf%sminn_to_plant
sminn_to_denit_excess => clm3%g%l%c%cnf%sminn_to_denit_excess
supplement_to_sminn => clm3%g%l%c%cnf%supplement_to_sminn
#if (defined CROP)
aleafi => clm3%g%l%c%p%pps%aleafi
astemi => clm3%g%l%c%p%pps%astemi
aleaf => clm3%g%l%c%p%pps%aleaf
astem => clm3%g%l%c%p%pps%astem
allocate(arepr(lbp:ubp))
allocate(aroot(lbp:ubp))
#endif
! set time steps
! dt = real( get_step_size(), r8 )
! set some space-and-time constant parameters
dayscrecover = 30.0_r8
grperc = 0.3_r8
grpnow = 1.0_r8
bdnr = 0.5_r8 * (dt/86400._r8)
! loop over pfts to assess the total plant N demand
do fp=1,num_soilp
p = filter_soilp(fp)
! get the time step total gross photosynthesis
! this is coming from the canopy fluxes code, and is the
! gpp that is used to control stomatal conductance.
! For the nitrogen downregulation code, this is assumed
! to be the potential gpp, and the actual gpp will be
! reduced due to N limitation.
! Convert psn from umol/m2/s -> gC/m2/s
! The input psn (psnsun and psnsha) are expressed per unit LAI
! in the sunlit and shaded canopy, respectively. These need to be
! scaled by laisun and laisha to get the total gpp for allocation
psnsun_to_cpool(p) = psnsun(p) * laisun(p) * 12.011e-6_r8
psnshade_to_cpool(p) = psnsha(p) * laisha(p) * 12.011e-6_r8
#if (defined C13)
c13_psnsun_to_cpool(p) = c13_psnsun(p) * laisun(p) * 12.011e-6_r8
c13_psnshade_to_cpool(p) = c13_psnsha(p) * laisha(p) * 12.011e-6_r8
#endif
gpp(p) = psnsun_to_cpool(p) + psnshade_to_cpool(p)
! get the time step total maintenance respiration
! These fluxes should already be in gC/m2/s
mr = leaf_mr(p) + froot_mr(p)
if (woody(ivt(p)) == 1.0_r8) then
mr = mr + livestem_mr(p) + livecroot_mr(p)
end if
! carbon flux available for allocation
availc(p) = gpp(p) - mr
! new code added for isotope calculations, 7/1/05, PET
! If mr > gpp, then some mr comes from gpp, the rest comes from
! cpool (xsmr)
curmr_ratio = 1._r8
if (mr > 0._r8 .and. availc(p) < 0._r8) then
curmr = gpp(p)
curmr_ratio = curmr / mr
end if
leaf_curmr(p) = leaf_mr(p) * curmr_ratio
leaf_xsmr(p) = leaf_mr(p) - leaf_curmr(p)
froot_curmr(p) = froot_mr(p) * curmr_ratio
froot_xsmr(p) = froot_mr(p) - froot_curmr(p)
livestem_curmr(p) = livestem_mr(p) * curmr_ratio
livestem_xsmr(p) = livestem_mr(p) - livestem_curmr(p)
livecroot_curmr(p) = livecroot_mr(p) * curmr_ratio
livecroot_xsmr(p) = livecroot_mr(p) - livecroot_curmr(p)
! no allocation when available c is negative
availc(p) = max(availc(p),0.0_r8)
! test for an xsmrpool deficit
if (xsmrpool(p) < 0.0_r8) then
! Running a deficit in the xsmrpool, so the first priority is to let
! some availc from this timestep accumulate in xsmrpool.
! Determine rate of recovery for xsmrpool deficit
xsmrpool_recover(p) = -xsmrpool(p)/(dayscrecover*86400.0_r8)
if (xsmrpool_recover(p) < availc(p)) then
! available carbon reduced by amount for xsmrpool recovery
availc(p) = availc(p) - xsmrpool_recover(p)
else
! all of the available carbon goes to xsmrpool recovery
xsmrpool_recover(p) = availc(p)
availc(p) = 0.0_r8
end if
cpool_to_xsmrpool(p) = xsmrpool_recover(p)
end if
f1 = froot_leaf(ivt(p))
f2 = croot_stem(ivt(p))
! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0,
! constrained so that it does not go lower than 0.2 (under negative annsum_npp)
! This variable allocation is only for trees. Shrubs have a constant
! allocation as specified in the pft-physiology file. The value is also used
! as a trigger here: -1.0 means to use the dynamic allocation (trees).
if (stem_leaf(ivt(p)) == -1._r8) then
f3 = (2.7/(1.0+exp(-0.004*(annsum_npp(p) - 300.0)))) - 0.4
else
f3 = stem_leaf(ivt(p))
end if
f4 = flivewd(ivt(p))
g1 = grperc
g2 = grpnow
cnl = leafcn(ivt(p))
cnfr = frootcn(ivt(p))
cnlw = livewdcn(ivt(p))
cndw = deadwdcn(ivt(p))
! calculate f1 to f5 for prog crops following AgroIBIS subr phenocrop
#if (defined CROP)
f5 = 0._r8 ! continued intializations from above
if (ivt(p) >= npcropmin .and. croplive(p) == 1) then ! skip 2 generic crops
! same phases appear in subroutine CropPhenology
! Phase 1 completed:
! ==================
! if hui is less than the number of gdd needed for filling of grain
! leaf emergence also has to have taken place for lai changes to occur
! and carbon assimilation
! Next phase: leaf emergence to start of leaf decline
if (leafout(p) >= huileaf(p) .and. hui(p) < huigrain(p)) then
! allocation rules for crops based on maturity and linear decrease
! of amount allocated to roots over course of the growing season
if (peaklai(p) == 1) then ! lai at maximum allowed
arepr(p) = 0._r8
aleaf(p) = 1.e-5_r8
astem(p) = 0._r8
aroot(p) = 1._r8 - arepr(p) - aleaf(p) - astem(p)
else
arepr(p) = 0._r8
aroot(p) = max(0._r8, min(1._r8, arooti(ivt(p)) - &
(arooti(ivt(p)) - arootf(ivt(p))) * &
min(1._r8, hui(p)/gddmaturity(p))))
fleaf = fleafi(ivt(p)) * (exp(-bfact(ivt(p))) - &
exp(-bfact(ivt(p))*hui(p)/huigrain(p))) / &
(exp(-bfact(ivt(p)))-1) ! fraction alloc to leaf (from J Norman alloc curve)
aleaf(p) = max(1.e-5_r8, (1._r8 - aroot(p)) * fleaf)
astem(p) = 1._r8 - arepr(p) - aleaf(p) - aroot(p)
end if
! AgroIBIS included here an immediate adjustment to aleaf & astem if the
! predicted lai from the above allocation coefficients exceeded laimx.
! We have decided to live with lais slightly higher than laimx by
! enforcing the cap in the following tstep through the peaklai logic above.
astemi(p) = astem(p) ! save for use by equations after shift
aleafi(p) = aleaf(p) ! to reproductive phenology stage begins
! Phase 2 completed:
! ==================
! shift allocation either when enough gdd are accumulated or maximum number
! of days has elapsed since planting
else if (hui(p) >= huigrain(p)) then
aroot(p) = max(0._r8, min(1._r8, arooti(ivt(p)) - &
(arooti(ivt(p)) - arootf(ivt(p))) * min(1._r8, hui(p)/gddmaturity(p))))
if (astemi(p) > astemf(ivt(p))) then
astem(p) = max(0._r8, max(astemf(ivt(p)), astem(p) * &
(1._r8 - min((hui(p)- &
huigrain(p))/((gddmaturity(p)*declfact(ivt(p)))- &
huigrain(p)),1._r8)**allconss(ivt(p)) )))
end if
if (aleafi(p) > aleaff(ivt(p))) then
aleaf(p) = max(1.e-5_r8, max(aleaff(ivt(p)), aleaf(p) * &
(1._r8 - min((hui(p)- &
huigrain(p))/((gddmaturity(p)*declfact(ivt(p)))- &
huigrain(p)),1._r8)**allconsl(ivt(p)) )))
end if
arepr(p) = 1._r8 - aroot(p) - astem(p) - aleaf(p)
astem(p) = astem(p)+arepr(p)
arepr(p) = 0._r8
else ! pre emergence
aleaf(p) = 1.e-5_r8 ! allocation coefficients should be irrelevant
astem(p) = 0._r8 ! because crops have no live carbon pools;
aroot(p) = 0._r8 ! this applies to this "else" and to the "else"
end if ! a few lines down
f1 = aroot(p) / aleaf(p)
f3 = astem(p) / aleaf(p)
f5 = arepr(p) / aleaf(p)
g1 = 0.25_r8
else if (ivt(p) >= npcropmin) then ! skip 2 generic crops
f1 = 0._r8
f3 = 0._r8
f5 = 0._r8
g1 = 0.25_r8
end if
#endif
write(6,*) 'CNAllocation, check n_allometry'
! based on available C, use constant allometric relationships to
! determine N requirements
if (woody(ivt(p)) == 1.0_r8) then
c_allometry(p) = (1._r8+g1)*(1._r8+f1+f3*(1._r8+f2))
n_allometry(p) = 1._r8/cnl + f1/cnfr + (f3*f4*(1._r8+f2))/cnlw + &
(f3*(1._r8-f4)*(1._r8+f2))/cndw
write(6,*) 'if (woody(ivt(p)) == 1.0_r8) n_allometry(',p,')=',n_allometry(p)
#if (defined CROP)
else if (ivt(p) >= npcropmin) then ! skip generic crops
c_allometry(p) = (1._r8+g1)*(1._r8+f1+f3*(1._r8+f2))
n_allometry(p) = 1._r8/cnl + f1/cnfr + (f3*f4*(1._r8+f2))/cnlw + &
(f3*(1._r8-f4)*(1._r8+f2))/cndw
write(6,*) 'else if (ivt(p) >= npcropmin) n_allometry(',p,')=',n_allometry(p)
write(6,*) 'cnl = leafcn(',ivt(p),')=',leafcn(ivt(p))
write(6,*) 'cnlw = livewdcn(',ivt(p),')=',livewdcn(ivt(p))
write(6,*) 'cnfr = frootcn(',ivt(p),')=',frootcn(ivt(p))
write(6,*) 'cndw = deadwdcn(',ivt(p),')=',deadwdcn(ivt(p))
write(6,*) 'f4 = flivewd(',ivt(p),')=',flivewd(ivt(p))
write(6,*) 'f1=',f1
write(6,*) 'f2=',f2
write(6,*) 'f3=',f3
write(6,*) 'f5=',f5
#endif
else
c_allometry(p) = 1._r8+g1+f1+f1*g1
n_allometry(p) = 1._r8/cnl + f1/cnfr
write(6,*) 'else n_allometry(',p,')=',n_allometry(p)
end if
plant_ndemand(p) = availc(p)*(n_allometry(p)/c_allometry(p))
write(6,*) 'CNAllocation, check plant_ndemand first'
write(6,*) 'plant_ndemand(',p,')=',plant_ndemand(p)
write(6,*) 'availc(',p,')=',availc(p)
write(6,*) 'n_allometry(',p,')=',n_allometry(p)
write(6,*) 'c_allometry(',p,')=',c_allometry(p)
! retranslocated N deployment depends on seasonal cycle of potential GPP
! (requires one year run to accumulate demand)
tempsum_potential_gpp(p) = tempsum_potential_gpp(p) + gpp(p)
! Adding the following line to carry max retransn info to CN Annual Update
tempmax_retransn(p) = max(tempmax_retransn(p),retransn(p))
if (annsum_potential_gpp(p) > 0.0_r8) then
avail_retransn(p) = (annmax_retransn(p)/2.0)*(gpp(p)/annsum_potential_gpp(p))/dt
else
avail_retransn(p) = 0.0_r8
end if
! make sure available retrans N doesn't exceed storage
avail_retransn(p) = min(avail_retransn(p), retransn(p)/dt)
! modify plant N demand according to the availability of
! retranslocated N
! take from retransn pool at most the flux required to meet
! plant ndemand
if (plant_ndemand(p) > avail_retransn(p)) then
retransn_to_npool(p) = avail_retransn(p)
else
retransn_to_npool(p) = plant_ndemand(p)
end if
plant_ndemand(p) = plant_ndemand(p) - retransn_to_npool(p)
write(6,*) 'CNAllocation, check plant_ndemand second time'
write(6,*) 'retransn_to_npool(',p,')=',retransn_to_npool(p)
write(6,*) 'CNAllocation, plant_ndemand(',p,')=',plant_ndemand(p)
end do ! end pft loop
! now use the p2c routine to get the column-averaged plant_ndemand
allocate(col_plant_ndemand(lbc:ubc))
call p2c(num_soilc,filter_soilc,plant_ndemand,col_plant_ndemand)
! column loop to resolve plant/heterotroph competition for mineral N
do fc=1,num_soilc
c = filter_soilc(fc)
sum_ndemand = col_plant_ndemand(c) + potential_immob(c)
if (sum_ndemand*dt < sminn(c)) then
! N availability is not limiting immobilization of plant
! uptake, and both can proceed at their potential rates
nlimit = 0
fpi(c) = 1.0_r8
actual_immob(c) = potential_immob(c)
sminn_to_plant(c) = col_plant_ndemand(c)
! under conditions of excess N, some proportion is asusmed to
! be lost to denitrification, in addition to the constant
! proportion lost in the decomposition pathways
sminn_to_denit_excess(c) = bdnr*((sminn(c)/dt) - sum_ndemand)
else
#if (!defined SUPLN)
! N availability can not satisfy the sum of immobilization and
! plant growth demands, so these two demands compete for available
! soil mineral N resource.
nlimit = 1
if (sum_ndemand > 0.0_r8) then
actual_immob(c) = (sminn(c)/dt)*(potential_immob(c) / sum_ndemand)
else
actual_immob(c) = 0.0_r8
end if
if (potential_immob(c) > 0.0_r8) then
fpi(c) = actual_immob(c) / potential_immob(c)
else
fpi(c) = 0.0_r8
end if
sminn_to_plant(c) = (sminn(c)/dt) - actual_immob(c)
#else
! this code block controls the addition of N to sminn pool
! to eliminate any N limitation, when SUPLN is set. This lets the
! model behave essentially as a carbon-only model, but with the
! benefit of keeping trrack of the N additions needed to
! eliminate N limitations, so there is still a diagnostic quantity
! that describes the degree of N limitation at steady-state.
nlimit = 1
fpi(c) = 1.0_r8
actual_immob(c) = potential_immob(c)
sminn_to_plant(c) = col_plant_ndemand(c)
supplement_to_sminn(c) = sum_ndemand - (sminn(c)/dt)
#endif
end if
! calculate the fraction of potential growth that can be
! acheived with the N available to plants
if (col_plant_ndemand(c) > 0.0_r8) then
fpg(c) = sminn_to_plant(c) / col_plant_ndemand(c)
else
fpg(c) = 1.0_r8
end if
end do ! end of column loop
! start new pft loop to distribute the available N between the
! competing pfts on the basis of relative demand, and allocate C and N to
! new growth and storage
do fp=1,num_soilp
p = filter_soilp(fp)
c = pcolumn(p)
! set some local allocation variables
f1 = froot_leaf(ivt(p))
f2 = croot_stem(ivt(p))
! modified wood allocation to be 2.2 at npp=800 gC/m2/yr, 0.2 at npp=0,
! constrained so that it does not go lower than 0.2 (under negative annsum_npp)
! There was an error in this formula in previous version, where the coefficient
! was 0.004 instead of 0.0025.
! This variable allocation is only for trees. Shrubs have a constant
! allocation as specified in the pft-physiology file. The value is also used
! as a trigger here: -1.0 means to use the dynamic allocation (trees).
if (stem_leaf(ivt(p)) == -1._r8) then
f3 = (2.7/(1.0+exp(-0.004*(annsum_npp(p) - 300.0)))) - 0.4
else
f3 = stem_leaf(ivt(p))
end if
f4 = flivewd(ivt(p))
g1 = grperc
g2 = grpnow
cnl = leafcn(ivt(p))
cnfr = frootcn(ivt(p))
cnlw = livewdcn(ivt(p))
cndw = deadwdcn(ivt(p))
fcur = fcur2(ivt(p))
#if (defined CROP)
if (ivt(p) >= npcropmin .and. croplive(p) == 1) then ! skip 2 generic crops
f1 = aroot(p) / aleaf(p)
f3 = astem(p) / aleaf(p)
f5 = arepr(p) / aleaf(p)
g1 = 0.25_r8
else if (ivt(p) >= npcropmin) then ! skip 2 generic crops
f1 = 0._r8
f3 = 0._r8
f5 = 0._r8
g1 = 0.25_r8
end if
cng = graincn(ivt(p))
#endif
! increase fcur linearly with ndays_active, until fcur reaches 1.0 at
! ndays_active = 365. This prevents the continued storage of C and N.
! turning off this correction (PET, 12/11/03), instead using bgtr in
! phenology algorithm.
!fcur = fcur + (1._r8 - fcur)*lgsf(p)
sminn_to_npool(p) = plant_ndemand(p) * fpg(c)
plant_nalloc(p) = sminn_to_npool(p) + retransn_to_npool(p)
! calculate the associated carbon allocation, and the excess
! carbon flux that must be accounted for through downregulation
plant_calloc(p) = plant_nalloc(p) * (c_allometry(p)/n_allometry(p))
excess_cflux(p) = availc(p) - plant_calloc(p)
! reduce gpp fluxes due to N limitation
if (gpp(p) > 0.0_r8) then
downreg(p) = excess_cflux(p)/gpp(p)
psnsun_to_cpool(p) = psnsun_to_cpool(p)*(1._r8 - downreg(p))
psnshade_to_cpool(p) = psnshade_to_cpool(p)*(1._r8 - downreg(p))
#if (defined C13)
c13_psnsun_to_cpool(p) = c13_psnsun_to_cpool(p)*(1._r8 - downreg(p))
c13_psnshade_to_cpool(p) = c13_psnshade_to_cpool(p)*(1._r8 - downreg(p))
#endif
end if
! calculate the amount of new leaf C dictated by these allocation
! decisions, and calculate the daily fluxes of C and N to current
! growth and storage pools
! fcur is the proportion of this day's growth that is displayed now,
! the remainder going into storage for display next year through the
! transfer pools
nlc = plant_calloc(p) / c_allometry(p)
write(6,*) 'in CNAllocation, nlc=',nlc,'fcur=',fcur
write(6,*) 'f1=',f1,'f2=',f2,'f3=',f3,'f4=',f4,'f5=',f5
cpool_to_leafc(p) = nlc * fcur
cpool_to_leafc_storage(p) = nlc * (1._r8 - fcur)
cpool_to_frootc(p) = nlc * f1 * fcur
cpool_to_frootc_storage(p) = nlc * f1 * (1._r8 - fcur)
if (woody(ivt(p)) == 1._r8) then
cpool_to_livestemc(p) = nlc * f3 * f4 * fcur
cpool_to_livestemc_storage(p) = nlc * f3 * f4 * (1._r8 - fcur)
cpool_to_deadstemc(p) = nlc * f3 * (1._r8 - f4) * fcur
cpool_to_deadstemc_storage(p) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur)
cpool_to_livecrootc(p) = nlc * f2 * f3 * f4 * fcur
cpool_to_livecrootc_storage(p) = nlc * f2 * f3 * f4 * (1._r8 - fcur)
cpool_to_deadcrootc(p) = nlc * f2 * f3 * (1._r8 - f4) * fcur
cpool_to_deadcrootc_storage(p) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur)
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
cpool_to_livestemc(p) = nlc * f3 * f4 * fcur
cpool_to_livestemc_storage(p) = nlc * f3 * f4 * (1._r8 - fcur)
cpool_to_deadstemc(p) = nlc * f3 * (1._r8 - f4) * fcur
cpool_to_deadstemc_storage(p) = nlc * f3 * (1._r8 - f4) * (1._r8 - fcur)
cpool_to_livecrootc(p) = nlc * f2 * f3 * f4 * fcur
cpool_to_livecrootc_storage(p) = nlc * f2 * f3 * f4 * (1._r8 - fcur)
cpool_to_deadcrootc(p) = nlc * f2 * f3 * (1._r8 - f4) * fcur
cpool_to_deadcrootc_storage(p) = nlc * f2 * f3 * (1._r8 - f4) * (1._r8 - fcur)
cpool_to_grainc(p) = nlc * f5 * fcur
cpool_to_grainc_storage(p) = nlc * f5 * (1._r8 -fcur)
end if
#endif
! corresponding N fluxes
npool_to_leafn(p) = (nlc / cnl) * fcur
npool_to_leafn_storage(p) = (nlc / cnl) * (1._r8 - fcur)
npool_to_frootn(p) = (nlc * f1 / cnfr) * fcur
npool_to_frootn_storage(p) = (nlc * f1 / cnfr) * (1._r8 - fcur)
if (woody(ivt(p)) == 1._r8) then
npool_to_livestemn(p) = (nlc * f3 * f4 / cnlw) * fcur
npool_to_livestemn_storage(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur)
npool_to_deadstemn(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur
npool_to_deadstemn_storage(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur)
npool_to_livecrootn(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur
npool_to_livecrootn_storage(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur)
npool_to_deadcrootn(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur
npool_to_deadcrootn_storage(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur)
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
npool_to_livestemn(p) = (nlc * f3 * f4 / cnlw) * fcur
npool_to_livestemn_storage(p) = (nlc * f3 * f4 / cnlw) * (1._r8 - fcur)
npool_to_deadstemn(p) = (nlc * f3 * (1._r8 - f4) / cndw) * fcur
npool_to_deadstemn_storage(p) = (nlc * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur)
npool_to_livecrootn(p) = (nlc * f2 * f3 * f4 / cnlw) * fcur
npool_to_livecrootn_storage(p) = (nlc * f2 * f3 * f4 / cnlw) * (1._r8 - fcur)
npool_to_deadcrootn(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * fcur
npool_to_deadcrootn_storage(p) = (nlc * f2 * f3 * (1._r8 - f4) / cndw) * (1._r8 - fcur)
npool_to_grainn(p) = (nlc * f5 / cng) * fcur
npool_to_grainn_storage(p) = (nlc * f5 / cng) * (1._r8 -fcur)
end if
#endif
! Calculate the amount of carbon that needs to go into growth
! respiration storage to satisfy all of the storage growth demands.
! Allows for the fraction of growth respiration that is released at the
! time of fixation, versus the remaining fraction that is stored for
! release at the time of display. Note that all the growth respiration
! fluxes that get released on a given timestep are calculated in growth_resp(),
! but that the storage of C for growth resp during display of transferred
! growth is assigned here.
gresp_storage = cpool_to_leafc_storage(p) + cpool_to_frootc_storage(p)
if (woody(ivt(p)) == 1._r8) then
gresp_storage = gresp_storage + cpool_to_livestemc_storage(p)
gresp_storage = gresp_storage + cpool_to_deadstemc_storage(p)
gresp_storage = gresp_storage + cpool_to_livecrootc_storage(p)
gresp_storage = gresp_storage + cpool_to_deadcrootc_storage(p)
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
gresp_storage = gresp_storage + cpool_to_livestemc_storage(p)
gresp_storage = gresp_storage + cpool_to_grainc_storage(p)
end if
#endif
cpool_to_gresp_storage(p) = gresp_storage * g1 * (1._r8 - g2)
end do ! end pft loop
deallocate(col_plant_ndemand)
#if (defined CROP)
deallocate(arepr)
deallocate(aroot)
#endif
end subroutine CNAllocation
#endif
end module CNAllocationMod
module CNAnnualUpdateMod 2,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNAnnualUpdateMod
!
! !DESCRIPTION:
! Module for updating annual summation variables
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public:: CNAnnualUpdate
!
! !REVISION HISTORY:
! 4/23/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNAnnualUpdate
!
! !INTERFACE:
subroutine CNAnnualUpdate(lbc, ubc, lbp, ubp, num_soilc, filter_soilc, & 1,16
num_soilp, filter_soilp)
!
! !DESCRIPTION:
! On the radiation time step, update annual summation variables
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size, get_days_per_year
use clm_varcon , only: secspday
use pft2colMod , only: p2c
!Yaqiong Lu add for coupling
use globals , only: dt,day_per_year
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: lbp, ubp ! pft bounds
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(ubp-lbp+1) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! 10/1/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
integer , pointer :: pcolumn(:) ! index into column level
! quantities
!
! local pointers to implicit in/out scalars
!
real(r8), pointer :: annsum_counter(:) ! seconds since last annual accumulator turnover
real(r8), pointer :: tempsum_potential_gpp(:) ! temporary annual sum of potential GPP
real(r8), pointer :: annsum_potential_gpp(:) ! annual sum of potential GPP
real(r8), pointer :: tempmax_retransn(:) ! temporary annual max of retranslocated N pool (gN/m2)
real(r8), pointer :: annmax_retransn(:) ! annual max of retranslocated N pool (gN/m2)
real(r8), pointer :: tempavg_t2m(:) ! temporary average 2m air temperature (K)
real(r8), pointer :: annavg_t2m(:) ! annual average 2m air temperature (K)
real(r8), pointer :: tempsum_npp(:) ! temporary sum NPP (gC/m2/yr)
real(r8), pointer :: annsum_npp(:) ! annual sum NPP (gC/m2/yr)
real(r8), pointer :: cannsum_npp(:) ! column annual sum NPP (gC/m2/yr)
real(r8), pointer :: cannavg_t2m(:) !annual average of 2m air temperature, averaged from pft-level (K)
#if (defined CNDV)
real(r8), pointer :: tempsum_litfall(:) ! temporary sum litfall (gC/m2/yr)
real(r8), pointer :: annsum_litfall(:) ! annual sum litfall (gC/m2/yr)
#endif
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
character*256 :: msg
! real(r8):: dt ! radiation time step (seconds)
!EOP
!-----------------------------------------------------------------------
! assign local pointers to derived type arrays
annsum_counter => clm3%g%l%c%cps%annsum_counter
tempsum_potential_gpp => clm3%g%l%c%p%pepv%tempsum_potential_gpp
annsum_potential_gpp => clm3%g%l%c%p%pepv%annsum_potential_gpp
tempmax_retransn => clm3%g%l%c%p%pepv%tempmax_retransn
annmax_retransn => clm3%g%l%c%p%pepv%annmax_retransn
tempavg_t2m => clm3%g%l%c%p%pepv%tempavg_t2m
annavg_t2m => clm3%g%l%c%p%pepv%annavg_t2m
tempsum_npp => clm3%g%l%c%p%pepv%tempsum_npp
annsum_npp => clm3%g%l%c%p%pepv%annsum_npp
cannsum_npp => clm3%g%l%c%cps%cannsum_npp
cannavg_t2m => clm3%g%l%c%cps%cannavg_t2m
#if (defined CNDV)
tempsum_litfall => clm3%g%l%c%p%pepv%tempsum_litfall
annsum_litfall => clm3%g%l%c%p%pepv%annsum_litfall
#endif
pcolumn => clm3%g%l%c%p%column
! set time steps
! dt = real( get_step_size(), r8 )
call CLMDebug('CNannual-assign done')
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
annsum_counter(c) = annsum_counter(c) + dt
end do
write(msg,*) 'annsum_counter(filter_soilc(1))=',annsum_counter(filter_soilc(1))
call CLMDebug(msg)
call CLMDebug('CNannual-mark1')
#if (defined CNDV) || (defined CROP)
! In the future -- ONLY use this code and remove the similar part below
! So the #ifdef on CNDV and CROP would be removed
if (annsum_counter(filter_soilc(1)) >= day_per_year * secspday) then ! new (slevis)
#endif
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
#if (!defined CNDV) && (!defined CROP)
! In the future -- REMOVE this code and use the equivalent code above always
c = pcolumn(p) ! old (slevis)
if (annsum_counter(c) >= day_per_year * secspday) then ! old (slevis)
#endif
call CLMDebug('CNannual-mark2')
! update annual plant ndemand accumulator
annsum_potential_gpp(p) = tempsum_potential_gpp(p)
tempsum_potential_gpp(p) = 0._r8
call CLMDebug('CNannual-mark3')
! update annual total N retranslocation accumulator
annmax_retransn(p) = tempmax_retransn(p)
tempmax_retransn(p) = 0._r8
call CLMDebug('CNannual-mark4')
! update annual average 2m air temperature accumulator
annavg_t2m(p) = tempavg_t2m(p)
tempavg_t2m(p) = 0._r8
write(6,*) 'CNAnnualUpdateMod, annavg_t2m(',p,')=',annavg_t2m(p)
call CLMDebug('CNannual-mark5')
! update annual NPP accumulator, convert to annual total
annsum_npp(p) = tempsum_npp(p) * dt
tempsum_npp(p) = 0._r8
write(6,*) 'CNAnnualUpdateMod, annsum_npp(',p,')=',annsum_npp(p)
call CLMDebug('CNannual-mark6')
#if (defined CNDV)
! update annual litfall accumulator, convert to annual total
annsum_litfall(p) = tempsum_litfall(p) * dt
tempsum_litfall(p) = 0._r8
#endif
#if (!defined CNDV) && (!defined CROP)
end if ! old (slevis)
#endif
end do
! use p2c routine to get selected column-average pft-level fluxes and states
call CLMDebug('CNannual-call p2c')
call p2c(num_soilc, filter_soilc, annsum_npp, cannsum_npp)
call p2c(num_soilc, filter_soilc, annavg_t2m, cannavg_t2m)
#if (defined CNDV) || (defined CROP)
end if ! new (slevis)
#endif
call CLMDebug('CNannual-mark4')
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
if (annsum_counter(c) >= day_per_year * secspday) annsum_counter(c) = 0._r8
end do
end subroutine CNAnnualUpdate
!-----------------------------------------------------------------------
#endif
end module CNAnnualUpdateMod
module CNBalanceCheckMod 2,2
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNBalanceCheckMod
!
! !DESCRIPTION:
! Module for carbon mass balance checking.
!
! !USES:
! use abortutils , only: endrun
use shr_kind_mod, only: r8 => shr_kind_r8
! use clm_varctl , only: iulog
use module_cam_support, only: endrun
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: BeginCBalance
public :: BeginNBalance
public :: CBalanceCheck
public :: NBalanceCheck
!
! !REVISION HISTORY:
! 4/23/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: BeginCBalance
!
! !INTERFACE:
subroutine BeginCBalance(lbc, ubc, num_soilc, filter_soilc) 1,1
!
! !DESCRIPTION:
! On the radiation time step, calculate the beginning carbon balance for mass
! conservation checks.
!
! !USES:
use clmtype
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_soilc ! number of soil columns filter
integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! 2/4/05: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool
!
! local pointers to implicit out arrays
real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2)
!
! !OTHER LOCAL VARIABLES:
integer :: c ! indices
integer :: fc ! lake filter indices
!
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the column level
col_begcb => clm3%g%l%c%ccbal%begcb
totcolc => clm3%g%l%c%ccs%totcolc
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! calculate beginning column-level carbon balance,
! for mass conservation check
col_begcb(c) = totcolc(c)
end do ! end of columns loop
end subroutine BeginCBalance
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: BeginNBalance
!
! !INTERFACE:
subroutine BeginNBalance(lbc, ubc, num_soilc, filter_soilc) 1,1
!
! !DESCRIPTION:
! On the radiation time step, calculate the beginning nitrogen balance for mass
! conservation checks.
!
! !USES:
use clmtype
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_soilc ! number of soil columns filter
integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! 2/4/05: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg
!
! local pointers to implicit out arrays
real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2)
!
! !OTHER LOCAL VARIABLES:
integer :: c ! indices
integer :: fc ! lake filter indices
!
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the column level
col_begnb => clm3%g%l%c%cnbal%begnb
totcoln => clm3%g%l%c%cns%totcoln
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! calculate beginning column-level nitrogen balance,
! for mass conservation check
col_begnb(c) = totcoln(c)
end do ! end of columns loop
end subroutine BeginNBalance
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CBalanceCheck
!
! !INTERFACE:
subroutine CBalanceCheck(lbc, ubc, num_soilc, filter_soilc) 1,3
!
! !DESCRIPTION:
! On the radiation time step, perform carbon mass conservation check for column and pft
!
! !USES:
use clmtype
use globals, only: dt
! use clm_time_manager, only: get_step_size
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! 12/9/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arrays
real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool
real(r8), pointer :: gpp(:) ! (gC/m2/s) gross primary production
real(r8), pointer :: er(:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic
real(r8), pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss
real(r8), pointer :: col_hrv_xsmrpool_to_atm(:) ! excess MR pool harvest mortality (gC/m2/s)
real(r8), pointer :: dwt_closs(:) ! (gC/m2/s) total carbon loss from product pools and conversion
real(r8), pointer :: product_closs(:) ! (gC/m2/s) total wood product carbon loss
!
! local pointers to implicit out arrays
real(r8), pointer :: col_cinputs(:) ! (gC/m2/s) total column-level carbon inputs (for balance check)
real(r8), pointer :: col_coutputs(:) ! (gC/m2/s) total column-level carbon outputs (for balance check)
real(r8), pointer :: col_begcb(:) ! carbon mass, beginning of time step (gC/m**2)
real(r8), pointer :: col_endcb(:) ! carbon mass, end of time step (gC/m**2)
real(r8), pointer :: col_errcb(:) ! carbon balance error for the timestep (gC/m**2)
!
! !OTHER LOCAL VARIABLES:
integer :: c,err_index ! indices
integer :: fc ! lake filter indices
logical :: err_found ! error flag
! real(r8):: dt ! radiation time step (seconds)
!EOP
!-----------------------------------------------------------------------
! assign local pointers to column-level arrays
totcolc => clm3%g%l%c%ccs%totcolc
gpp => clm3%g%l%c%ccf%pcf_a%gpp
er => clm3%g%l%c%ccf%er
col_fire_closs => clm3%g%l%c%ccf%col_fire_closs
col_hrv_xsmrpool_to_atm => clm3%g%l%c%ccf%pcf_a%hrv_xsmrpool_to_atm
dwt_closs => clm3%g%l%c%ccf%dwt_closs
product_closs => clm3%g%l%c%ccf%product_closs
col_cinputs => clm3%g%l%c%ccf%col_cinputs
col_coutputs => clm3%g%l%c%ccf%col_coutputs
col_begcb => clm3%g%l%c%ccbal%begcb
col_endcb => clm3%g%l%c%ccbal%endcb
col_errcb => clm3%g%l%c%ccbal%errcb
! set time steps
!ylu removed
! dt = real( get_step_size(), r8 )
err_found = .false.
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! calculate the total column-level carbon storage, for mass conservation check
col_endcb(c) = totcolc(c)
! calculate total column-level inputs
col_cinputs(c) = gpp(c)
! calculate total column-level outputs
! er = ar + hr, col_fire_closs includes pft-level fire losses
col_coutputs(c) = er(c) + col_fire_closs(c) + dwt_closs(c) + product_closs(c) + col_hrv_xsmrpool_to_atm(c)
! calculate the total column-level carbon balance error for this time step
col_errcb(c) = (col_cinputs(c) - col_coutputs(c))*dt - &
(col_endcb(c) - col_begcb(c))
! check for significant errors
if (abs(col_errcb(c)) > 1e-8_r8) then
err_found = .true.
err_index = c
end if
end do ! end of columns loop
if (err_found) then
c = err_index
write(6,*)'column cbalance error = ', col_errcb(c), c
write(6,*)'begcb = ',col_begcb(c)
write(6,*)'endcb = ',col_endcb(c)
write(6,*)'delta store = ',col_endcb(c)-col_begcb(c)
write(6,*)'input mass = ',col_cinputs(c)*dt
write(6,*)'output mass = ',col_coutputs(c)*dt
write(6,*)'net flux = ',(col_cinputs(c)-col_coutputs(c))*dt
write(6,*)'nee = ',clm3%g%l%c%ccf%nee(c) * dt
write(6,*)'gpp = ',gpp(c) * dt
write(6,*)'er = ',er(c) * dt
write(6,*)'col_fire_closs = ',col_fire_closs(c) * dt
write(6,*)'col_hrv_xsmrpool_to_atm = ',col_hrv_xsmrpool_to_atm(c) * dt
write(6,*)'dwt_closs = ',dwt_closs(c) * dt
write(6,*)'product_closs = ',product_closs(c) * dt
call endrun()
end if
end subroutine CBalanceCheck
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: NBalanceCheck
!
! !INTERFACE:
subroutine NBalanceCheck(lbc, ubc, num_soilc, filter_soilc) 1,3
!
! !DESCRIPTION:
! On the radiation time step, perform nitrogen mass conservation check
! for column and pft
!
! !USES:
use clmtype
use globals, only: dt
! use clm_time_manager, only: get_step_size
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! 12/9/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arrays
real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg
real(r8), pointer :: ndep_to_sminn(:) ! atmospheric N deposition to soil mineral N (gN/m2/s)
real(r8), pointer :: nfix_to_sminn(:) ! symbiotic/asymbiotic N fixation to soil mineral N (gN/m2/s)
real(r8), pointer :: supplement_to_sminn(:) ! supplemental N supply (gN/m2/s)
real(r8), pointer :: denit(:) ! total rate of denitrification (gN/m2/s)
real(r8), pointer :: sminn_leached(:) ! soil mineral N pool loss to leaching (gN/m2/s)
real(r8), pointer :: col_fire_nloss(:) ! total column-level fire N loss (gN/m2/s)
real(r8), pointer :: dwt_nloss(:) ! (gN/m2/s) total nitrogen loss from product pools and conversion
real(r8), pointer :: product_nloss(:) ! (gN/m2/s) total wood product nitrogen loss
!
! local pointers to implicit in/out arrays
!
! local pointers to implicit out arrays
real(r8), pointer :: col_ninputs(:) ! column-level N inputs (gN/m2/s)
real(r8), pointer :: col_noutputs(:) ! column-level N outputs (gN/m2/s)
real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2)
real(r8), pointer :: col_endnb(:) ! nitrogen mass, end of time step (gN/m**2)
real(r8), pointer :: col_errnb(:) ! nitrogen balance error for the timestep (gN/m**2)
!
! !OTHER LOCAL VARIABLES:
integer :: c,err_index ! indices
integer :: fc ! lake filter indices
logical :: err_found ! error flag
! real(r8):: dt ! radiation time step (seconds)
!EOP
!-----------------------------------------------------------------------
! assign local pointers to column-level arrays
totcoln => clm3%g%l%c%cns%totcoln
ndep_to_sminn => clm3%g%l%c%cnf%ndep_to_sminn
nfix_to_sminn => clm3%g%l%c%cnf%nfix_to_sminn
supplement_to_sminn => clm3%g%l%c%cnf%supplement_to_sminn
denit => clm3%g%l%c%cnf%denit
sminn_leached => clm3%g%l%c%cnf%sminn_leached
col_fire_nloss => clm3%g%l%c%cnf%col_fire_nloss
dwt_nloss => clm3%g%l%c%cnf%dwt_nloss
product_nloss => clm3%g%l%c%cnf%product_nloss
col_ninputs => clm3%g%l%c%cnf%col_ninputs
col_noutputs => clm3%g%l%c%cnf%col_noutputs
col_begnb => clm3%g%l%c%cnbal%begnb
col_endnb => clm3%g%l%c%cnbal%endnb
col_errnb => clm3%g%l%c%cnbal%errnb
! set time steps
! dt = real( get_step_size(), r8 ) !already set in globals module --ylu 10/27/10
err_found = .false.
! column loop
do fc = 1,num_soilc
c=filter_soilc(fc)
! calculate the total column-level nitrogen storage, for mass conservation check
col_endnb(c) = totcoln(c)
! calculate total column-level inputs
col_ninputs(c) = ndep_to_sminn(c) + nfix_to_sminn(c) + supplement_to_sminn(c)
! calculate total column-level outputs
col_noutputs(c) = denit(c) + sminn_leached(c) + col_fire_nloss(c) + dwt_nloss(c) + product_nloss(c)
! calculate the total column-level nitrogen balance error for this time step
col_errnb(c) = (col_ninputs(c) - col_noutputs(c))*dt - &
(col_endnb(c) - col_begnb(c))
if (abs(col_errnb(c)) > 1e-8_r8) then
err_found = .true.
err_index = c
end if
end do ! end of columns loop
if (err_found) then
c = err_index
write(6,*)'column nbalance error = ', col_errnb(c), c
write(6,*)'begnb = ',col_begnb(c)
write(6,*)'endnb = ',col_endnb(c)
write(6,*)'delta store = ',col_endnb(c)-col_begnb(c)
write(6,*)'input mass = ',col_ninputs(c)*dt
write(6,*)'output mass = ',col_noutputs(c)*dt
write(6,*)'net flux = ',(col_ninputs(c)-col_noutputs(c))*dt
call endrun()
end if
end subroutine NBalanceCheck
!-----------------------------------------------------------------------
#endif
end module CNBalanceCheckMod
module CNCStateUpdate1Mod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CStateUpdate1Mod
!
! !DESCRIPTION:
! Module for carbon state variable update, non-mortality fluxes.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
!
! !PUBLIC MEMBER FUNCTIONS:
public:: CStateUpdate1
public:: CStateUpdate0
!
! !REVISION HISTORY:
! 4/23/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CStateUpdate0
!
! !INTERFACE:
subroutine CStateUpdate0(num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! On the radiation time step, update cpool carbon state
!
! !USES:
use clmtype
!ylu removed
! use clm_time_manager, only: get_step_size
use globals, only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 7/1/05: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
real(r8), pointer :: psnshade_to_cpool(:)
real(r8), pointer :: psnsun_to_cpool(:)
!
! local pointers to implicit in/out arrays
real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool
! !OTHER LOCAL VARIABLES:
integer :: p ! indices
integer :: fp ! lake filter indices
! real(r8):: dt ! radiation time step (seconds)
!
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the pft level
cpool => clm3%g%l%c%p%pcs%cpool
psnshade_to_cpool => clm3%g%l%c%p%pcf%psnshade_to_cpool
psnsun_to_cpool => clm3%g%l%c%p%pcf%psnsun_to_cpool
! set time steps
! dt = real( get_step_size(), r8 )
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! gross photosynthesis fluxes
cpool(p) = cpool(p) + psnsun_to_cpool(p)*dt
cpool(p) = cpool(p) + psnshade_to_cpool(p)*dt
end do
end subroutine CStateUpdate0
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CStateUpdate1
!
! !INTERFACE:
subroutine CStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,3
!
! !DESCRIPTION:
! On the radiation time step, update all the prognostic carbon state
! variables (except for gap-phase mortality and fire fluxes)
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size
use globals, only: dt
#if (defined CROP)
use pftvarcon , only: npcropmin
#endif
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 8/1/03: Created by Peter Thornton
! 12/5/03, Peter Thornton: Added livewood turnover fluxes
!
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
!
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
real(r8), pointer :: cwdc_to_litr2c(:)
real(r8), pointer :: cwdc_to_litr3c(:)
#if (defined CROP)
integer , pointer :: harvdate(:) ! harvest date
real(r8), pointer :: xsmrpool_to_atm(:)
real(r8), pointer :: grainc_to_litr1c(:)
real(r8), pointer :: grainc_to_litr2c(:)
real(r8), pointer :: grainc_to_litr3c(:)
real(r8), pointer :: livestemc_to_litr1c(:)
real(r8), pointer :: livestemc_to_litr2c(:)
real(r8), pointer :: livestemc_to_litr3c(:)
#endif
real(r8), pointer :: frootc_to_litr1c(:)
real(r8), pointer :: frootc_to_litr2c(:)
real(r8), pointer :: frootc_to_litr3c(:)
real(r8), pointer :: leafc_to_litr1c(:)
real(r8), pointer :: leafc_to_litr2c(:)
real(r8), pointer :: leafc_to_litr3c(:)
real(r8), pointer :: litr1_hr(:)
real(r8), pointer :: litr1c_to_soil1c(:)
real(r8), pointer :: litr2_hr(:)
real(r8), pointer :: litr2c_to_soil2c(:)
real(r8), pointer :: litr3_hr(:)
real(r8), pointer :: litr3c_to_soil3c(:)
real(r8), pointer :: soil1_hr(:)
real(r8), pointer :: soil1c_to_soil2c(:)
real(r8), pointer :: soil2_hr(:)
real(r8), pointer :: soil2c_to_soil3c(:)
real(r8), pointer :: soil3_hr(:)
real(r8), pointer :: soil3c_to_soil4c(:)
real(r8), pointer :: soil4_hr(:)
real(r8), pointer :: col_ctrunc(:) ! (gC/m2) column-level sink for C truncation
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:)
real(r8), pointer :: deadstemc_xfer_to_deadstemc(:)
real(r8), pointer :: frootc_xfer_to_frootc(:)
real(r8), pointer :: leafc_xfer_to_leafc(:)
real(r8), pointer :: livecrootc_xfer_to_livecrootc(:)
real(r8), pointer :: livestemc_xfer_to_livestemc(:)
real(r8), pointer :: cpool_to_xsmrpool(:)
real(r8), pointer :: cpool_to_deadcrootc(:)
real(r8), pointer :: cpool_to_deadcrootc_storage(:)
real(r8), pointer :: cpool_to_deadstemc(:)
real(r8), pointer :: cpool_to_deadstemc_storage(:)
real(r8), pointer :: cpool_to_frootc(:)
real(r8), pointer :: cpool_to_frootc_storage(:)
real(r8), pointer :: cpool_to_gresp_storage(:)
real(r8), pointer :: cpool_to_leafc(:)
real(r8), pointer :: cpool_to_leafc_storage(:)
real(r8), pointer :: cpool_to_livecrootc(:)
real(r8), pointer :: cpool_to_livecrootc_storage(:)
real(r8), pointer :: cpool_to_livestemc(:)
real(r8), pointer :: cpool_to_livestemc_storage(:)
real(r8), pointer :: deadcrootc_storage_to_xfer(:)
real(r8), pointer :: deadstemc_storage_to_xfer(:)
real(r8), pointer :: frootc_storage_to_xfer(:)
real(r8), pointer :: frootc_to_litter(:)
real(r8), pointer :: gresp_storage_to_xfer(:)
real(r8), pointer :: leafc_storage_to_xfer(:)
real(r8), pointer :: leafc_to_litter(:)
real(r8), pointer :: livecrootc_storage_to_xfer(:)
real(r8), pointer :: livecrootc_to_deadcrootc(:)
real(r8), pointer :: livestemc_storage_to_xfer(:)
real(r8), pointer :: livestemc_to_deadstemc(:)
real(r8), pointer :: livestem_mr(:)
real(r8), pointer :: froot_mr(:)
real(r8), pointer :: leaf_mr(:)
real(r8), pointer :: livecroot_mr(:)
real(r8), pointer :: livestem_curmr(:)
real(r8), pointer :: froot_curmr(:)
real(r8), pointer :: leaf_curmr(:)
real(r8), pointer :: livecroot_curmr(:)
real(r8), pointer :: livestem_xsmr(:)
real(r8), pointer :: froot_xsmr(:)
real(r8), pointer :: leaf_xsmr(:)
real(r8), pointer :: livecroot_xsmr(:)
real(r8), pointer :: cpool_deadcroot_gr(:)
real(r8), pointer :: cpool_deadcroot_storage_gr(:)
real(r8), pointer :: cpool_deadstem_gr(:)
real(r8), pointer :: cpool_deadstem_storage_gr(:)
real(r8), pointer :: cpool_froot_gr(:)
real(r8), pointer :: cpool_froot_storage_gr(:)
real(r8), pointer :: cpool_leaf_gr(:)
real(r8), pointer :: cpool_leaf_storage_gr(:)
real(r8), pointer :: cpool_livecroot_gr(:)
real(r8), pointer :: cpool_livecroot_storage_gr(:)
real(r8), pointer :: cpool_livestem_gr(:)
real(r8), pointer :: cpool_livestem_storage_gr(:)
real(r8), pointer :: transfer_deadcroot_gr(:)
real(r8), pointer :: transfer_deadstem_gr(:)
real(r8), pointer :: transfer_froot_gr(:)
real(r8), pointer :: transfer_leaf_gr(:)
real(r8), pointer :: transfer_livecroot_gr(:)
real(r8), pointer :: transfer_livestem_gr(:)
#if (defined CROP)
real(r8), pointer :: cpool_to_grainc(:)
real(r8), pointer :: cpool_to_grainc_storage(:)
real(r8), pointer :: grainc_storage_to_xfer(:)
real(r8), pointer :: livestemc_to_litter(:)
real(r8), pointer :: grainc_to_food(:)
real(r8), pointer :: grainc_xfer_to_grainc(:)
real(r8), pointer :: cpool_grain_gr(:)
real(r8), pointer :: cpool_grain_storage_gr(:)
real(r8), pointer :: transfer_grain_gr(:)
#endif
!
! local pointers to implicit in/out arrays
#if (defined CROP)
real(r8), pointer :: grainc(:)
real(r8), pointer :: grainc_storage(:)
real(r8), pointer :: grainc_xfer(:)
#endif
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: soil1c(:) ! (gC/m2) soil organic matter C (fast pool)
real(r8), pointer :: soil2c(:) ! (gC/m2) soil organic matter C (medium pool)
real(r8), pointer :: soil3c(:) ! (gC/m2) soil organic matter C (slow pool)
real(r8), pointer :: soil4c(:) ! (gC/m2) soil organic matter C (slowest pool)
real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool
real(r8), pointer :: xsmrpool(:) ! (gC/m2) execss maint resp C pool
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation
! local pointers for dynamic landcover fluxes and states
real(r8), pointer :: dwt_seedc_to_leaf(:)
real(r8), pointer :: dwt_seedc_to_deadstem(:)
real(r8), pointer :: dwt_frootc_to_litr1c(:)
real(r8), pointer :: dwt_frootc_to_litr2c(:)
real(r8), pointer :: dwt_frootc_to_litr3c(:)
real(r8), pointer :: dwt_livecrootc_to_cwdc(:)
real(r8), pointer :: dwt_deadcrootc_to_cwdc(:)
real(r8), pointer :: seedc(:)
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
! real(r8):: dt ! radiation time step (seconds)
!
!EOP
!-----------------------------------------------------------------------
! assign local pointers
woody => pftcon%woody
! assign local pointers at the column level
cwdc_to_litr2c => clm3%g%l%c%ccf%cwdc_to_litr2c
cwdc_to_litr3c => clm3%g%l%c%ccf%cwdc_to_litr3c
frootc_to_litr1c => clm3%g%l%c%ccf%frootc_to_litr1c
frootc_to_litr2c => clm3%g%l%c%ccf%frootc_to_litr2c
frootc_to_litr3c => clm3%g%l%c%ccf%frootc_to_litr3c
leafc_to_litr1c => clm3%g%l%c%ccf%leafc_to_litr1c
leafc_to_litr2c => clm3%g%l%c%ccf%leafc_to_litr2c
leafc_to_litr3c => clm3%g%l%c%ccf%leafc_to_litr3c
#if (defined CROP)
grainc_to_litr1c => clm3%g%l%c%ccf%grainc_to_litr1c
grainc_to_litr2c => clm3%g%l%c%ccf%grainc_to_litr2c
grainc_to_litr3c => clm3%g%l%c%ccf%grainc_to_litr3c
livestemc_to_litr1c => clm3%g%l%c%ccf%livestemc_to_litr1c
livestemc_to_litr2c => clm3%g%l%c%ccf%livestemc_to_litr2c
livestemc_to_litr3c => clm3%g%l%c%ccf%livestemc_to_litr3c
#endif
litr1_hr => clm3%g%l%c%ccf%litr1_hr
litr1c_to_soil1c => clm3%g%l%c%ccf%litr1c_to_soil1c
litr2_hr => clm3%g%l%c%ccf%litr2_hr
litr2c_to_soil2c => clm3%g%l%c%ccf%litr2c_to_soil2c
litr3_hr => clm3%g%l%c%ccf%litr3_hr
litr3c_to_soil3c => clm3%g%l%c%ccf%litr3c_to_soil3c
soil1_hr => clm3%g%l%c%ccf%soil1_hr
soil1c_to_soil2c => clm3%g%l%c%ccf%soil1c_to_soil2c
soil2_hr => clm3%g%l%c%ccf%soil2_hr
soil2c_to_soil3c => clm3%g%l%c%ccf%soil2c_to_soil3c
soil3_hr => clm3%g%l%c%ccf%soil3_hr
soil3c_to_soil4c => clm3%g%l%c%ccf%soil3c_to_soil4c
soil4_hr => clm3%g%l%c%ccf%soil4_hr
col_ctrunc => clm3%g%l%c%ccs%col_ctrunc
cwdc => clm3%g%l%c%ccs%cwdc
litr1c => clm3%g%l%c%ccs%litr1c
litr2c => clm3%g%l%c%ccs%litr2c
litr3c => clm3%g%l%c%ccs%litr3c
soil1c => clm3%g%l%c%ccs%soil1c
soil2c => clm3%g%l%c%ccs%soil2c
soil3c => clm3%g%l%c%ccs%soil3c
soil4c => clm3%g%l%c%ccs%soil4c
! new pointers for dynamic landcover
dwt_seedc_to_leaf => clm3%g%l%c%ccf%dwt_seedc_to_leaf
dwt_seedc_to_deadstem => clm3%g%l%c%ccf%dwt_seedc_to_deadstem
dwt_frootc_to_litr1c => clm3%g%l%c%ccf%dwt_frootc_to_litr1c
dwt_frootc_to_litr2c => clm3%g%l%c%ccf%dwt_frootc_to_litr2c
dwt_frootc_to_litr3c => clm3%g%l%c%ccf%dwt_frootc_to_litr3c
dwt_livecrootc_to_cwdc => clm3%g%l%c%ccf%dwt_livecrootc_to_cwdc
dwt_deadcrootc_to_cwdc => clm3%g%l%c%ccf%dwt_deadcrootc_to_cwdc
seedc => clm3%g%l%c%ccs%seedc
! assign local pointers at the pft level
ivt => clm3%g%l%c%p%itype
cpool_deadcroot_gr => clm3%g%l%c%p%pcf%cpool_deadcroot_gr
cpool_deadcroot_storage_gr => clm3%g%l%c%p%pcf%cpool_deadcroot_storage_gr
cpool_deadstem_gr => clm3%g%l%c%p%pcf%cpool_deadstem_gr
cpool_deadstem_storage_gr => clm3%g%l%c%p%pcf%cpool_deadstem_storage_gr
cpool_froot_gr => clm3%g%l%c%p%pcf%cpool_froot_gr
cpool_froot_storage_gr => clm3%g%l%c%p%pcf%cpool_froot_storage_gr
cpool_leaf_gr => clm3%g%l%c%p%pcf%cpool_leaf_gr
cpool_leaf_storage_gr => clm3%g%l%c%p%pcf%cpool_leaf_storage_gr
cpool_livecroot_gr => clm3%g%l%c%p%pcf%cpool_livecroot_gr
cpool_livecroot_storage_gr => clm3%g%l%c%p%pcf%cpool_livecroot_storage_gr
cpool_livestem_gr => clm3%g%l%c%p%pcf%cpool_livestem_gr
cpool_livestem_storage_gr => clm3%g%l%c%p%pcf%cpool_livestem_storage_gr
cpool_to_xsmrpool => clm3%g%l%c%p%pcf%cpool_to_xsmrpool
cpool_to_deadcrootc => clm3%g%l%c%p%pcf%cpool_to_deadcrootc
cpool_to_deadcrootc_storage => clm3%g%l%c%p%pcf%cpool_to_deadcrootc_storage
cpool_to_deadstemc => clm3%g%l%c%p%pcf%cpool_to_deadstemc
cpool_to_deadstemc_storage => clm3%g%l%c%p%pcf%cpool_to_deadstemc_storage
cpool_to_frootc => clm3%g%l%c%p%pcf%cpool_to_frootc
cpool_to_frootc_storage => clm3%g%l%c%p%pcf%cpool_to_frootc_storage
cpool_to_gresp_storage => clm3%g%l%c%p%pcf%cpool_to_gresp_storage
cpool_to_leafc => clm3%g%l%c%p%pcf%cpool_to_leafc
cpool_to_leafc_storage => clm3%g%l%c%p%pcf%cpool_to_leafc_storage
cpool_to_livecrootc => clm3%g%l%c%p%pcf%cpool_to_livecrootc
cpool_to_livecrootc_storage => clm3%g%l%c%p%pcf%cpool_to_livecrootc_storage
cpool_to_livestemc => clm3%g%l%c%p%pcf%cpool_to_livestemc
cpool_to_livestemc_storage => clm3%g%l%c%p%pcf%cpool_to_livestemc_storage
deadcrootc_storage_to_xfer => clm3%g%l%c%p%pcf%deadcrootc_storage_to_xfer
deadcrootc_xfer_to_deadcrootc => clm3%g%l%c%p%pcf%deadcrootc_xfer_to_deadcrootc
deadstemc_storage_to_xfer => clm3%g%l%c%p%pcf%deadstemc_storage_to_xfer
deadstemc_xfer_to_deadstemc => clm3%g%l%c%p%pcf%deadstemc_xfer_to_deadstemc
froot_mr => clm3%g%l%c%p%pcf%froot_mr
froot_curmr => clm3%g%l%c%p%pcf%froot_curmr
froot_xsmr => clm3%g%l%c%p%pcf%froot_xsmr
frootc_storage_to_xfer => clm3%g%l%c%p%pcf%frootc_storage_to_xfer
frootc_to_litter => clm3%g%l%c%p%pcf%frootc_to_litter
frootc_xfer_to_frootc => clm3%g%l%c%p%pcf%frootc_xfer_to_frootc
gresp_storage_to_xfer => clm3%g%l%c%p%pcf%gresp_storage_to_xfer
leaf_mr => clm3%g%l%c%p%pcf%leaf_mr
leaf_curmr => clm3%g%l%c%p%pcf%leaf_curmr
leaf_xsmr => clm3%g%l%c%p%pcf%leaf_xsmr
leafc_storage_to_xfer => clm3%g%l%c%p%pcf%leafc_storage_to_xfer
leafc_to_litter => clm3%g%l%c%p%pcf%leafc_to_litter
leafc_xfer_to_leafc => clm3%g%l%c%p%pcf%leafc_xfer_to_leafc
livecroot_mr => clm3%g%l%c%p%pcf%livecroot_mr
livecroot_curmr => clm3%g%l%c%p%pcf%livecroot_curmr
livecroot_xsmr => clm3%g%l%c%p%pcf%livecroot_xsmr
livecrootc_storage_to_xfer => clm3%g%l%c%p%pcf%livecrootc_storage_to_xfer
livecrootc_to_deadcrootc => clm3%g%l%c%p%pcf%livecrootc_to_deadcrootc
livecrootc_xfer_to_livecrootc => clm3%g%l%c%p%pcf%livecrootc_xfer_to_livecrootc
livestem_mr => clm3%g%l%c%p%pcf%livestem_mr
livestem_curmr => clm3%g%l%c%p%pcf%livestem_curmr
livestem_xsmr => clm3%g%l%c%p%pcf%livestem_xsmr
livestemc_storage_to_xfer => clm3%g%l%c%p%pcf%livestemc_storage_to_xfer
livestemc_to_deadstemc => clm3%g%l%c%p%pcf%livestemc_to_deadstemc
livestemc_xfer_to_livestemc => clm3%g%l%c%p%pcf%livestemc_xfer_to_livestemc
transfer_deadcroot_gr => clm3%g%l%c%p%pcf%transfer_deadcroot_gr
transfer_deadstem_gr => clm3%g%l%c%p%pcf%transfer_deadstem_gr
transfer_froot_gr => clm3%g%l%c%p%pcf%transfer_froot_gr
transfer_leaf_gr => clm3%g%l%c%p%pcf%transfer_leaf_gr
transfer_livecroot_gr => clm3%g%l%c%p%pcf%transfer_livecroot_gr
transfer_livestem_gr => clm3%g%l%c%p%pcf%transfer_livestem_gr
#if (defined CROP)
harvdate => clm3%g%l%c%p%pps%harvdate
xsmrpool_to_atm => clm3%g%l%c%p%pcf%xsmrpool_to_atm
cpool_grain_gr => clm3%g%l%c%p%pcf%cpool_grain_gr
cpool_grain_storage_gr => clm3%g%l%c%p%pcf%cpool_grain_storage_gr
cpool_to_grainc => clm3%g%l%c%p%pcf%cpool_to_grainc
cpool_to_grainc_storage => clm3%g%l%c%p%pcf%cpool_to_grainc_storage
livestemc_to_litter => clm3%g%l%c%p%pcf%livestemc_to_litter
grainc_storage_to_xfer => clm3%g%l%c%p%pcf%grainc_storage_to_xfer
grainc_to_food => clm3%g%l%c%p%pcf%grainc_to_food
grainc_xfer_to_grainc => clm3%g%l%c%p%pcf%grainc_xfer_to_grainc
transfer_grain_gr => clm3%g%l%c%p%pcf%transfer_grain_gr
grainc => clm3%g%l%c%p%pcs%grainc
grainc_storage => clm3%g%l%c%p%pcs%grainc_storage
grainc_xfer => clm3%g%l%c%p%pcs%grainc_xfer
#endif
cpool => clm3%g%l%c%p%pcs%cpool
xsmrpool => clm3%g%l%c%p%pcs%xsmrpool
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
deadstemc => clm3%g%l%c%p%pcs%deadstemc
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
frootc => clm3%g%l%c%p%pcs%frootc
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
leafc => clm3%g%l%c%p%pcs%leafc
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
livecrootc => clm3%g%l%c%p%pcs%livecrootc
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
livestemc => clm3%g%l%c%p%pcs%livestemc
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
pft_ctrunc => clm3%g%l%c%p%pcs%pft_ctrunc
! set time steps
! dt = real( get_step_size(), r8 )
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! column level fluxes
! plant to litter fluxes
! leaf litter
litr1c(c) = litr1c(c) + leafc_to_litr1c(c)*dt
litr2c(c) = litr2c(c) + leafc_to_litr2c(c)*dt
litr3c(c) = litr3c(c) + leafc_to_litr3c(c)*dt
! fine root litter
litr1c(c) = litr1c(c) + frootc_to_litr1c(c)*dt
litr2c(c) = litr2c(c) + frootc_to_litr2c(c)*dt
litr3c(c) = litr3c(c) + frootc_to_litr3c(c)*dt
#if (defined CROP)
! livestem litter
litr1c(c) = litr1c(c) + livestemc_to_litr1c(c)*dt
litr2c(c) = litr2c(c) + livestemc_to_litr2c(c)*dt
litr3c(c) = litr3c(c) + livestemc_to_litr3c(c)*dt
! grain litter
litr1c(c) = litr1c(c) + grainc_to_litr1c(c)*dt
litr2c(c) = litr2c(c) + grainc_to_litr2c(c)*dt
litr3c(c) = litr3c(c) + grainc_to_litr3c(c)*dt
#endif
! seeding fluxes, from dynamic landcover
seedc(c) = seedc(c) - dwt_seedc_to_leaf(c) * dt
seedc(c) = seedc(c) - dwt_seedc_to_deadstem(c) * dt
! fluxes into litter and CWD, from dynamic landcover
litr1c(c) = litr1c(c) + dwt_frootc_to_litr1c(c)*dt
litr2c(c) = litr2c(c) + dwt_frootc_to_litr2c(c)*dt
litr3c(c) = litr3c(c) + dwt_frootc_to_litr3c(c)*dt
cwdc(c) = cwdc(c) + dwt_livecrootc_to_cwdc(c)*dt
cwdc(c) = cwdc(c) + dwt_deadcrootc_to_cwdc(c)*dt
! litter and SOM HR fluxes
litr1c(c) = litr1c(c) - litr1_hr(c)*dt
litr2c(c) = litr2c(c) - litr2_hr(c)*dt
litr3c(c) = litr3c(c) - litr3_hr(c)*dt
soil1c(c) = soil1c(c) - soil1_hr(c)*dt
soil2c(c) = soil2c(c) - soil2_hr(c)*dt
soil3c(c) = soil3c(c) - soil3_hr(c)*dt
soil4c(c) = soil4c(c) - soil4_hr(c)*dt
! CWD to litter fluxes
cwdc(c) = cwdc(c) - cwdc_to_litr2c(c)*dt
litr2c(c) = litr2c(c) + cwdc_to_litr2c(c)*dt
cwdc(c) = cwdc(c) - cwdc_to_litr3c(c)*dt
litr3c(c) = litr3c(c) + cwdc_to_litr3c(c)*dt
! litter to SOM fluxes
litr1c(c) = litr1c(c) - litr1c_to_soil1c(c)*dt
soil1c(c) = soil1c(c) + litr1c_to_soil1c(c)*dt
litr2c(c) = litr2c(c) - litr2c_to_soil2c(c)*dt
soil2c(c) = soil2c(c) + litr2c_to_soil2c(c)*dt
litr3c(c) = litr3c(c) - litr3c_to_soil3c(c)*dt
soil3c(c) = soil3c(c) + litr3c_to_soil3c(c)*dt
! SOM to SOM fluxes
soil1c(c) = soil1c(c) - soil1c_to_soil2c(c)*dt
soil2c(c) = soil2c(c) + soil1c_to_soil2c(c)*dt
soil2c(c) = soil2c(c) - soil2c_to_soil3c(c)*dt
soil3c(c) = soil3c(c) + soil2c_to_soil3c(c)*dt
soil3c(c) = soil3c(c) - soil3c_to_soil4c(c)*dt
soil4c(c) = soil4c(c) + soil3c_to_soil4c(c)*dt
end do ! end of columns loop
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! phenology: transfer growth fluxes
leafc(p) = leafc(p) + leafc_xfer_to_leafc(p)*dt
leafc_xfer(p) = leafc_xfer(p) - leafc_xfer_to_leafc(p)*dt
frootc(p) = frootc(p) + frootc_xfer_to_frootc(p)*dt
frootc_xfer(p) = frootc_xfer(p) - frootc_xfer_to_frootc(p)*dt
if (woody(ivt(p)) == 1._r8) then
livestemc(p) = livestemc(p) + livestemc_xfer_to_livestemc(p)*dt
livestemc_xfer(p) = livestemc_xfer(p) - livestemc_xfer_to_livestemc(p)*dt
write(6,*) 'in CNCStateUpdate1Mod,before,deadstemc(',p,')=',deadstemc(p)
deadstemc(p) = deadstemc(p) + deadstemc_xfer_to_deadstemc(p)*dt
write(6,*) 'in CNCStateUpdate1Mod,deadstemc_xfer_to_deadstemc(',p,')=',deadstemc_xfer_to_deadstemc(p)
write(6,*) 'in CNCStateUpdate1Mod,after, deadstemc(',p,')=',deadstemc(p)
deadstemc_xfer(p) = deadstemc_xfer(p) - deadstemc_xfer_to_deadstemc(p)*dt
livecrootc(p) = livecrootc(p) + livecrootc_xfer_to_livecrootc(p)*dt
livecrootc_xfer(p) = livecrootc_xfer(p) - livecrootc_xfer_to_livecrootc(p)*dt
deadcrootc(p) = deadcrootc(p) + deadcrootc_xfer_to_deadcrootc(p)*dt
deadcrootc_xfer(p) = deadcrootc_xfer(p) - deadcrootc_xfer_to_deadcrootc(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
! lines here for consistency; the transfer terms are zero
livestemc(p) = livestemc(p) + livestemc_xfer_to_livestemc(p)*dt
livestemc_xfer(p) = livestemc_xfer(p) - livestemc_xfer_to_livestemc(p)*dt
grainc(p) = grainc(p) + grainc_xfer_to_grainc(p)*dt
grainc_xfer(p) = grainc_xfer(p) - grainc_xfer_to_grainc(p)*dt
end if
#endif
! phenology: litterfall fluxes
leafc(p) = leafc(p) - leafc_to_litter(p)*dt
frootc(p) = frootc(p) - frootc_to_litter(p)*dt
! livewood turnover fluxes
if (woody(ivt(p)) == 1._r8) then
livestemc(p) = livestemc(p) - livestemc_to_deadstemc(p)*dt
deadstemc(p) = deadstemc(p) + livestemc_to_deadstemc(p)*dt
write(6,*) 'in CNCStateUpdate1Mod,livestemc_to_deadstemc(',p,')=',livestemc_to_deadstemc(p)
write(6,*) 'in CNCStateUpdate1Mod,after, deadstemc(',p,')=',deadstemc(p)
livecrootc(p) = livecrootc(p) - livecrootc_to_deadcrootc(p)*dt
deadcrootc(p) = deadcrootc(p) + livecrootc_to_deadcrootc(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
livestemc(p) = livestemc(p) - livestemc_to_litter(p)*dt
grainc(p) = grainc(p) - grainc_to_food(p)*dt
end if
#endif
! maintenance respiration fluxes from cpool
cpool(p) = cpool(p) - cpool_to_xsmrpool(p)*dt
cpool(p) = cpool(p) - leaf_curmr(p)*dt
cpool(p) = cpool(p) - froot_curmr(p)*dt
if (woody(ivt(p)) == 1._r8) then
cpool(p) = cpool(p) - livestem_curmr(p)*dt
cpool(p) = cpool(p) - livecroot_curmr(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
cpool(p) = cpool(p) - livestem_curmr(p)*dt
end if
#endif
! maintenance respiration fluxes from xsmrpool
xsmrpool(p) = xsmrpool(p) + cpool_to_xsmrpool(p)*dt
xsmrpool(p) = xsmrpool(p) - leaf_xsmr(p)*dt
xsmrpool(p) = xsmrpool(p) - froot_xsmr(p)*dt
if (woody(ivt(p)) == 1._r8) then
xsmrpool(p) = xsmrpool(p) - livestem_xsmr(p)*dt
xsmrpool(p) = xsmrpool(p) - livecroot_xsmr(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
xsmrpool(p) = xsmrpool(p) - livestem_xsmr(p)*dt
if (harvdate(p) < 999) then ! beginning at harvest, send to atm
xsmrpool_to_atm(p) = xsmrpool_to_atm(p) + xsmrpool(p)/dt
xsmrpool(p) = xsmrpool(p) - xsmrpool_to_atm(p)*dt
end if
end if
#endif
! allocation fluxes
cpool(p) = cpool(p) - cpool_to_leafc(p)*dt
leafc(p) = leafc(p) + cpool_to_leafc(p)*dt
cpool(p) = cpool(p) - cpool_to_leafc_storage(p)*dt
leafc_storage(p) = leafc_storage(p) + cpool_to_leafc_storage(p)*dt
cpool(p) = cpool(p) - cpool_to_frootc(p)*dt
frootc(p) = frootc(p) + cpool_to_frootc(p)*dt
cpool(p) = cpool(p) - cpool_to_frootc_storage(p)*dt
frootc_storage(p) = frootc_storage(p) + cpool_to_frootc_storage(p)*dt
write(6,*) 'm1 cpool(',p,')=',cpool(p)
if (woody(ivt(p)) == 1._r8) then
cpool(p) = cpool(p) - cpool_to_livestemc(p)*dt
livestemc(p) = livestemc(p) + cpool_to_livestemc(p)*dt
cpool(p) = cpool(p) - cpool_to_livestemc_storage(p)*dt
livestemc_storage(p) = livestemc_storage(p) + cpool_to_livestemc_storage(p)*dt
cpool(p) = cpool(p) - cpool_to_deadstemc(p)*dt
deadstemc(p) = deadstemc(p) + cpool_to_deadstemc(p)*dt
write(6,*) 'cpool_to_deadstemc(',p,')=',cpool_to_deadstemc(p)
write(6,*) 'deadstemc(',p,')=',deadstemc(p)
write(6,*) 'm2 cpool=',cpool
cpool(p) = cpool(p) - cpool_to_deadstemc_storage(p)*dt
deadstemc_storage(p) = deadstemc_storage(p) + cpool_to_deadstemc_storage(p)*dt
cpool(p) = cpool(p) - cpool_to_livecrootc(p)*dt
livecrootc(p) = livecrootc(p) + cpool_to_livecrootc(p)*dt
cpool(p) = cpool(p) - cpool_to_livecrootc_storage(p)*dt
livecrootc_storage(p) = livecrootc_storage(p) + cpool_to_livecrootc_storage(p)*dt
cpool(p) = cpool(p) - cpool_to_deadcrootc(p)*dt
deadcrootc(p) = deadcrootc(p) + cpool_to_deadcrootc(p)*dt
cpool(p) = cpool(p) - cpool_to_deadcrootc_storage(p)*dt
deadcrootc_storage(p) = deadcrootc_storage(p) + cpool_to_deadcrootc_storage(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
cpool(p) = cpool(p) - cpool_to_livestemc(p)*dt
livestemc(p) = livestemc(p) + cpool_to_livestemc(p)*dt
cpool(p) = cpool(p) - cpool_to_livestemc_storage(p)*dt
livestemc_storage(p) = livestemc_storage(p) + cpool_to_livestemc_storage(p)*dt
cpool(p) = cpool(p) - cpool_to_grainc(p)*dt
grainc(p) = grainc(p) + cpool_to_grainc(p)*dt
cpool(p) = cpool(p) - cpool_to_grainc_storage(p)*dt
grainc_storage(p) = grainc_storage(p) + cpool_to_grainc_storage(p)*dt
end if
#endif
write(6,*) 'm3 cpool=',cpool
! growth respiration fluxes for current growth
cpool(p) = cpool(p) - cpool_leaf_gr(p)*dt
cpool(p) = cpool(p) - cpool_froot_gr(p)*dt
if (woody(ivt(p)) == 1._r8) then
cpool(p) = cpool(p) - cpool_livestem_gr(p)*dt
cpool(p) = cpool(p) - cpool_deadstem_gr(p)*dt
cpool(p) = cpool(p) - cpool_livecroot_gr(p)*dt
cpool(p) = cpool(p) - cpool_deadcroot_gr(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
cpool(p) = cpool(p) - cpool_livestem_gr(p)*dt
cpool(p) = cpool(p) - cpool_grain_gr(p)*dt
end if
#endif
! growth respiration for transfer growth
gresp_xfer(p) = gresp_xfer(p) - transfer_leaf_gr(p)*dt
gresp_xfer(p) = gresp_xfer(p) - transfer_froot_gr(p)*dt
if (woody(ivt(p)) == 1._r8) then
gresp_xfer(p) = gresp_xfer(p) - transfer_livestem_gr(p)*dt
gresp_xfer(p) = gresp_xfer(p) - transfer_deadstem_gr(p)*dt
gresp_xfer(p) = gresp_xfer(p) - transfer_livecroot_gr(p)*dt
gresp_xfer(p) = gresp_xfer(p) - transfer_deadcroot_gr(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
gresp_xfer(p) = gresp_xfer(p) - transfer_livestem_gr(p)*dt
gresp_xfer(p) = gresp_xfer(p) - transfer_grain_gr(p)*dt
end if
#endif
! growth respiration at time of storage
cpool(p) = cpool(p) - cpool_leaf_storage_gr(p)*dt
cpool(p) = cpool(p) - cpool_froot_storage_gr(p)*dt
if (woody(ivt(p)) == 1._r8) then
cpool(p) = cpool(p) - cpool_livestem_storage_gr(p)*dt
cpool(p) = cpool(p) - cpool_deadstem_storage_gr(p)*dt
cpool(p) = cpool(p) - cpool_livecroot_storage_gr(p)*dt
cpool(p) = cpool(p) - cpool_deadcroot_storage_gr(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
cpool(p) = cpool(p) - cpool_livestem_storage_gr(p)*dt
cpool(p) = cpool(p) - cpool_grain_storage_gr(p)*dt
end if
#endif
! growth respiration stored for release during transfer growth
cpool(p) = cpool(p) - cpool_to_gresp_storage(p)*dt
gresp_storage(p) = gresp_storage(p) + cpool_to_gresp_storage(p)*dt
! move storage pools into transfer pools
leafc_storage(p) = leafc_storage(p) - leafc_storage_to_xfer(p)*dt
leafc_xfer(p) = leafc_xfer(p) + leafc_storage_to_xfer(p)*dt
frootc_storage(p) = frootc_storage(p) - frootc_storage_to_xfer(p)*dt
frootc_xfer(p) = frootc_xfer(p) + frootc_storage_to_xfer(p)*dt
if (woody(ivt(p)) == 1._r8) then
livestemc_storage(p) = livestemc_storage(p) - livestemc_storage_to_xfer(p)*dt
livestemc_xfer(p) = livestemc_xfer(p) + livestemc_storage_to_xfer(p)*dt
deadstemc_storage(p) = deadstemc_storage(p) - deadstemc_storage_to_xfer(p)*dt
deadstemc_xfer(p) = deadstemc_xfer(p) + deadstemc_storage_to_xfer(p)*dt
livecrootc_storage(p) = livecrootc_storage(p) - livecrootc_storage_to_xfer(p)*dt
livecrootc_xfer(p) = livecrootc_xfer(p) + livecrootc_storage_to_xfer(p)*dt
deadcrootc_storage(p) = deadcrootc_storage(p) - deadcrootc_storage_to_xfer(p)*dt
deadcrootc_xfer(p) = deadcrootc_xfer(p) + deadcrootc_storage_to_xfer(p)*dt
gresp_storage(p) = gresp_storage(p) - gresp_storage_to_xfer(p)*dt
gresp_xfer(p) = gresp_xfer(p) + gresp_storage_to_xfer(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
! lines here for consistency; the transfer terms are zero
livestemc_storage(p) = livestemc_storage(p) - livestemc_storage_to_xfer(p)*dt
livestemc_xfer(p) = livestemc_xfer(p) + livestemc_storage_to_xfer(p)*dt
grainc_storage(p) = grainc_storage(p) - grainc_storage_to_xfer(p)*dt
grainc_xfer(p) = grainc_xfer(p) + grainc_storage_to_xfer(p)*dt
end if
#endif
end do ! end of pft loop
end subroutine CStateUpdate1
!-----------------------------------------------------------------------
#endif
end module CNCStateUpdate1Mod
module CNCStateUpdate2Mod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CStateUpdate2Mod
!
! !DESCRIPTION:
! Module for carbon state variable update, mortality fluxes.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public:: CStateUpdate2
public:: CStateUpdate2h
!
! !REVISION HISTORY:
! 4/23/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CStateUpdate2
!
! !INTERFACE:
subroutine CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! On the radiation time step, update all the prognostic carbon state
! variables affected by gap-phase mortality fluxes
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size
use globals, only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 3/29/04: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
real(r8), pointer :: m_deadcrootc_storage_to_litr1c(:)
real(r8), pointer :: m_deadcrootc_to_cwdc(:)
real(r8), pointer :: m_deadcrootc_xfer_to_litr1c(:)
real(r8), pointer :: m_deadstemc_storage_to_litr1c(:)
real(r8), pointer :: m_deadstemc_to_cwdc(:)
real(r8), pointer :: m_deadstemc_xfer_to_litr1c(:)
real(r8), pointer :: m_frootc_storage_to_litr1c(:)
real(r8), pointer :: m_frootc_to_litr1c(:)
real(r8), pointer :: m_frootc_to_litr2c(:)
real(r8), pointer :: m_frootc_to_litr3c(:)
real(r8), pointer :: m_frootc_xfer_to_litr1c(:)
real(r8), pointer :: m_gresp_storage_to_litr1c(:)
real(r8), pointer :: m_gresp_xfer_to_litr1c(:)
real(r8), pointer :: m_leafc_storage_to_litr1c(:)
real(r8), pointer :: m_leafc_to_litr1c(:)
real(r8), pointer :: m_leafc_to_litr2c(:)
real(r8), pointer :: m_leafc_to_litr3c(:)
real(r8), pointer :: m_leafc_xfer_to_litr1c(:)
real(r8), pointer :: m_livecrootc_storage_to_litr1c(:)
real(r8), pointer :: m_livecrootc_to_cwdc(:)
real(r8), pointer :: m_livecrootc_xfer_to_litr1c(:)
real(r8), pointer :: m_livestemc_storage_to_litr1c(:)
real(r8), pointer :: m_livestemc_to_cwdc(:)
real(r8), pointer :: m_livestemc_xfer_to_litr1c(:)
real(r8), pointer :: m_deadcrootc_storage_to_litter(:)
real(r8), pointer :: m_deadcrootc_to_litter(:)
real(r8), pointer :: m_deadcrootc_xfer_to_litter(:)
real(r8), pointer :: m_deadstemc_storage_to_litter(:)
real(r8), pointer :: m_deadstemc_to_litter(:)
real(r8), pointer :: m_deadstemc_xfer_to_litter(:)
real(r8), pointer :: m_frootc_storage_to_litter(:)
real(r8), pointer :: m_frootc_to_litter(:)
real(r8), pointer :: m_frootc_xfer_to_litter(:)
real(r8), pointer :: m_gresp_storage_to_litter(:)
real(r8), pointer :: m_gresp_xfer_to_litter(:)
real(r8), pointer :: m_leafc_storage_to_litter(:)
real(r8), pointer :: m_leafc_to_litter(:)
real(r8), pointer :: m_leafc_xfer_to_litter(:)
real(r8), pointer :: m_livecrootc_storage_to_litter(:)
real(r8), pointer :: m_livecrootc_to_litter(:)
real(r8), pointer :: m_livecrootc_xfer_to_litter(:)
real(r8), pointer :: m_livestemc_storage_to_litter(:)
real(r8), pointer :: m_livestemc_to_litter(:)
real(r8), pointer :: m_livestemc_xfer_to_litter(:)
!
! local pointers to implicit in/out arrays
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc_xfer(:) !(gC/m2) dead coarse root C transfer
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc_xfer(:) !(gC/m2) live coarse root C transfer
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
!
!
! local pointers to implicit out arrays
!
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
! real(r8):: dt ! radiation time step (seconds)
!
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the column level
m_deadcrootc_storage_to_litr1c => clm3%g%l%c%ccf%m_deadcrootc_storage_to_litr1c
m_deadcrootc_to_cwdc => clm3%g%l%c%ccf%m_deadcrootc_to_cwdc
m_deadcrootc_xfer_to_litr1c => clm3%g%l%c%ccf%m_deadcrootc_xfer_to_litr1c
m_deadstemc_storage_to_litr1c => clm3%g%l%c%ccf%m_deadstemc_storage_to_litr1c
m_deadstemc_to_cwdc => clm3%g%l%c%ccf%m_deadstemc_to_cwdc
m_deadstemc_xfer_to_litr1c => clm3%g%l%c%ccf%m_deadstemc_xfer_to_litr1c
m_frootc_storage_to_litr1c => clm3%g%l%c%ccf%m_frootc_storage_to_litr1c
m_frootc_to_litr1c => clm3%g%l%c%ccf%m_frootc_to_litr1c
m_frootc_to_litr2c => clm3%g%l%c%ccf%m_frootc_to_litr2c
m_frootc_to_litr3c => clm3%g%l%c%ccf%m_frootc_to_litr3c
m_frootc_xfer_to_litr1c => clm3%g%l%c%ccf%m_frootc_xfer_to_litr1c
m_gresp_storage_to_litr1c => clm3%g%l%c%ccf%m_gresp_storage_to_litr1c
m_gresp_xfer_to_litr1c => clm3%g%l%c%ccf%m_gresp_xfer_to_litr1c
m_leafc_storage_to_litr1c => clm3%g%l%c%ccf%m_leafc_storage_to_litr1c
m_leafc_to_litr1c => clm3%g%l%c%ccf%m_leafc_to_litr1c
m_leafc_to_litr2c => clm3%g%l%c%ccf%m_leafc_to_litr2c
m_leafc_to_litr3c => clm3%g%l%c%ccf%m_leafc_to_litr3c
m_leafc_xfer_to_litr1c => clm3%g%l%c%ccf%m_leafc_xfer_to_litr1c
m_livecrootc_storage_to_litr1c => clm3%g%l%c%ccf%m_livecrootc_storage_to_litr1c
m_livecrootc_to_cwdc => clm3%g%l%c%ccf%m_livecrootc_to_cwdc
m_livecrootc_xfer_to_litr1c => clm3%g%l%c%ccf%m_livecrootc_xfer_to_litr1c
m_livestemc_storage_to_litr1c => clm3%g%l%c%ccf%m_livestemc_storage_to_litr1c
m_livestemc_to_cwdc => clm3%g%l%c%ccf%m_livestemc_to_cwdc
m_livestemc_xfer_to_litr1c => clm3%g%l%c%ccf%m_livestemc_xfer_to_litr1c
cwdc => clm3%g%l%c%ccs%cwdc
litr1c => clm3%g%l%c%ccs%litr1c
litr2c => clm3%g%l%c%ccs%litr2c
litr3c => clm3%g%l%c%ccs%litr3c
! assign local pointers at the pft level
m_deadcrootc_storage_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_storage_to_litter
m_deadcrootc_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_to_litter
m_deadcrootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_xfer_to_litter
m_deadstemc_storage_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_storage_to_litter
m_deadstemc_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_to_litter
m_deadstemc_xfer_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_xfer_to_litter
m_frootc_storage_to_litter => clm3%g%l%c%p%pcf%m_frootc_storage_to_litter
m_frootc_to_litter => clm3%g%l%c%p%pcf%m_frootc_to_litter
m_frootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_frootc_xfer_to_litter
m_gresp_storage_to_litter => clm3%g%l%c%p%pcf%m_gresp_storage_to_litter
m_gresp_xfer_to_litter => clm3%g%l%c%p%pcf%m_gresp_xfer_to_litter
m_leafc_storage_to_litter => clm3%g%l%c%p%pcf%m_leafc_storage_to_litter
m_leafc_to_litter => clm3%g%l%c%p%pcf%m_leafc_to_litter
m_leafc_xfer_to_litter => clm3%g%l%c%p%pcf%m_leafc_xfer_to_litter
m_livecrootc_storage_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_storage_to_litter
m_livecrootc_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_to_litter
m_livecrootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_xfer_to_litter
m_livestemc_storage_to_litter => clm3%g%l%c%p%pcf%m_livestemc_storage_to_litter
m_livestemc_to_litter => clm3%g%l%c%p%pcf%m_livestemc_to_litter
m_livestemc_xfer_to_litter => clm3%g%l%c%p%pcf%m_livestemc_xfer_to_litter
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
deadstemc => clm3%g%l%c%p%pcs%deadstemc
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
frootc => clm3%g%l%c%p%pcs%frootc
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
leafc => clm3%g%l%c%p%pcs%leafc
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
livecrootc => clm3%g%l%c%p%pcs%livecrootc
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
livestemc => clm3%g%l%c%p%pcs%livestemc
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
! set time steps
! dt = real( get_step_size(), r8 )
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! column level carbon fluxes from gap-phase mortality
! leaf to litter
litr1c(c) = litr1c(c) + m_leafc_to_litr1c(c) * dt
litr2c(c) = litr2c(c) + m_leafc_to_litr2c(c) * dt
litr3c(c) = litr3c(c) + m_leafc_to_litr3c(c) * dt
! fine root to litter
litr1c(c) = litr1c(c) + m_frootc_to_litr1c(c) * dt
litr2c(c) = litr2c(c) + m_frootc_to_litr2c(c) * dt
litr3c(c) = litr3c(c) + m_frootc_to_litr3c(c) * dt
! wood to CWD
cwdc(c) = cwdc(c) + m_livestemc_to_cwdc(c) * dt
cwdc(c) = cwdc(c) + m_deadstemc_to_cwdc(c) * dt
cwdc(c) = cwdc(c) + m_livecrootc_to_cwdc(c) * dt
cwdc(c) = cwdc(c) + m_deadcrootc_to_cwdc(c) * dt
! storage pools to litter
litr1c(c) = litr1c(c) + m_leafc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_frootc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_livestemc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_deadstemc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_livecrootc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_deadcrootc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_gresp_storage_to_litr1c(c) * dt
! transfer pools to litter
litr1c(c) = litr1c(c) + m_leafc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_frootc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_livestemc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_deadstemc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_livecrootc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_deadcrootc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + m_gresp_xfer_to_litr1c(c) * dt
end do ! end of columns loop
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! pft-level carbon fluxes from gap-phase mortality
! displayed pools
leafc(p) = leafc(p) - m_leafc_to_litter(p) * dt
frootc(p) = frootc(p) - m_frootc_to_litter(p) * dt
livestemc(p) = livestemc(p) - m_livestemc_to_litter(p) * dt
write(6,*) 'in CStateUpdate2, before deadstemc(',p,')=',deadstemc(p)
deadstemc(p) = deadstemc(p) - m_deadstemc_to_litter(p) * dt
write(6,*) 'in CStateUpdate2, deadstemc(',p,')=',deadstemc(p)
write(6,*) 'in CStateUpdate2, m_deadstemc_to_litter(',p,')=',m_deadstemc_to_litter(p)
livecrootc(p) = livecrootc(p) - m_livecrootc_to_litter(p) * dt
deadcrootc(p) = deadcrootc(p) - m_deadcrootc_to_litter(p) * dt
! storage pools
leafc_storage(p) = leafc_storage(p) - m_leafc_storage_to_litter(p) * dt
frootc_storage(p) = frootc_storage(p) - m_frootc_storage_to_litter(p) * dt
livestemc_storage(p) = livestemc_storage(p) - m_livestemc_storage_to_litter(p) * dt
deadstemc_storage(p) = deadstemc_storage(p) - m_deadstemc_storage_to_litter(p) * dt
livecrootc_storage(p) = livecrootc_storage(p) - m_livecrootc_storage_to_litter(p) * dt
deadcrootc_storage(p) = deadcrootc_storage(p) - m_deadcrootc_storage_to_litter(p) * dt
gresp_storage(p) = gresp_storage(p) - m_gresp_storage_to_litter(p) * dt
! transfer pools
leafc_xfer(p) = leafc_xfer(p) - m_leafc_xfer_to_litter(p) * dt
frootc_xfer(p) = frootc_xfer(p) - m_frootc_xfer_to_litter(p) * dt
livestemc_xfer(p) = livestemc_xfer(p) - m_livestemc_xfer_to_litter(p) * dt
deadstemc_xfer(p) = deadstemc_xfer(p) - m_deadstemc_xfer_to_litter(p) * dt
livecrootc_xfer(p) = livecrootc_xfer(p) - m_livecrootc_xfer_to_litter(p) * dt
deadcrootc_xfer(p) = deadcrootc_xfer(p) - m_deadcrootc_xfer_to_litter(p) * dt
gresp_xfer(p) = gresp_xfer(p) - m_gresp_xfer_to_litter(p) * dt
end do ! end of pft loop
end subroutine CStateUpdate2
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CStateUpdate2h
!
! !INTERFACE:
subroutine CStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! Update all the prognostic carbon state
! variables affected by harvest mortality fluxes
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size
use globals, only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 5/20/09: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
real(r8), pointer :: hrv_deadcrootc_storage_to_litr1c(:)
real(r8), pointer :: hrv_deadcrootc_to_cwdc(:)
real(r8), pointer :: hrv_deadcrootc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_deadstemc_storage_to_litr1c(:)
real(r8), pointer :: hrv_deadstemc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_frootc_storage_to_litr1c(:)
real(r8), pointer :: hrv_frootc_to_litr1c(:)
real(r8), pointer :: hrv_frootc_to_litr2c(:)
real(r8), pointer :: hrv_frootc_to_litr3c(:)
real(r8), pointer :: hrv_frootc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_gresp_storage_to_litr1c(:)
real(r8), pointer :: hrv_gresp_xfer_to_litr1c(:)
real(r8), pointer :: hrv_leafc_storage_to_litr1c(:)
real(r8), pointer :: hrv_leafc_to_litr1c(:)
real(r8), pointer :: hrv_leafc_to_litr2c(:)
real(r8), pointer :: hrv_leafc_to_litr3c(:)
real(r8), pointer :: hrv_leafc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_livecrootc_storage_to_litr1c(:)
real(r8), pointer :: hrv_livecrootc_to_cwdc(:)
real(r8), pointer :: hrv_livecrootc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_livestemc_storage_to_litr1c(:)
real(r8), pointer :: hrv_livestemc_to_cwdc(:)
real(r8), pointer :: hrv_livestemc_xfer_to_litr1c(:)
real(r8), pointer :: hrv_deadcrootc_storage_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_xfer_to_litter(:)
real(r8), pointer :: hrv_deadstemc_storage_to_litter(:)
real(r8), pointer :: hrv_deadstemc_to_prod10c(:)
real(r8), pointer :: hrv_deadstemc_to_prod100c(:)
real(r8), pointer :: hrv_deadstemc_xfer_to_litter(:)
real(r8), pointer :: hrv_frootc_storage_to_litter(:)
real(r8), pointer :: hrv_frootc_to_litter(:)
real(r8), pointer :: hrv_frootc_xfer_to_litter(:)
real(r8), pointer :: hrv_gresp_storage_to_litter(:)
real(r8), pointer :: hrv_gresp_xfer_to_litter(:)
real(r8), pointer :: hrv_leafc_storage_to_litter(:)
real(r8), pointer :: hrv_leafc_to_litter(:)
real(r8), pointer :: hrv_leafc_xfer_to_litter(:)
real(r8), pointer :: hrv_livecrootc_storage_to_litter(:)
real(r8), pointer :: hrv_livecrootc_to_litter(:)
real(r8), pointer :: hrv_livecrootc_xfer_to_litter(:)
real(r8), pointer :: hrv_livestemc_storage_to_litter(:)
real(r8), pointer :: hrv_livestemc_to_litter(:)
real(r8), pointer :: hrv_livestemc_xfer_to_litter(:)
real(r8), pointer :: hrv_xsmrpool_to_atm(:)
!
! local pointers to implicit in/out arrays
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: xsmrpool(:) ! (gC/m2) abstract C pool to meet excess MR demand
!
!
! local pointers to implicit out arrays
!
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
! real(r8):: dt ! radiation time step (seconds)
!
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the column level
hrv_deadcrootc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_deadcrootc_storage_to_litr1c
hrv_deadcrootc_to_cwdc => clm3%g%l%c%ccf%hrv_deadcrootc_to_cwdc
hrv_deadcrootc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_deadcrootc_xfer_to_litr1c
hrv_deadstemc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_deadstemc_storage_to_litr1c
hrv_deadstemc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_deadstemc_xfer_to_litr1c
hrv_frootc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_frootc_storage_to_litr1c
hrv_frootc_to_litr1c => clm3%g%l%c%ccf%hrv_frootc_to_litr1c
hrv_frootc_to_litr2c => clm3%g%l%c%ccf%hrv_frootc_to_litr2c
hrv_frootc_to_litr3c => clm3%g%l%c%ccf%hrv_frootc_to_litr3c
hrv_frootc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_frootc_xfer_to_litr1c
hrv_gresp_storage_to_litr1c => clm3%g%l%c%ccf%hrv_gresp_storage_to_litr1c
hrv_gresp_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_gresp_xfer_to_litr1c
hrv_leafc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_leafc_storage_to_litr1c
hrv_leafc_to_litr1c => clm3%g%l%c%ccf%hrv_leafc_to_litr1c
hrv_leafc_to_litr2c => clm3%g%l%c%ccf%hrv_leafc_to_litr2c
hrv_leafc_to_litr3c => clm3%g%l%c%ccf%hrv_leafc_to_litr3c
hrv_leafc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_leafc_xfer_to_litr1c
hrv_livecrootc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_livecrootc_storage_to_litr1c
hrv_livecrootc_to_cwdc => clm3%g%l%c%ccf%hrv_livecrootc_to_cwdc
hrv_livecrootc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_livecrootc_xfer_to_litr1c
hrv_livestemc_storage_to_litr1c => clm3%g%l%c%ccf%hrv_livestemc_storage_to_litr1c
hrv_livestemc_to_cwdc => clm3%g%l%c%ccf%hrv_livestemc_to_cwdc
hrv_livestemc_xfer_to_litr1c => clm3%g%l%c%ccf%hrv_livestemc_xfer_to_litr1c
cwdc => clm3%g%l%c%ccs%cwdc
litr1c => clm3%g%l%c%ccs%litr1c
litr2c => clm3%g%l%c%ccs%litr2c
litr3c => clm3%g%l%c%ccs%litr3c
! assign local pointers at the pft level
hrv_deadcrootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_storage_to_litter
hrv_deadcrootc_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_to_litter
hrv_deadcrootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_xfer_to_litter
hrv_deadstemc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_deadstemc_storage_to_litter
hrv_deadstemc_to_prod10c => clm3%g%l%c%p%pcf%hrv_deadstemc_to_prod10c
hrv_deadstemc_to_prod100c => clm3%g%l%c%p%pcf%hrv_deadstemc_to_prod100c
hrv_deadstemc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_deadstemc_xfer_to_litter
hrv_frootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_storage_to_litter
hrv_frootc_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_to_litter
hrv_frootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_xfer_to_litter
hrv_gresp_storage_to_litter => clm3%g%l%c%p%pcf%hrv_gresp_storage_to_litter
hrv_gresp_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_gresp_xfer_to_litter
hrv_leafc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_storage_to_litter
hrv_leafc_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_to_litter
hrv_leafc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_xfer_to_litter
hrv_livecrootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_storage_to_litter
hrv_livecrootc_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_to_litter
hrv_livecrootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_xfer_to_litter
hrv_livestemc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_storage_to_litter
hrv_livestemc_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_to_litter
hrv_livestemc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_xfer_to_litter
hrv_xsmrpool_to_atm => clm3%g%l%c%p%pcf%hrv_xsmrpool_to_atm
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
deadstemc => clm3%g%l%c%p%pcs%deadstemc
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
frootc => clm3%g%l%c%p%pcs%frootc
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
leafc => clm3%g%l%c%p%pcs%leafc
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
livecrootc => clm3%g%l%c%p%pcs%livecrootc
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
livestemc => clm3%g%l%c%p%pcs%livestemc
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
xsmrpool => clm3%g%l%c%p%pcs%xsmrpool
! set time steps
! dt = real( get_step_size(), r8 )
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! column level carbon fluxes from harvest mortality
! leaf to litter
litr1c(c) = litr1c(c) + hrv_leafc_to_litr1c(c) * dt
litr2c(c) = litr2c(c) + hrv_leafc_to_litr2c(c) * dt
litr3c(c) = litr3c(c) + hrv_leafc_to_litr3c(c) * dt
! fine root to litter
litr1c(c) = litr1c(c) + hrv_frootc_to_litr1c(c) * dt
litr2c(c) = litr2c(c) + hrv_frootc_to_litr2c(c) * dt
litr3c(c) = litr3c(c) + hrv_frootc_to_litr3c(c) * dt
! wood to CWD
cwdc(c) = cwdc(c) + hrv_livestemc_to_cwdc(c) * dt
cwdc(c) = cwdc(c) + hrv_livecrootc_to_cwdc(c) * dt
cwdc(c) = cwdc(c) + hrv_deadcrootc_to_cwdc(c) * dt
! wood to product pools - states updated in CNWoodProducts()
! storage pools to litter
litr1c(c) = litr1c(c) + hrv_leafc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_frootc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_livestemc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_deadstemc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_livecrootc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_deadcrootc_storage_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_gresp_storage_to_litr1c(c) * dt
! transfer pools to litter
litr1c(c) = litr1c(c) + hrv_leafc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_frootc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_livestemc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_deadstemc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_livecrootc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_deadcrootc_xfer_to_litr1c(c) * dt
litr1c(c) = litr1c(c) + hrv_gresp_xfer_to_litr1c(c) * dt
end do ! end of columns loop
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! pft-level carbon fluxes from harvest mortality
! displayed pools
leafc(p) = leafc(p) - hrv_leafc_to_litter(p) * dt
frootc(p) = frootc(p) - hrv_frootc_to_litter(p) * dt
livestemc(p) = livestemc(p) - hrv_livestemc_to_litter(p) * dt
deadstemc(p) = deadstemc(p) - hrv_deadstemc_to_prod10c(p) * dt
deadstemc(p) = deadstemc(p) - hrv_deadstemc_to_prod100c(p) * dt
livecrootc(p) = livecrootc(p) - hrv_livecrootc_to_litter(p) * dt
deadcrootc(p) = deadcrootc(p) - hrv_deadcrootc_to_litter(p) * dt
! xsmrpool
xsmrpool(p) = xsmrpool(p) - hrv_xsmrpool_to_atm(p) * dt
! storage pools
leafc_storage(p) = leafc_storage(p) - hrv_leafc_storage_to_litter(p) * dt
frootc_storage(p) = frootc_storage(p) - hrv_frootc_storage_to_litter(p) * dt
livestemc_storage(p) = livestemc_storage(p) - hrv_livestemc_storage_to_litter(p) * dt
deadstemc_storage(p) = deadstemc_storage(p) - hrv_deadstemc_storage_to_litter(p) * dt
livecrootc_storage(p) = livecrootc_storage(p) - hrv_livecrootc_storage_to_litter(p) * dt
deadcrootc_storage(p) = deadcrootc_storage(p) - hrv_deadcrootc_storage_to_litter(p) * dt
gresp_storage(p) = gresp_storage(p) - hrv_gresp_storage_to_litter(p) * dt
! transfer pools
leafc_xfer(p) = leafc_xfer(p) - hrv_leafc_xfer_to_litter(p) * dt
frootc_xfer(p) = frootc_xfer(p) - hrv_frootc_xfer_to_litter(p) * dt
livestemc_xfer(p) = livestemc_xfer(p) - hrv_livestemc_xfer_to_litter(p) * dt
deadstemc_xfer(p) = deadstemc_xfer(p) - hrv_deadstemc_xfer_to_litter(p) * dt
livecrootc_xfer(p) = livecrootc_xfer(p) - hrv_livecrootc_xfer_to_litter(p) * dt
deadcrootc_xfer(p) = deadcrootc_xfer(p) - hrv_deadcrootc_xfer_to_litter(p) * dt
gresp_xfer(p) = gresp_xfer(p) - hrv_gresp_xfer_to_litter(p) * dt
end do ! end of pft loop
end subroutine CStateUpdate2h
!-----------------------------------------------------------------------
#endif
end module CNCStateUpdate2Mod
module CNCStateUpdate3Mod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CStateUpdate3Mod
!
! !DESCRIPTION:
! Module for carbon state variable update, mortality fluxes.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public:: CStateUpdate3
!
! !REVISION HISTORY:
! 7/27/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CStateUpdate3
!
! !INTERFACE:
subroutine CStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! On the radiation time step, update all the prognostic carbon state
! variables affected by fire fluxes
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size
use globals , only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 3/29/04: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
real(r8), pointer :: m_cwdc_to_fire(:)
real(r8), pointer :: m_deadcrootc_to_cwdc_fire(:)
real(r8), pointer :: m_deadstemc_to_cwdc_fire(:)
real(r8), pointer :: m_litr1c_to_fire(:)
real(r8), pointer :: m_litr2c_to_fire(:)
real(r8), pointer :: m_litr3c_to_fire(:)
real(r8), pointer :: m_deadcrootc_storage_to_fire(:)
real(r8), pointer :: m_deadcrootc_to_fire(:)
real(r8), pointer :: m_deadcrootc_to_litter_fire(:)
real(r8), pointer :: m_deadcrootc_xfer_to_fire(:)
real(r8), pointer :: m_deadstemc_storage_to_fire(:)
real(r8), pointer :: m_deadstemc_to_fire(:)
real(r8), pointer :: m_deadstemc_to_litter_fire(:)
real(r8), pointer :: m_deadstemc_xfer_to_fire(:)
real(r8), pointer :: m_frootc_storage_to_fire(:)
real(r8), pointer :: m_frootc_to_fire(:)
real(r8), pointer :: m_frootc_xfer_to_fire(:)
real(r8), pointer :: m_gresp_storage_to_fire(:)
real(r8), pointer :: m_gresp_xfer_to_fire(:)
real(r8), pointer :: m_leafc_storage_to_fire(:)
real(r8), pointer :: m_leafc_to_fire(:)
real(r8), pointer :: m_leafc_xfer_to_fire(:)
real(r8), pointer :: m_livecrootc_storage_to_fire(:)
real(r8), pointer :: m_livecrootc_to_fire(:)
real(r8), pointer :: m_livecrootc_xfer_to_fire(:)
real(r8), pointer :: m_livestemc_storage_to_fire(:)
real(r8), pointer :: m_livestemc_to_fire(:)
real(r8), pointer :: m_livestemc_xfer_to_fire(:)
!
! local pointers to implicit in/out arrays
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
!
! local pointers to implicit out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
! real(r8):: dt ! radiation time step (seconds)
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the column level
m_cwdc_to_fire => clm3%g%l%c%ccf%m_cwdc_to_fire
m_deadcrootc_to_cwdc_fire => clm3%g%l%c%ccf%m_deadcrootc_to_cwdc_fire
m_deadstemc_to_cwdc_fire => clm3%g%l%c%ccf%m_deadstemc_to_cwdc_fire
m_litr1c_to_fire => clm3%g%l%c%ccf%m_litr1c_to_fire
m_litr2c_to_fire => clm3%g%l%c%ccf%m_litr2c_to_fire
m_litr3c_to_fire => clm3%g%l%c%ccf%m_litr3c_to_fire
cwdc => clm3%g%l%c%ccs%cwdc
litr1c => clm3%g%l%c%ccs%litr1c
litr2c => clm3%g%l%c%ccs%litr2c
litr3c => clm3%g%l%c%ccs%litr3c
! assign local pointers at the column level
m_deadcrootc_storage_to_fire => clm3%g%l%c%p%pcf%m_deadcrootc_storage_to_fire
m_deadcrootc_to_fire => clm3%g%l%c%p%pcf%m_deadcrootc_to_fire
m_deadcrootc_to_litter_fire => clm3%g%l%c%p%pcf%m_deadcrootc_to_litter_fire
m_deadcrootc_xfer_to_fire => clm3%g%l%c%p%pcf%m_deadcrootc_xfer_to_fire
m_deadstemc_storage_to_fire => clm3%g%l%c%p%pcf%m_deadstemc_storage_to_fire
m_deadstemc_to_fire => clm3%g%l%c%p%pcf%m_deadstemc_to_fire
m_deadstemc_to_litter_fire => clm3%g%l%c%p%pcf%m_deadstemc_to_litter_fire
m_deadstemc_xfer_to_fire => clm3%g%l%c%p%pcf%m_deadstemc_xfer_to_fire
m_frootc_storage_to_fire => clm3%g%l%c%p%pcf%m_frootc_storage_to_fire
m_frootc_to_fire => clm3%g%l%c%p%pcf%m_frootc_to_fire
m_frootc_xfer_to_fire => clm3%g%l%c%p%pcf%m_frootc_xfer_to_fire
m_gresp_storage_to_fire => clm3%g%l%c%p%pcf%m_gresp_storage_to_fire
m_gresp_xfer_to_fire => clm3%g%l%c%p%pcf%m_gresp_xfer_to_fire
m_leafc_storage_to_fire => clm3%g%l%c%p%pcf%m_leafc_storage_to_fire
m_leafc_to_fire => clm3%g%l%c%p%pcf%m_leafc_to_fire
m_leafc_xfer_to_fire => clm3%g%l%c%p%pcf%m_leafc_xfer_to_fire
m_livecrootc_storage_to_fire => clm3%g%l%c%p%pcf%m_livecrootc_storage_to_fire
m_livecrootc_to_fire => clm3%g%l%c%p%pcf%m_livecrootc_to_fire
m_livecrootc_xfer_to_fire => clm3%g%l%c%p%pcf%m_livecrootc_xfer_to_fire
m_livestemc_storage_to_fire => clm3%g%l%c%p%pcf%m_livestemc_storage_to_fire
m_livestemc_to_fire => clm3%g%l%c%p%pcf%m_livestemc_to_fire
m_livestemc_xfer_to_fire => clm3%g%l%c%p%pcf%m_livestemc_xfer_to_fire
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
deadstemc => clm3%g%l%c%p%pcs%deadstemc
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
frootc => clm3%g%l%c%p%pcs%frootc
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
leafc => clm3%g%l%c%p%pcs%leafc
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
livecrootc => clm3%g%l%c%p%pcs%livecrootc
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
livestemc => clm3%g%l%c%p%pcs%livestemc
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
! set time steps
! dt = real( get_step_size(), r8 )
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! column level carbon fluxes from fire
! pft-level wood to column-level CWD (uncombusted wood)
cwdc(c) = cwdc(c) + m_deadstemc_to_cwdc_fire(c) * dt
cwdc(c) = cwdc(c) + m_deadcrootc_to_cwdc_fire(c) * dt
! litter and CWD losses to fire
litr1c(c) = litr1c(c) - m_litr1c_to_fire(c) * dt
litr2c(c) = litr2c(c) - m_litr2c_to_fire(c) * dt
litr3c(c) = litr3c(c) - m_litr3c_to_fire(c) * dt
cwdc(c) = cwdc(c) - m_cwdc_to_fire(c) * dt
end do ! end of columns loop
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! pft-level carbon fluxes from fire
! displayed pools
leafc(p) = leafc(p) - m_leafc_to_fire(p) * dt
frootc(p) = frootc(p) - m_frootc_to_fire(p) * dt
livestemc(p) = livestemc(p) - m_livestemc_to_fire(p) * dt
deadstemc(p) = deadstemc(p) - m_deadstemc_to_fire(p) * dt
deadstemc(p) = deadstemc(p) - m_deadstemc_to_litter_fire(p) * dt
livecrootc(p) = livecrootc(p) - m_livecrootc_to_fire(p) * dt
deadcrootc(p) = deadcrootc(p) - m_deadcrootc_to_fire(p) * dt
deadcrootc(p) = deadcrootc(p) - m_deadcrootc_to_litter_fire(p) * dt
! storage pools
leafc_storage(p) = leafc_storage(p) - m_leafc_storage_to_fire(p) * dt
frootc_storage(p) = frootc_storage(p) - m_frootc_storage_to_fire(p) * dt
livestemc_storage(p) = livestemc_storage(p) - m_livestemc_storage_to_fire(p) * dt
deadstemc_storage(p) = deadstemc_storage(p) - m_deadstemc_storage_to_fire(p) * dt
livecrootc_storage(p) = livecrootc_storage(p) - m_livecrootc_storage_to_fire(p) * dt
deadcrootc_storage(p) = deadcrootc_storage(p) - m_deadcrootc_storage_to_fire(p) * dt
gresp_storage(p) = gresp_storage(p) - m_gresp_storage_to_fire(p) * dt
! transfer pools
leafc_xfer(p) = leafc_xfer(p) - m_leafc_xfer_to_fire(p) * dt
frootc_xfer(p) = frootc_xfer(p) - m_frootc_xfer_to_fire(p) * dt
livestemc_xfer(p) = livestemc_xfer(p) - m_livestemc_xfer_to_fire(p) * dt
deadstemc_xfer(p) = deadstemc_xfer(p) - m_deadstemc_xfer_to_fire(p) * dt
livecrootc_xfer(p) = livecrootc_xfer(p) - m_livecrootc_xfer_to_fire(p) * dt
deadcrootc_xfer(p) = deadcrootc_xfer(p) - m_deadcrootc_xfer_to_fire(p) * dt
gresp_xfer(p) = gresp_xfer(p) - m_gresp_xfer_to_fire(p) * dt
end do ! end of pft loop
end subroutine CStateUpdate3
!-----------------------------------------------------------------------
#endif
end module CNCStateUpdate3Mod
module CNDecompMod 1,3
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNDecompMod
!
! !DESCRIPTION:
! Module holding routines used in litter and soil decomposition model
! for coupled carbon-nitrogen code.
!
! !USES:
use shr_kind_mod , only: r8 => shr_kind_r8
use shr_const_mod, only: SHR_CONST_TKFRZ
use CNAllocationMod, only: CNAllocation
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public:: CNDecompAlloc
!
! !REVISION HISTORY:
! 8/15/03: Created by Peter Thornton
! 10/23/03, Peter Thornton: migrated to vector data structures
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNDecompAlloc
!
! !INTERFACE:
subroutine CNDecompAlloc (lbp, ubp, lbc, ubc, num_soilc, filter_soilc, & 1,5
num_soilp, filter_soilp)
!
! !DESCRIPTION:
!
! !USES:
use clmtype
use CNAllocationMod, only: CNAllocation
! ylu removed
! use clm_time_manager, only: get_step_size
use pft2colMod, only: p2c
use globals, only :dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbp, ubp ! pft-index bounds
integer, intent(in) :: lbc, ubc ! column-index bounds
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90
!
! !REVISION HISTORY:
! 8/15/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
! column level
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: psisat(:,:) ! soil water potential at saturation for CN code (MPa)
real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa)
real(r8), pointer :: dz(:,:) ! soil layer thickness (m)
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (kgC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (kgC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (kgC/m2) litter lignin C
real(r8), pointer :: soil1c(:) ! (kgC/m2) soil organic matter C (fast pool)
real(r8), pointer :: soil2c(:) ! (kgC/m2) soil organic matter C (medium pool)
real(r8), pointer :: soil3c(:) ! (kgC/m2) soil organic matter C (slow pool)
real(r8), pointer :: soil4c(:) ! (kgC/m2) soil organic matter C (slowest pool)
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: litr1n(:) ! (kgN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (kgN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (kgN/m2) litter lignin N
integer, pointer :: clandunit(:) ! index into landunit level quantities
integer , pointer :: itypelun(:) ! landunit type
! pft level
real(r8), pointer :: rootfr(:,:) ! fraction of roots in each soil layer (nlevgrnd)
!
! local pointers to implicit in/out scalars
!
real(r8), pointer :: fpi(:) ! fraction of potential immobilization (no units)
real(r8), pointer :: cwdc_to_litr2c(:)
real(r8), pointer :: cwdc_to_litr3c(:)
real(r8), pointer :: litr1_hr(:)
real(r8), pointer :: litr1c_to_soil1c(:)
real(r8), pointer :: litr2_hr(:)
real(r8), pointer :: litr2c_to_soil2c(:)
real(r8), pointer :: litr3_hr(:)
real(r8), pointer :: litr3c_to_soil3c(:)
real(r8), pointer :: soil1_hr(:)
real(r8), pointer :: soil1c_to_soil2c(:)
real(r8), pointer :: soil2_hr(:)
real(r8), pointer :: soil2c_to_soil3c(:)
real(r8), pointer :: soil3_hr(:)
real(r8), pointer :: soil3c_to_soil4c(:)
real(r8), pointer :: soil4_hr(:)
real(r8), pointer :: cwdn_to_litr2n(:)
real(r8), pointer :: cwdn_to_litr3n(:)
real(r8), pointer :: potential_immob(:)
real(r8), pointer :: litr1n_to_soil1n(:)
real(r8), pointer :: sminn_to_soil1n_l1(:)
real(r8), pointer :: litr2n_to_soil2n(:)
real(r8), pointer :: sminn_to_soil2n_l2(:)
real(r8), pointer :: litr3n_to_soil3n(:)
real(r8), pointer :: sminn_to_soil3n_l3(:)
real(r8), pointer :: soil1n_to_soil2n(:)
real(r8), pointer :: sminn_to_soil2n_s1(:)
real(r8), pointer :: soil2n_to_soil3n(:)
real(r8), pointer :: sminn_to_soil3n_s2(:)
real(r8), pointer :: soil3n_to_soil4n(:)
real(r8), pointer :: sminn_to_soil4n_s3(:)
real(r8), pointer :: soil4n_to_sminn(:)
real(r8), pointer :: sminn_to_denit_l1s1(:)
real(r8), pointer :: sminn_to_denit_l2s2(:)
real(r8), pointer :: sminn_to_denit_l3s3(:)
real(r8), pointer :: sminn_to_denit_s1s2(:)
real(r8), pointer :: sminn_to_denit_s2s3(:)
real(r8), pointer :: sminn_to_denit_s3s4(:)
real(r8), pointer :: sminn_to_denit_s4(:)
real(r8), pointer :: sminn_to_denit_excess(:)
real(r8), pointer :: gross_nmin(:)
real(r8), pointer :: net_nmin(:)
!
! local pointers to implicit out scalars
!
! !OTHER LOCAL VARIABLES:
integer :: c,j !indices
integer :: fc !lake filter column index
!ylu removed 10-22-10
! real(r8):: dt !decomp timestep (seconds)
real(r8):: dtd !decomp timestep (days)
real(r8), pointer:: fr(:,:) !column-level rooting fraction by soil depth
real(r8):: frw(lbc:ubc) !rooting fraction weight
real(r8):: t_scalar(lbc:ubc) !soil temperature scalar for decomp
real(r8):: minpsi, maxpsi !limits for soil water scalar for decomp
real(r8):: psi !temporary soilpsi for water scalar
real(r8):: w_scalar(lbc:ubc) !soil water scalar for decomp
real(r8):: rate_scalar !combined rate scalar for decomp
real(r8):: cn_l1(lbc:ubc) !C:N for litter 1
real(r8):: cn_l2(lbc:ubc) !C:N for litter 2
real(r8):: cn_l3(lbc:ubc) !C:N for litter 3
real(r8):: cn_s1 !C:N for SOM 1
real(r8):: cn_s2 !C:N for SOM 2
real(r8):: cn_s3 !C:N for SOM 3
real(r8):: cn_s4 !C:N for SOM 4
real(r8):: rf_l1s1 !respiration fraction litter 1 -> SOM 1
real(r8):: rf_l2s2 !respiration fraction litter 2 -> SOM 2
real(r8):: rf_l3s3 !respiration fraction litter 3 -> SOM 3
real(r8):: rf_s1s2 !respiration fraction SOM 1 -> SOM 2
real(r8):: rf_s2s3 !respiration fraction SOM 2 -> SOM 3
real(r8):: rf_s3s4 !respiration fraction SOM 3 -> SOM 4
real(r8):: k_l1 !decomposition rate constant litter 1
real(r8):: k_l2 !decomposition rate constant litter 2
real(r8):: k_l3 !decomposition rate constant litter 3
real(r8):: k_s1 !decomposition rate constant SOM 1
real(r8):: k_s2 !decomposition rate constant SOM 2
real(r8):: k_s3 !decomposition rate constant SOM 3
real(r8):: k_s4 !decomposition rate constant SOM 3
real(r8):: k_frag !fragmentation rate constant CWD
real(r8):: ck_l1 !corrected decomposition rate constant litter 1
real(r8):: ck_l2 !corrected decomposition rate constant litter 2
real(r8):: ck_l3 !corrected decomposition rate constant litter 3
real(r8):: ck_s1 !corrected decomposition rate constant SOM 1
real(r8):: ck_s2 !corrected decomposition rate constant SOM 2
real(r8):: ck_s3 !corrected decomposition rate constant SOM 3
real(r8):: ck_s4 !corrected decomposition rate constant SOM 3
real(r8):: ck_frag !corrected fragmentation rate constant CWD
real(r8):: cwd_fcel !cellulose fraction of coarse woody debris
real(r8):: cwd_flig !lignin fraction of coarse woody debris
real(r8):: cwdc_loss !fragmentation rate for CWD carbon (gC/m2/s)
real(r8):: cwdn_loss !fragmentation rate for CWD nitrogen (gN/m2/s)
real(r8):: plitr1c_loss(lbc:ubc) !potential C loss from litter 1
real(r8):: plitr2c_loss(lbc:ubc) !potential C loss from litter 2
real(r8):: plitr3c_loss(lbc:ubc) !potential C loss from litter 3
real(r8):: psoil1c_loss(lbc:ubc) !potential C loss from SOM 1
real(r8):: psoil2c_loss(lbc:ubc) !potential C loss from SOM 2
real(r8):: psoil3c_loss(lbc:ubc) !potential C loss from SOM 3
real(r8):: psoil4c_loss(lbc:ubc) !potential C loss from SOM 4
real(r8):: pmnf_l1s1(lbc:ubc) !potential mineral N flux, litter 1 -> SOM 1
real(r8):: pmnf_l2s2(lbc:ubc) !potential mineral N flux, litter 2 -> SOM 2
real(r8):: pmnf_l3s3(lbc:ubc) !potential mineral N flux, litter 3 -> SOM 3
real(r8):: pmnf_s1s2(lbc:ubc) !potential mineral N flux, SOM 1 -> SOM 2
real(r8):: pmnf_s2s3(lbc:ubc) !potential mineral N flux, SOM 2 -> SOM 3
real(r8):: pmnf_s3s4(lbc:ubc) !potential mineral N flux, SOM 3 -> SOM 4
real(r8):: pmnf_s4(lbc:ubc) !potential mineral N flux, SOM 4
real(r8):: immob(lbc:ubc) !potential N immobilization
real(r8):: ratio !temporary variable
real(r8):: dnp !denitrification proportion
integer :: nlevdecomp ! bottom layer to consider for decomp controls
real(r8):: spinup_scalar !multiplier for AD_SPINUP algorithm
!EOP
!-----------------------------------------------------------------------
! Assign local pointers to derived type arrays
t_soisno => clm3%g%l%c%ces%t_soisno
psisat => clm3%g%l%c%cps%psisat
soilpsi => clm3%g%l%c%cps%soilpsi
dz => clm3%g%l%c%cps%dz
cwdc => clm3%g%l%c%ccs%cwdc
litr1c => clm3%g%l%c%ccs%litr1c
litr2c => clm3%g%l%c%ccs%litr2c
litr3c => clm3%g%l%c%ccs%litr3c
soil1c => clm3%g%l%c%ccs%soil1c
soil2c => clm3%g%l%c%ccs%soil2c
soil3c => clm3%g%l%c%ccs%soil3c
soil4c => clm3%g%l%c%ccs%soil4c
cwdn => clm3%g%l%c%cns%cwdn
litr1n => clm3%g%l%c%cns%litr1n
litr2n => clm3%g%l%c%cns%litr2n
litr3n => clm3%g%l%c%cns%litr3n
fpi => clm3%g%l%c%cps%fpi
cwdc_to_litr2c => clm3%g%l%c%ccf%cwdc_to_litr2c
cwdc_to_litr3c => clm3%g%l%c%ccf%cwdc_to_litr3c
litr1_hr => clm3%g%l%c%ccf%litr1_hr
litr1c_to_soil1c => clm3%g%l%c%ccf%litr1c_to_soil1c
litr2_hr => clm3%g%l%c%ccf%litr2_hr
litr2c_to_soil2c => clm3%g%l%c%ccf%litr2c_to_soil2c
litr3_hr => clm3%g%l%c%ccf%litr3_hr
litr3c_to_soil3c => clm3%g%l%c%ccf%litr3c_to_soil3c
soil1_hr => clm3%g%l%c%ccf%soil1_hr
soil1c_to_soil2c => clm3%g%l%c%ccf%soil1c_to_soil2c
soil2_hr => clm3%g%l%c%ccf%soil2_hr
soil2c_to_soil3c => clm3%g%l%c%ccf%soil2c_to_soil3c
soil3_hr => clm3%g%l%c%ccf%soil3_hr
soil3c_to_soil4c => clm3%g%l%c%ccf%soil3c_to_soil4c
soil4_hr => clm3%g%l%c%ccf%soil4_hr
cwdn_to_litr2n => clm3%g%l%c%cnf%cwdn_to_litr2n
cwdn_to_litr3n => clm3%g%l%c%cnf%cwdn_to_litr3n
potential_immob => clm3%g%l%c%cnf%potential_immob
litr1n_to_soil1n => clm3%g%l%c%cnf%litr1n_to_soil1n
sminn_to_soil1n_l1 => clm3%g%l%c%cnf%sminn_to_soil1n_l1
litr2n_to_soil2n => clm3%g%l%c%cnf%litr2n_to_soil2n
sminn_to_soil2n_l2 => clm3%g%l%c%cnf%sminn_to_soil2n_l2
litr3n_to_soil3n => clm3%g%l%c%cnf%litr3n_to_soil3n
sminn_to_soil3n_l3 => clm3%g%l%c%cnf%sminn_to_soil3n_l3
soil1n_to_soil2n => clm3%g%l%c%cnf%soil1n_to_soil2n
sminn_to_soil2n_s1 => clm3%g%l%c%cnf%sminn_to_soil2n_s1
soil2n_to_soil3n => clm3%g%l%c%cnf%soil2n_to_soil3n
sminn_to_soil3n_s2 => clm3%g%l%c%cnf%sminn_to_soil3n_s2
soil3n_to_soil4n => clm3%g%l%c%cnf%soil3n_to_soil4n
sminn_to_soil4n_s3 => clm3%g%l%c%cnf%sminn_to_soil4n_s3
soil4n_to_sminn => clm3%g%l%c%cnf%soil4n_to_sminn
sminn_to_denit_l1s1 => clm3%g%l%c%cnf%sminn_to_denit_l1s1
sminn_to_denit_l2s2 => clm3%g%l%c%cnf%sminn_to_denit_l2s2
sminn_to_denit_l3s3 => clm3%g%l%c%cnf%sminn_to_denit_l3s3
sminn_to_denit_s1s2 => clm3%g%l%c%cnf%sminn_to_denit_s1s2
sminn_to_denit_s2s3 => clm3%g%l%c%cnf%sminn_to_denit_s2s3
sminn_to_denit_s3s4 => clm3%g%l%c%cnf%sminn_to_denit_s3s4
sminn_to_denit_s4 => clm3%g%l%c%cnf%sminn_to_denit_s4
sminn_to_denit_excess => clm3%g%l%c%cnf%sminn_to_denit_excess
gross_nmin => clm3%g%l%c%cnf%gross_nmin
net_nmin => clm3%g%l%c%cnf%net_nmin
rootfr => clm3%g%l%c%p%pps%rootfr
clandunit => clm3%g%l%c%landunit
itypelun => clm3%g%l%itype
! set time steps
! dt = real( get_step_size(), r8 )
dtd = dt/86400.0_r8
! set soil organic matter compartment C:N ratios (from Biome-BGC v4.2.0)
cn_s1 = 12.0_r8
cn_s2 = 12.0_r8
cn_s3 = 10.0_r8
cn_s4 = 10.0_r8
! set respiration fractions for fluxes between compartments
! (from Biome-BGC v4.2.0)
rf_l1s1 = 0.39_r8
rf_l2s2 = 0.55_r8
rf_l3s3 = 0.29_r8
rf_s1s2 = 0.28_r8
rf_s2s3 = 0.46_r8
rf_s3s4 = 0.55
! set the cellulose and lignin fractions for coarse woody debris
cwd_fcel = 0.76_r8
cwd_flig = 0.24_r8
! set initial base rates for decomposition mass loss (1/day)
! (from Biome-BGC v4.2.0, using three SOM pools)
! Value inside log function is the discrete-time values for a
! daily time step model, and the result of the log function is
! the corresponding continuous-time decay rate (1/day), following
! Olson, 1963.
k_l1 = -log(1.0_r8-0.7_r8)
k_l2 = -log(1.0_r8-0.07_r8)
k_l3 = -log(1.0_r8-0.014_r8)
k_s1 = -log(1.0_r8-0.07_r8)
k_s2 = -log(1.0_r8-0.014_r8)
k_s3 = -log(1.0_r8-0.0014_r8)
k_s4 = -log(1.0_r8-0.0001_r8)
k_frag = -log(1.0_r8-0.001_r8)
! calculate the new discrete-time decay rate for model timestep
k_l1 = 1.0_r8-exp(-k_l1*dtd)
k_l2 = 1.0_r8-exp(-k_l2*dtd)
k_l3 = 1.0_r8-exp(-k_l3*dtd)
k_s1 = 1.0_r8-exp(-k_s1*dtd)
k_s2 = 1.0_r8-exp(-k_s2*dtd)
k_s3 = 1.0_r8-exp(-k_s3*dtd)
k_s4 = 1.0_r8-exp(-k_s4*dtd)
k_frag = 1.0_r8-exp(-k_frag*dtd)
! The following code implements the acceleration part of the AD spinup
! algorithm, by multiplying all of the SOM decomposition base rates by 10.0.
#if (defined AD_SPINUP)
spinup_scalar = 20._r8
k_s1 = k_s1 * spinup_scalar
k_s2 = k_s2 * spinup_scalar
k_s3 = k_s3 * spinup_scalar
k_s4 = k_s4 * spinup_scalar
#endif
! calculate function to weight the temperature and water potential scalars
! for decomposition control.
! the following normalizes values in fr so that they
! sum to 1.0 across top nlevdecomp levels on a column
frw(lbc:ubc) = 0._r8
nlevdecomp=5
allocate(fr(lbc:ubc,nlevdecomp))
do j=1,nlevdecomp
!dir$ concurrent
!cdir nodep
do fc = 1,num_soilc
c = filter_soilc(fc)
frw(c) = frw(c) + dz(c,j)
end do
end do
do j = 1,nlevdecomp
!dir$ concurrent
!dir$ prefervector
!cdir nodep
do fc = 1,num_soilc
c = filter_soilc(fc)
if (frw(c) /= 0._r8) then
fr(c,j) = dz(c,j) / frw(c)
else
fr(c,j) = 0._r8
end if
end do
end do
! calculate rate constant scalar for soil temperature
! assuming that the base rate constants are assigned for non-moisture
! limiting conditions at 25 C.
! Peter Thornton: 3/13/09
! Replaced the Lloyd and Taylor function with a Q10 formula, with Q10 = 1.5
! as part of the modifications made to improve the seasonal cycle of
! atmospheric CO2 concentration in global simulations. This does not impact
! the base rates at 25 C, which are calibrated from microcosm studies.
t_scalar(:) = 0._r8
do j = 1,nlevdecomp
!dir$ concurrent
!cdir nodep
do fc = 1,num_soilc
c = filter_soilc(fc)
t_scalar(c)=t_scalar(c) + (1.5**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8))*fr(c,j)
end do
end do
! calculate the rate constant scalar for soil water content.
! Uses the log relationship with water potential given in
! Andren, O., and K. Paustian, 1987. Barley straw decomposition in the field:
! a comparison of models. Ecology, 68(5):1190-1200.
! and supported by data in
! Orchard, V.A., and F.J. Cook, 1983. Relationship between soil respiration
! and soil moisture. Soil Biol. Biochem., 15(4):447-453.
minpsi = -10.0_r8;
w_scalar(:) = 0._r8
do j = 1,nlevdecomp
!dir$ concurrent
!cdir nodep
do fc = 1,num_soilc
c = filter_soilc(fc)
maxpsi = psisat(c,j)
psi = min(soilpsi(c,j),maxpsi)
! decomp only if soilpsi is higher than minpsi
if (psi > minpsi) then
w_scalar(c) = w_scalar(c) + (log(minpsi/psi)/log(minpsi/maxpsi))*fr(c,j)
end if
end do
end do
! set initial values for potential C and N fluxes
plitr1c_loss(:) = 0._r8
plitr2c_loss(:) = 0._r8
plitr3c_loss(:) = 0._r8
psoil1c_loss(:) = 0._r8
psoil2c_loss(:) = 0._r8
psoil3c_loss(:) = 0._r8
psoil4c_loss(:) = 0._r8
pmnf_l1s1(:) = 0._r8
pmnf_l2s2(:) = 0._r8
pmnf_l3s3(:) = 0._r8
pmnf_s1s2(:) = 0._r8
pmnf_s2s3(:) = 0._r8
pmnf_s3s4(:) = 0._r8
pmnf_s4(:) = 0._r8
! column loop to calculate potential decomp rates and total immobilization
! demand.
!dir$ concurrent
!cdir nodep
do fc = 1,num_soilc
c = filter_soilc(fc)
! calculate litter compartment C:N ratios
if (litr1n(c) > 0._r8) cn_l1(c) = litr1c(c)/litr1n(c)
if (litr2n(c) > 0._r8) cn_l2(c) = litr2c(c)/litr2n(c)
if (litr3n(c) > 0._r8) cn_l3(c) = litr3c(c)/litr3n(c)
! calculate the final rate scalar as the product of temperature and water
! rate scalars, and correct the base decomp rates
rate_scalar = t_scalar(c) * w_scalar(c)
ck_l1 = k_l1 * rate_scalar
ck_l2 = k_l2 * rate_scalar
ck_l3 = k_l3 * rate_scalar
ck_s1 = k_s1 * rate_scalar
ck_s2 = k_s2 * rate_scalar
ck_s3 = k_s3 * rate_scalar
ck_s4 = k_s4 * rate_scalar
ck_frag = k_frag * rate_scalar
! calculate the non-nitrogen-limited fluxes
! these fluxes include the "/ dt" term to put them on a
! per second basis, since the rate constants have been
! calculated on a per timestep basis.
! CWD fragmentation -> litter pools
cwdc_loss = cwdc(c) * ck_frag / dt
cwdc_to_litr2c(c) = cwdc_loss * cwd_fcel
cwdc_to_litr3c(c) = cwdc_loss * cwd_flig
cwdn_loss = cwdn(c) * ck_frag / dt
cwdn_to_litr2n(c) = cwdn_loss * cwd_fcel
cwdn_to_litr3n(c) = cwdn_loss * cwd_flig
! litter 1 -> SOM 1
if (litr1c(c) > 0._r8) then
plitr1c_loss(c) = litr1c(c) * ck_l1 / dt
ratio = 0._r8
if (litr1n(c) > 0._r8) ratio = cn_s1/cn_l1(c)
pmnf_l1s1(c) = (plitr1c_loss(c) * (1.0_r8 - rf_l1s1 - ratio))/cn_s1
end if
! litter 2 -> SOM 2
if (litr2c(c) > 0._r8) then
plitr2c_loss(c) = litr2c(c) * ck_l2 / dt
ratio = 0._r8
if (litr2n(c) > 0._r8) ratio = cn_s2/cn_l2(c)
pmnf_l2s2(c) = (plitr2c_loss(c) * (1.0_r8 - rf_l2s2 - ratio))/cn_s2
end if
! litter 3 -> SOM 3
if (litr3c(c) > 0._r8) then
plitr3c_loss(c) = litr3c(c) * ck_l3 / dt
ratio = 0._r8
if (litr3n(c) > 0._r8) ratio = cn_s3/cn_l3(c)
pmnf_l3s3(c) = (plitr3c_loss(c) * (1.0_r8 - rf_l3s3 - ratio))/cn_s3
end if
! SOM 1 -> SOM 2
if (soil1c(c) > 0._r8) then
psoil1c_loss(c) = soil1c(c) * ck_s1 / dt
pmnf_s1s2(c) = (psoil1c_loss(c) * (1.0_r8 - rf_s1s2 - (cn_s2/cn_s1)))/cn_s2
end if
! SOM 2 -> SOM 3
if (soil2c(c) > 0._r8) then
psoil2c_loss(c) = soil2c(c) * ck_s2 / dt
pmnf_s2s3(c) = (psoil2c_loss(c) * (1.0_r8 - rf_s2s3 - (cn_s3/cn_s2)))/cn_s3
end if
! SOM 3 -> SOM 4
if (soil3c(c) > 0._r8) then
psoil3c_loss(c) = soil3c(c) * ck_s3 / dt
pmnf_s3s4(c) = (psoil3c_loss(c) * (1.0_r8 - rf_s3s4 - (cn_s4/cn_s3)))/cn_s4
end if
! Loss from SOM 4 is entirely respiration (no downstream pool)
if (soil4c(c) > 0._r8) then
psoil4c_loss(c) = soil4c(c) * ck_s4 / dt
pmnf_s4(c) = -psoil4c_loss(c)/cn_s4
end if
! Sum up all the potential immobilization fluxes (positive pmnf flux)
! and all the mineralization fluxes (negative pmnf flux)
immob(c) = 0._r8
! litter 1 -> SOM 1
if (pmnf_l1s1(c) > 0._r8) then
immob(c) = immob(c) + pmnf_l1s1(c)
else
gross_nmin(c) = gross_nmin(c) - pmnf_l1s1(c)
end if
! litter 2 -> SOM 2
if (pmnf_l2s2(c) > 0._r8) then
immob(c) = immob(c) + pmnf_l2s2(c)
else
gross_nmin(c) = gross_nmin(c) - pmnf_l2s2(c)
end if
! litter 3 -> SOM 3
if (pmnf_l3s3(c) > 0._r8) then
immob(c) = immob(c) + pmnf_l3s3(c)
else
gross_nmin(c) = gross_nmin(c) - pmnf_l3s3(c)
end if
! SOM 1 -> SOM 2
if (pmnf_s1s2(c) > 0._r8) then
immob(c) = immob(c) + pmnf_s1s2(c)
else
gross_nmin(c) = gross_nmin(c) - pmnf_s1s2(c)
end if
! SOM 2 -> SOM 3
if (pmnf_s2s3(c) > 0._r8) then
immob(c) = immob(c) + pmnf_s2s3(c)
else
gross_nmin(c) = gross_nmin(c) - pmnf_s2s3(c)
end if
! SOM 3 -> SOM 4
if (pmnf_s3s4(c) > 0._r8) then
immob(c) = immob(c) + pmnf_s3s4(c)
else
gross_nmin(c) = gross_nmin(c) - pmnf_s3s4(c)
end if
! SOM 4
gross_nmin(c) = gross_nmin(c) - pmnf_s4(c)
potential_immob(c) = immob(c)
end do ! end column loop
! now that potential N immobilization is known, call allocation
! to resolve the competition between plants and soil heterotrophs
! for available soil mineral N resource.
call CNAllocation(lbp, ubp, lbc,ubc,num_soilc,filter_soilc,num_soilp,filter_soilp)
! column loop to calculate actual immobilization and decomp rates, following
! resolution of plant/heterotroph competition for mineral N
dnp = 0.01_r8
!dir$ concurrent
!cdir nodep
do fc = 1,num_soilc
c = filter_soilc(fc)
! upon return from CNAllocation, the fraction of potential immobilization
! has been set (cps%fpi). now finish the decomp calculations.
! Only the immobilization steps are limited by fpi (pmnf > 0)
! Also calculate denitrification losses as a simple proportion
! of mineralization flux.
! litter 1 fluxes (labile pool)
if (litr1c(c) > 0._r8) then
if (pmnf_l1s1(c) > 0._r8) then
plitr1c_loss(c) = plitr1c_loss(c) * fpi(c)
pmnf_l1s1(c) = pmnf_l1s1(c) * fpi(c)
sminn_to_denit_l1s1(c) = 0._r8
else
sminn_to_denit_l1s1(c) = -dnp * pmnf_l1s1(c)
end if
litr1_hr(c) = rf_l1s1 * plitr1c_loss(c)
litr1c_to_soil1c(c) = (1._r8 - rf_l1s1) * plitr1c_loss(c)
if (litr1n(c) > 0._r8) litr1n_to_soil1n(c) = plitr1c_loss(c) / cn_l1(c)
sminn_to_soil1n_l1(c) = pmnf_l1s1(c)
net_nmin(c) = net_nmin(c) - pmnf_l1s1(c)
end if
! litter 2 fluxes (cellulose pool)
if (litr2c(c) > 0._r8) then
if (pmnf_l2s2(c) > 0._r8) then
plitr2c_loss(c) = plitr2c_loss(c) * fpi(c)
pmnf_l2s2(c) = pmnf_l2s2(c) * fpi(c)
sminn_to_denit_l2s2(c) = 0._r8
else
sminn_to_denit_l2s2(c) = -dnp * pmnf_l2s2(c)
end if
litr2_hr(c) = rf_l2s2 * plitr2c_loss(c)
litr2c_to_soil2c(c) = (1._r8 - rf_l2s2) * plitr2c_loss(c)
if (litr2n(c) > 0._r8) litr2n_to_soil2n(c) = plitr2c_loss(c) / cn_l2(c)
sminn_to_soil2n_l2(c) = pmnf_l2s2(c)
net_nmin(c) = net_nmin(c) - pmnf_l2s2(c)
end if
! litter 3 fluxes (lignin pool)
if (litr3c(c) > 0._r8) then
if (pmnf_l3s3(c) > 0._r8) then
plitr3c_loss(c) = plitr3c_loss(c) * fpi(c)
pmnf_l3s3(c) = pmnf_l3s3(c) * fpi(c)
sminn_to_denit_l3s3(c) = 0._r8
else
sminn_to_denit_l3s3(c) = -dnp * pmnf_l3s3(c)
end if
litr3_hr(c) = rf_l3s3 * plitr3c_loss(c)
litr3c_to_soil3c(c) = (1._r8 - rf_l3s3) * plitr3c_loss(c)
if (litr3n(c) > 0._r8) litr3n_to_soil3n(c) = plitr3c_loss(c) / cn_l3(c)
sminn_to_soil3n_l3(c) = pmnf_l3s3(c)
net_nmin(c) = net_nmin(c) - pmnf_l3s3(c)
end if
! SOM 1 fluxes (fast rate soil organic matter pool)
if (soil1c(c) > 0._r8) then
if (pmnf_s1s2(c) > 0._r8) then
psoil1c_loss(c) = psoil1c_loss(c) * fpi(c)
pmnf_s1s2(c) = pmnf_s1s2(c) * fpi(c)
sminn_to_denit_s1s2(c) = 0._r8
else
sminn_to_denit_s1s2(c) = -dnp * pmnf_s1s2(c)
end if
soil1_hr(c) = rf_s1s2 * psoil1c_loss(c)
soil1c_to_soil2c(c) = (1._r8 - rf_s1s2) * psoil1c_loss(c)
soil1n_to_soil2n(c) = psoil1c_loss(c) / cn_s1
sminn_to_soil2n_s1(c) = pmnf_s1s2(c)
net_nmin(c) = net_nmin(c) - pmnf_s1s2(c)
end if
! SOM 2 fluxes (medium rate soil organic matter pool)
if (soil2c(c) > 0._r8) then
if (pmnf_s2s3(c) > 0._r8) then
psoil2c_loss(c) = psoil2c_loss(c) * fpi(c)
pmnf_s2s3(c) = pmnf_s2s3(c) * fpi(c)
sminn_to_denit_s2s3(c) = 0._r8
else
sminn_to_denit_s2s3(c) = -dnp * pmnf_s2s3(c)
end if
soil2_hr(c) = rf_s2s3 * psoil2c_loss(c)
soil2c_to_soil3c(c) = (1._r8 - rf_s2s3) * psoil2c_loss(c)
soil2n_to_soil3n(c) = psoil2c_loss(c) / cn_s2
sminn_to_soil3n_s2(c) = pmnf_s2s3(c)
net_nmin(c) = net_nmin(c) - pmnf_s2s3(c)
end if
! SOM 3 fluxes (slow rate soil organic matter pool)
if (soil3c(c) > 0._r8) then
if (pmnf_s3s4(c) > 0._r8) then
psoil3c_loss(c) = psoil3c_loss(c) * fpi(c)
pmnf_s3s4(c) = pmnf_s3s4(c) * fpi(c)
sminn_to_denit_s3s4(c) = 0._r8
else
sminn_to_denit_s3s4(c) = -dnp * pmnf_s3s4(c)
end if
soil3_hr(c) = rf_s3s4 * psoil3c_loss(c)
soil3c_to_soil4c(c) = (1._r8 - rf_s3s4) * psoil3c_loss(c)
soil3n_to_soil4n(c) = psoil3c_loss(c) / cn_s3
sminn_to_soil4n_s3(c) = pmnf_s3s4(c)
net_nmin(c) = net_nmin(c) - pmnf_s3s4(c)
end if
! SOM 4 fluxes (slowest rate soil organic matter pool)
if (soil4c(c) > 0._r8) then
soil4_hr(c) = psoil4c_loss(c)
soil4n_to_sminn(c) = psoil4c_loss(c) / cn_s4
sminn_to_denit_s4(c) = -dnp * pmnf_s4(c)
net_nmin(c) = net_nmin(c) - pmnf_s4(c)
end if
end do
deallocate(fr)
end subroutine CNDecompAlloc
!-----------------------------------------------------------------------
#endif
end module CNDecompMod
module CNSetValueMod 4,3
#if (defined CN)
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNSetValueMod
!
! !DESCRIPTION:
! contains code to set all CN variables to specified value
! Used for both initialization of special landunit values, and
! setting fluxes to 0.0 at the beginning of each time step
! 3/23/09, Peter Thornton: Added new subroutine, CNZeroFluxes_dwt(),
! which initialize flux variables used in the pftdyn
! routines. This is called from clm_driver1, as
! these variables need to be initialized outside of the clumps loop.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varpar , only: nlevgrnd
!ylu remove use clm_varctl , only: iulog
use clmtype
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: CNZeroFluxes
public :: CNZeroFluxes_dwt
public :: CNSetPps
public :: CNSetPepv
public :: CNSetPcs
public :: CNSetPns
public :: CNSetPcf
public :: CNSetPnf
public :: CNSetCps
public :: CNSetCcs
public :: CNSetCns
public :: CNSetCcf
public :: CNSetCnf
! !PRIVATE MEMBER FUNCTIONS:
!
! !REVISION HISTORY:
! 9/04/03: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNZeroFluxes
!
! !INTERFACE:
subroutine CNZeroFluxes(num_filterc, filterc, num_filterp, filterp) 1,8
!
! !DESCRIPTION:
!
! !USES:
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_filterc ! number of good values in filterc
integer, intent(in) :: filterc(:) ! column filter
integer, intent(in) :: num_filterp ! number of good values in filterp
integer, intent(in) :: filterp(:) ! pft filter
!
! !CALLED FROM:
! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90
!
! !REVISION HISTORY:
! 9/04/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
!
! local pointers to implicit in/out scalars
!
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
!EOP
!-----------------------------------------------------------------------
! zero the column-level C and N fluxes
call CNSetCcf(num_filterc, filterc, 0._r8, clm3%g%l%c%ccf)
#if (defined C13)
call CNSetCcf(num_filterc, filterc, 0._r8, clm3%g%l%c%cc13f)
#endif
call CNSetCnf(num_filterc, filterc, 0._r8, clm3%g%l%c%cnf)
! zero the column-average pft-level C and N fluxes
call CNSetPcf(num_filterc, filterc, 0._r8, clm3%g%l%c%ccf%pcf_a)
call CNSetPnf(num_filterc, filterc, 0._r8, clm3%g%l%c%cnf%pnf_a)
! zero the pft-level C and N fluxes
call CNSetPcf(num_filterp, filterp, 0._r8, clm3%g%l%c%p%pcf)
#if (defined C13)
call CNSetPcf(num_filterp, filterp, 0._r8, clm3%g%l%c%p%pc13f)
#endif
call CNSetPnf(num_filterp, filterp, 0._r8, clm3%g%l%c%p%pnf)
end subroutine CNZeroFluxes
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNZeroFluxes_dwt
!
! !INTERFACE:
subroutine CNZeroFluxes_dwt() 2,2
!
! !DESCRIPTION:
!
! !USES:
use decompMod , only : get_proc_bounds
!
! !ARGUMENTS:
implicit none
!
! !CALLED FROM:
! subroutine clm_driver1
!
! !REVISION HISTORY:
! 3/23/09: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
!
! local pointers to implicit in/out scalars
!
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: begp, endp ! proc beginning and ending pft indices
integer :: begc, endc ! proc beginning and ending column indices
integer :: begl, endl ! proc beginning and ending landunit indices
integer :: begg, endg ! proc beginning and ending gridcell indices
integer :: c, p ! indices
type(column_type), pointer :: cptr ! pointer to column derived subtype
!EOP
!-----------------------------------------------------------------------
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
cptr => clm3%g%l%c
! set column-level conversion and product pool fluxes
! to 0 at the beginning of every timestep
do c = begc,endc
! C fluxes
cptr%ccf%dwt_seedc_to_leaf(c) = 0._r8
cptr%ccf%dwt_seedc_to_deadstem(c) = 0._r8
cptr%ccf%dwt_conv_cflux(c) = 0._r8
cptr%ccf%dwt_prod10c_gain(c) = 0._r8
cptr%ccf%dwt_prod100c_gain(c) = 0._r8
cptr%ccf%dwt_frootc_to_litr1c(c) = 0._r8
cptr%ccf%dwt_frootc_to_litr2c(c) = 0._r8
cptr%ccf%dwt_frootc_to_litr3c(c) = 0._r8
cptr%ccf%dwt_livecrootc_to_cwdc(c) = 0._r8
cptr%ccf%dwt_deadcrootc_to_cwdc(c) = 0._r8
#if (defined C13)
! C13 fluxes
cptr%cc13f%dwt_seedc_to_leaf(c) = 0._r8
cptr%cc13f%dwt_seedc_to_deadstem(c) = 0._r8
cptr%cc13f%dwt_conv_cflux(c) = 0._r8
cptr%cc13f%dwt_prod10c_gain(c) = 0._r8
cptr%cc13f%dwt_prod100c_gain(c) = 0._r8
cptr%cc13f%dwt_frootc_to_litr1c(c) = 0._r8
cptr%cc13f%dwt_frootc_to_litr2c(c) = 0._r8
cptr%cc13f%dwt_frootc_to_litr3c(c) = 0._r8
cptr%cc13f%dwt_livecrootc_to_cwdc(c) = 0._r8
cptr%cc13f%dwt_deadcrootc_to_cwdc(c) = 0._r8
#endif
! N fluxes
cptr%cnf%dwt_seedn_to_leaf(c) = 0._r8
cptr%cnf%dwt_seedn_to_deadstem(c) = 0._r8
cptr%cnf%dwt_conv_nflux(c) = 0._r8
cptr%cnf%dwt_prod10n_gain(c) = 0._r8
cptr%cnf%dwt_prod100n_gain(c) = 0._r8
cptr%cnf%dwt_frootn_to_litr1n(c) = 0._r8
cptr%cnf%dwt_frootn_to_litr2n(c) = 0._r8
cptr%cnf%dwt_frootn_to_litr3n(c) = 0._r8
cptr%cnf%dwt_livecrootn_to_cwdn(c) = 0._r8
cptr%cnf%dwt_deadcrootn_to_cwdn(c) = 0._r8
end do
#if (defined CN)
do p = begp,endp
cptr%p%pcs%dispvegc(p) = 0._r8
cptr%p%pcs%storvegc(p) = 0._r8
cptr%p%pcs%totpftc(p) = 0._r8
#if (defined C13)
cptr%p%pc13s%dispvegc(p) = 0._r8
cptr%p%pc13s%storvegc(p) = 0._r8
cptr%p%pc13s%totpftc(p) = 0._r8
#endif
cptr%p%pns%dispvegn(p) = 0._r8
cptr%p%pns%storvegn(p) = 0._r8
cptr%p%pns%totvegn(p) = 0._r8
cptr%p%pns%totpftn(p) = 0._r8
end do
#endif
end subroutine CNZeroFluxes_dwt
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetPps
!
! !INTERFACE:
subroutine CNSetPps(num, filter, val, pps) 2,1
!
! !DESCRIPTION:
! Set pft physical state variables
! !USES:
use clm_varpar , only : numrad
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (pft_pstate_type), intent(inout) :: pps
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i,j ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
pps%slasun(i) = val
pps%slasha(i) = val
pps%lncsun(i) = val
pps%lncsha(i) = val
pps%vcmxsun(i) = val
pps%vcmxsha(i) = val
pps%gdir(i) = val
end do
do j = 1,numrad
do fi = 1,num
i = filter(fi)
pps%omega(i,j) = val
pps%eff_kid(i,j) = val
pps%eff_kii(i,j) = val
pps%sun_faid(i,j) = val
pps%sun_faii(i,j) = val
pps%sha_faid(i,j) = val
pps%sha_faii(i,j) = val
end do
end do
end subroutine CNSetPps
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetPepv
!
! !INTERFACE:
subroutine CNSetPepv (num, filter, val, pepv) 1
!
! !DESCRIPTION:
! Set pft ecophysiological variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (pft_epv_type), intent(inout) :: pepv
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
pepv%dormant_flag(i) = val
pepv%days_active(i) = val
pepv%onset_flag(i) = val
pepv%onset_counter(i) = val
pepv%onset_gddflag(i) = val
pepv%onset_fdd(i) = val
pepv%onset_gdd(i) = val
pepv%onset_swi(i) = val
pepv%offset_flag(i) = val
pepv%offset_counter(i) = val
pepv%offset_fdd(i) = val
pepv%offset_swi(i) = val
pepv%lgsf(i) = val
pepv%bglfr(i) = val
pepv%bgtr(i) = val
pepv%dayl(i) = val
pepv%prev_dayl(i) = val
pepv%annavg_t2m(i) = val
pepv%tempavg_t2m(i) = val
pepv%gpp(i) = val
pepv%availc(i) = val
pepv%xsmrpool_recover(i) = val
#if (defined C13)
pepv%xsmrpool_c13ratio(i) = val
#endif
pepv%alloc_pnow(i) = val
pepv%c_allometry(i) = val
pepv%n_allometry(i) = val
pepv%plant_ndemand(i) = val
pepv%tempsum_potential_gpp(i) = val
pepv%annsum_potential_gpp(i) = val
pepv%tempmax_retransn(i) = val
pepv%annmax_retransn(i) = val
pepv%avail_retransn(i) = val
pepv%plant_nalloc(i) = val
pepv%plant_calloc(i) = val
pepv%excess_cflux(i) = val
pepv%downreg(i) = val
pepv%prev_leafc_to_litter(i) = val
pepv%prev_frootc_to_litter(i) = val
pepv%tempsum_npp(i) = val
pepv%annsum_npp(i) = val
#if (defined CNDV)
pepv%tempsum_litfall(i) = val
pepv%annsum_litfall(i) = val
#endif
end do
end subroutine CNSetPepv
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetPcs
!
! !INTERFACE:
subroutine CNSetPcs (num, filter, val, pcs) 3
!
! !DESCRIPTION:
! Set pft carbon state variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (pft_cstate_type), intent(inout) :: pcs
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
pcs%leafc(i) = val
pcs%leafc_storage(i) = val
pcs%leafc_xfer(i) = val
pcs%frootc(i) = val
pcs%frootc_storage(i) = val
pcs%frootc_xfer(i) = val
pcs%livestemc(i) = val
pcs%livestemc_storage(i) = val
pcs%livestemc_xfer(i) = val
pcs%deadstemc(i) = val
pcs%deadstemc_storage(i) = val
pcs%deadstemc_xfer(i) = val
pcs%livecrootc(i) = val
pcs%livecrootc_storage(i) = val
pcs%livecrootc_xfer(i) = val
pcs%deadcrootc(i) = val
pcs%deadcrootc_storage(i) = val
pcs%deadcrootc_xfer(i) = val
pcs%gresp_storage(i) = val
pcs%gresp_xfer(i) = val
pcs%cpool(i) = val
pcs%xsmrpool(i) = val
pcs%pft_ctrunc(i) = val
pcs%dispvegc(i) = val
pcs%storvegc(i) = val
pcs%totvegc(i) = val
pcs%totpftc(i) = val
#if (defined CLAMP)
! CLAMP variables
pcs%woodc(i) = val
#endif
#if (defined CROP)
pcs%grainc(i) = val
pcs%grainc_storage(i) = val
pcs%grainc_xfer(i) = val
#endif
end do
end subroutine CNSetPcs
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetPns
!
! !INTERFACE:
subroutine CNSetPns(num, filter, val, pns) 2
!
! !DESCRIPTION:
! Set pft nitrogen state variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (pft_nstate_type), intent(inout) :: pns
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
pns%leafn(i) = val
pns%leafn_storage(i) = val
pns%leafn_xfer(i) = val
pns%frootn(i) = val
pns%frootn_storage(i) = val
pns%frootn_xfer(i) = val
pns%livestemn(i) = val
pns%livestemn_storage(i) = val
pns%livestemn_xfer(i) = val
pns%deadstemn(i) = val
pns%deadstemn_storage(i) = val
pns%deadstemn_xfer(i) = val
pns%livecrootn(i) = val
pns%livecrootn_storage(i) = val
pns%livecrootn_xfer(i) = val
pns%deadcrootn(i) = val
pns%deadcrootn_storage(i) = val
pns%deadcrootn_xfer(i) = val
pns%retransn(i) = val
pns%npool(i) = val
pns%pft_ntrunc(i) = val
pns%dispvegn(i) = val
pns%storvegn(i) = val
pns%totvegn(i) = val
pns%totpftn(i) = val
#if (defined CROP)
pns%grainn(i) = val
pns%grainn_storage(i) = val
pns%grainn_xfer(i) = val
#endif
end do
end subroutine CNSetPns
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetPcf
!
! !INTERFACE:
subroutine CNSetPcf(num, filter, val, pcf) 6
!
! !DESCRIPTION:
! Set pft carbon flux variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (pft_cflux_type), intent(inout) :: pcf
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
pcf%m_leafc_to_litter(i) = val
pcf%m_frootc_to_litter(i) = val
pcf%m_leafc_storage_to_litter(i) = val
pcf%m_frootc_storage_to_litter(i) = val
pcf%m_livestemc_storage_to_litter(i) = val
pcf%m_deadstemc_storage_to_litter(i) = val
pcf%m_livecrootc_storage_to_litter(i) = val
pcf%m_deadcrootc_storage_to_litter(i) = val
pcf%m_leafc_xfer_to_litter(i) = val
pcf%m_frootc_xfer_to_litter(i) = val
pcf%m_livestemc_xfer_to_litter(i) = val
pcf%m_deadstemc_xfer_to_litter(i) = val
pcf%m_livecrootc_xfer_to_litter(i) = val
pcf%m_deadcrootc_xfer_to_litter(i) = val
pcf%m_livestemc_to_litter(i) = val
pcf%m_deadstemc_to_litter(i) = val
pcf%m_livecrootc_to_litter(i) = val
pcf%m_deadcrootc_to_litter(i) = val
pcf%m_gresp_storage_to_litter(i) = val
pcf%m_gresp_xfer_to_litter(i) = val
pcf%hrv_leafc_to_litter(i) = val
pcf%hrv_leafc_storage_to_litter(i) = val
pcf%hrv_leafc_xfer_to_litter(i) = val
pcf%hrv_frootc_to_litter(i) = val
pcf%hrv_frootc_storage_to_litter(i) = val
pcf%hrv_frootc_xfer_to_litter(i) = val
pcf%hrv_livestemc_to_litter(i) = val
pcf%hrv_livestemc_storage_to_litter(i) = val
pcf%hrv_livestemc_xfer_to_litter(i) = val
pcf%hrv_deadstemc_to_prod10c(i) = val
pcf%hrv_deadstemc_to_prod100c(i) = val
pcf%hrv_deadstemc_storage_to_litter(i) = val
pcf%hrv_deadstemc_xfer_to_litter(i) = val
pcf%hrv_livecrootc_to_litter(i) = val
pcf%hrv_livecrootc_storage_to_litter(i) = val
pcf%hrv_livecrootc_xfer_to_litter(i) = val
pcf%hrv_deadcrootc_to_litter(i) = val
pcf%hrv_deadcrootc_storage_to_litter(i) = val
pcf%hrv_deadcrootc_xfer_to_litter(i) = val
pcf%hrv_gresp_storage_to_litter(i) = val
pcf%hrv_gresp_xfer_to_litter(i) = val
pcf%hrv_xsmrpool_to_atm(i) = val
pcf%m_leafc_to_fire(i) = val
pcf%m_frootc_to_fire(i) = val
pcf%m_leafc_storage_to_fire(i) = val
pcf%m_frootc_storage_to_fire(i) = val
pcf%m_livestemc_storage_to_fire(i) = val
pcf%m_deadstemc_storage_to_fire(i) = val
pcf%m_livecrootc_storage_to_fire(i) = val
pcf%m_deadcrootc_storage_to_fire(i) = val
pcf%m_leafc_xfer_to_fire(i) = val
pcf%m_frootc_xfer_to_fire(i) = val
pcf%m_livestemc_xfer_to_fire(i) = val
pcf%m_deadstemc_xfer_to_fire(i) = val
pcf%m_livecrootc_xfer_to_fire(i) = val
pcf%m_deadcrootc_xfer_to_fire(i) = val
pcf%m_livestemc_to_fire(i) = val
pcf%m_deadstemc_to_fire(i) = val
pcf%m_deadstemc_to_litter_fire(i) = val
pcf%m_livecrootc_to_fire(i) = val
pcf%m_deadcrootc_to_fire(i) = val
pcf%m_deadcrootc_to_litter_fire(i) = val
pcf%m_gresp_storage_to_fire(i) = val
pcf%m_gresp_xfer_to_fire(i) = val
pcf%leafc_xfer_to_leafc(i) = val
pcf%frootc_xfer_to_frootc(i) = val
pcf%livestemc_xfer_to_livestemc(i) = val
pcf%deadstemc_xfer_to_deadstemc(i) = val
pcf%livecrootc_xfer_to_livecrootc(i) = val
pcf%deadcrootc_xfer_to_deadcrootc(i) = val
pcf%leafc_to_litter(i) = val
pcf%frootc_to_litter(i) = val
pcf%leaf_mr(i) = val
pcf%froot_mr(i) = val
pcf%livestem_mr(i) = val
pcf%livecroot_mr(i) = val
pcf%leaf_curmr(i) = val
pcf%froot_curmr(i) = val
pcf%livestem_curmr(i) = val
pcf%livecroot_curmr(i) = val
pcf%leaf_xsmr(i) = val
pcf%froot_xsmr(i) = val
pcf%livestem_xsmr(i) = val
pcf%livecroot_xsmr(i) = val
pcf%psnsun_to_cpool(i) = val
pcf%psnshade_to_cpool(i) = val
pcf%cpool_to_xsmrpool(i) = val
pcf%cpool_to_leafc(i) = val
pcf%cpool_to_leafc_storage(i) = val
pcf%cpool_to_frootc(i) = val
pcf%cpool_to_frootc_storage(i) = val
pcf%cpool_to_livestemc(i) = val
pcf%cpool_to_livestemc_storage(i) = val
pcf%cpool_to_deadstemc(i) = val
pcf%cpool_to_deadstemc_storage(i) = val
pcf%cpool_to_livecrootc(i) = val
pcf%cpool_to_livecrootc_storage(i) = val
pcf%cpool_to_deadcrootc(i) = val
pcf%cpool_to_deadcrootc_storage(i) = val
pcf%cpool_to_gresp_storage(i) = val
pcf%cpool_leaf_gr(i) = val
pcf%cpool_leaf_storage_gr(i) = val
pcf%transfer_leaf_gr(i) = val
pcf%cpool_froot_gr(i) = val
pcf%cpool_froot_storage_gr(i) = val
pcf%transfer_froot_gr(i) = val
pcf%cpool_livestem_gr(i) = val
pcf%cpool_livestem_storage_gr(i) = val
pcf%transfer_livestem_gr(i) = val
pcf%cpool_deadstem_gr(i) = val
pcf%cpool_deadstem_storage_gr(i) = val
pcf%transfer_deadstem_gr(i) = val
pcf%cpool_livecroot_gr(i) = val
pcf%cpool_livecroot_storage_gr(i) = val
pcf%transfer_livecroot_gr(i) = val
pcf%cpool_deadcroot_gr(i) = val
pcf%cpool_deadcroot_storage_gr(i) = val
pcf%transfer_deadcroot_gr(i) = val
pcf%leafc_storage_to_xfer(i) = val
pcf%frootc_storage_to_xfer(i) = val
pcf%livestemc_storage_to_xfer(i) = val
pcf%deadstemc_storage_to_xfer(i) = val
pcf%livecrootc_storage_to_xfer(i) = val
pcf%deadcrootc_storage_to_xfer(i) = val
pcf%gresp_storage_to_xfer(i) = val
pcf%livestemc_to_deadstemc(i) = val
pcf%livecrootc_to_deadcrootc(i) = val
pcf%gpp(i) = val
pcf%mr(i) = val
pcf%current_gr(i) = val
pcf%transfer_gr(i) = val
pcf%storage_gr(i) = val
pcf%gr(i) = val
pcf%ar(i) = val
pcf%rr(i) = val
pcf%npp(i) = val
pcf%agnpp(i) = val
pcf%bgnpp(i) = val
pcf%litfall(i) = val
pcf%vegfire(i) = val
pcf%wood_harvestc(i) = val
pcf%pft_cinputs(i) = val
pcf%pft_coutputs(i) = val
pcf%pft_fire_closs(i) = val
#if (defined CLAMP)
!CLAMP
pcf%frootc_alloc(i) = val
pcf%frootc_loss(i) = val
pcf%leafc_alloc(i) = val
pcf%leafc_loss(i) = val
pcf%woodc_alloc(i) = val
pcf%woodc_loss(i) = val
#endif
#if (defined CROP)
pcf%xsmrpool_to_atm(i) = val
pcf%livestemc_to_litter(i) = val
pcf%grainc_to_food(i) = val
pcf%grainc_xfer_to_grainc(i) = val
pcf%cpool_to_grainc(i) = val
pcf%cpool_to_grainc_storage(i) = val
pcf%cpool_grain_gr(i) = val
pcf%cpool_grain_storage_gr(i) = val
pcf%transfer_grain_gr(i) = val
pcf%grainc_storage_to_xfer(i) = val
#endif
end do
end subroutine CNSetPcf
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetPnf
!
! !INTERFACE:
subroutine CNSetPnf(num, filter, val, pnf) 4
!
! !DESCRIPTION:
! Set pft nitrogen flux variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (pft_nflux_type), intent(inout) :: pnf
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i=filter(fi)
pnf%m_leafn_to_litter(i) = val
pnf%m_frootn_to_litter(i) = val
pnf%m_leafn_storage_to_litter(i) = val
pnf%m_frootn_storage_to_litter(i) = val
pnf%m_livestemn_storage_to_litter(i) = val
pnf%m_deadstemn_storage_to_litter(i) = val
pnf%m_livecrootn_storage_to_litter(i) = val
pnf%m_deadcrootn_storage_to_litter(i) = val
pnf%m_leafn_xfer_to_litter(i) = val
pnf%m_frootn_xfer_to_litter(i) = val
pnf%m_livestemn_xfer_to_litter(i) = val
pnf%m_deadstemn_xfer_to_litter(i) = val
pnf%m_livecrootn_xfer_to_litter(i) = val
pnf%m_deadcrootn_xfer_to_litter(i) = val
pnf%m_livestemn_to_litter(i) = val
pnf%m_deadstemn_to_litter(i) = val
pnf%m_livecrootn_to_litter(i) = val
pnf%m_deadcrootn_to_litter(i) = val
pnf%m_retransn_to_litter(i) = val
pnf%hrv_leafn_to_litter(i) = val
pnf%hrv_frootn_to_litter(i) = val
pnf%hrv_leafn_storage_to_litter(i) = val
pnf%hrv_frootn_storage_to_litter(i) = val
pnf%hrv_livestemn_storage_to_litter(i) = val
pnf%hrv_deadstemn_storage_to_litter(i) = val
pnf%hrv_livecrootn_storage_to_litter(i) = val
pnf%hrv_deadcrootn_storage_to_litter(i) = val
pnf%hrv_leafn_xfer_to_litter(i) = val
pnf%hrv_frootn_xfer_to_litter(i) = val
pnf%hrv_livestemn_xfer_to_litter(i) = val
pnf%hrv_deadstemn_xfer_to_litter(i) = val
pnf%hrv_livecrootn_xfer_to_litter(i) = val
pnf%hrv_deadcrootn_xfer_to_litter(i) = val
pnf%hrv_livestemn_to_litter(i) = val
pnf%hrv_deadstemn_to_prod10n(i) = val
pnf%hrv_deadstemn_to_prod100n(i) = val
pnf%hrv_livecrootn_to_litter(i) = val
pnf%hrv_deadcrootn_to_litter(i) = val
pnf%hrv_retransn_to_litter(i) = val
pnf%m_leafn_to_fire(i) = val
pnf%m_frootn_to_fire(i) = val
pnf%m_leafn_storage_to_fire(i) = val
pnf%m_frootn_storage_to_fire(i) = val
pnf%m_livestemn_storage_to_fire(i) = val
pnf%m_deadstemn_storage_to_fire(i) = val
pnf%m_livecrootn_storage_to_fire(i) = val
pnf%m_deadcrootn_storage_to_fire(i) = val
pnf%m_leafn_xfer_to_fire(i) = val
pnf%m_frootn_xfer_to_fire(i) = val
pnf%m_livestemn_xfer_to_fire(i) = val
pnf%m_deadstemn_xfer_to_fire(i) = val
pnf%m_livecrootn_xfer_to_fire(i) = val
pnf%m_deadcrootn_xfer_to_fire(i) = val
pnf%m_livestemn_to_fire(i) = val
pnf%m_deadstemn_to_fire(i) = val
pnf%m_deadstemn_to_litter_fire(i) = val
pnf%m_livecrootn_to_fire(i) = val
pnf%m_deadcrootn_to_fire(i) = val
pnf%m_deadcrootn_to_litter_fire(i) = val
pnf%m_retransn_to_fire(i) = val
pnf%leafn_xfer_to_leafn(i) = val
pnf%frootn_xfer_to_frootn(i) = val
pnf%livestemn_xfer_to_livestemn(i) = val
pnf%deadstemn_xfer_to_deadstemn(i) = val
pnf%livecrootn_xfer_to_livecrootn(i) = val
pnf%deadcrootn_xfer_to_deadcrootn(i) = val
pnf%leafn_to_litter(i) = val
pnf%leafn_to_retransn(i) = val
pnf%frootn_to_litter(i) = val
pnf%retransn_to_npool(i) = val
pnf%sminn_to_npool(i) = val
pnf%npool_to_leafn(i) = val
pnf%npool_to_leafn_storage(i) = val
pnf%npool_to_frootn(i) = val
pnf%npool_to_frootn_storage(i) = val
pnf%npool_to_livestemn(i) = val
pnf%npool_to_livestemn_storage(i) = val
pnf%npool_to_deadstemn(i) = val
pnf%npool_to_deadstemn_storage(i) = val
pnf%npool_to_livecrootn(i) = val
pnf%npool_to_livecrootn_storage(i) = val
pnf%npool_to_deadcrootn(i) = val
pnf%npool_to_deadcrootn_storage(i) = val
pnf%leafn_storage_to_xfer(i) = val
pnf%frootn_storage_to_xfer(i) = val
pnf%livestemn_storage_to_xfer(i) = val
pnf%deadstemn_storage_to_xfer(i) = val
pnf%livecrootn_storage_to_xfer(i) = val
pnf%deadcrootn_storage_to_xfer(i) = val
pnf%livestemn_to_deadstemn(i) = val
pnf%livestemn_to_retransn(i) = val
pnf%livecrootn_to_deadcrootn(i) = val
pnf%livecrootn_to_retransn(i) = val
pnf%ndeploy(i) = val
pnf%pft_ninputs(i) = val
pnf%pft_noutputs(i) = val
pnf%wood_harvestn(i) = val
pnf%pft_fire_nloss(i) = val
#if (defined CROP)
pnf%livestemn_to_litter(i) = val
pnf%grainn_to_food(i) = val
pnf%grainn_xfer_to_grainn(i) = val
pnf%npool_to_grainn(i) = val
pnf%npool_to_grainn_storage(i) = val
pnf%grainn_storage_to_xfer(i) = val
#endif
end do
end subroutine CNSetPnf
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetCps
!
! !INTERFACE:
subroutine CNSetCps(num, filter, val, cps) 2
!
! !DESCRIPTION:
! Set column physical state variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (column_pstate_type), intent(inout) :: cps
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i,j ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
cps%decl(i) = val
cps%coszen(i) = val
cps%fpi(i) = val
cps%fpg(i) = val
cps%annsum_counter(i) = val
cps%cannsum_npp(i) = val
cps%cannavg_t2m(i) = val
cps%wf(i) = val
cps%me(i) = val
cps%fire_prob(i) = val
cps%mean_fire_prob(i) = val
cps%fireseasonl(i) = val
cps%farea_burned(i) = val
cps%ann_farea_burned(i) = val
end do
do j = 1,nlevgrnd
do fi = 1,num
i = filter(fi)
cps%bsw2(i,j) = val
cps%psisat(i,j) = val
cps%vwcsat(i,j) = val
cps%soilpsi(i,j) = val
end do
end do
end subroutine CNSetCps
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetCcs
!
! !INTERFACE:
subroutine CNSetCcs(num, filter, val, ccs) 2
!
! !DESCRIPTION:
! Set column carbon state variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (column_cstate_type), intent(inout) :: ccs
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
ccs%cwdc(i) = val
ccs%litr1c(i) = val
ccs%litr2c(i) = val
ccs%litr3c(i) = val
ccs%soil1c(i) = val
ccs%soil2c(i) = val
ccs%soil3c(i) = val
ccs%soil4c(i) = val
ccs%col_ctrunc(i) = val
ccs%totlitc(i) = val
ccs%totsomc(i) = val
ccs%totecosysc(i) = val
ccs%totcolc(i) = val
end do
end subroutine CNSetCcs
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetCns
!
! !INTERFACE:
subroutine CNSetCns(num, filter, val, cns) 1
!
! !DESCRIPTION:
! Set column nitrogen state variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (column_nstate_type), intent(inout) :: cns
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
cns%cwdn(i) = val
cns%litr1n(i) = val
cns%litr2n(i) = val
cns%litr3n(i) = val
cns%soil1n(i) = val
cns%soil2n(i) = val
cns%soil3n(i) = val
cns%soil4n(i) = val
cns%sminn(i) = val
cns%col_ntrunc(i) = val
cns%totlitn(i) = val
cns%totsomn(i) = val
cns%totecosysn(i) = val
cns%totcoln(i) = val
end do
end subroutine CNSetCns
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetCcf
!
! !INTERFACE:
subroutine CNSetCcf(num, filter, val, ccf) 4
!
! !DESCRIPTION:
! Set column carbon flux variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (column_cflux_type), intent(inout) :: ccf
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
ccf%m_leafc_to_litr1c(i) = val
ccf%m_leafc_to_litr2c(i) = val
ccf%m_leafc_to_litr3c(i) = val
ccf%m_frootc_to_litr1c(i) = val
ccf%m_frootc_to_litr2c(i) = val
ccf%m_frootc_to_litr3c(i) = val
ccf%m_leafc_storage_to_litr1c(i) = val
ccf%m_frootc_storage_to_litr1c(i) = val
ccf%m_livestemc_storage_to_litr1c(i) = val
ccf%m_deadstemc_storage_to_litr1c(i) = val
ccf%m_livecrootc_storage_to_litr1c(i) = val
ccf%m_deadcrootc_storage_to_litr1c(i) = val
ccf%m_leafc_xfer_to_litr1c(i) = val
ccf%m_frootc_xfer_to_litr1c(i) = val
ccf%m_livestemc_xfer_to_litr1c(i) = val
ccf%m_deadstemc_xfer_to_litr1c(i) = val
ccf%m_livecrootc_xfer_to_litr1c(i) = val
ccf%m_deadcrootc_xfer_to_litr1c(i) = val
ccf%m_livestemc_to_cwdc(i) = val
ccf%m_deadstemc_to_cwdc(i) = val
ccf%m_livecrootc_to_cwdc(i) = val
ccf%m_deadcrootc_to_cwdc(i) = val
ccf%m_gresp_storage_to_litr1c(i) = val
ccf%m_gresp_xfer_to_litr1c(i) = val
ccf%hrv_leafc_to_litr1c(i) = val
ccf%hrv_leafc_to_litr2c(i) = val
ccf%hrv_leafc_to_litr3c(i) = val
ccf%hrv_frootc_to_litr1c(i) = val
ccf%hrv_frootc_to_litr2c(i) = val
ccf%hrv_frootc_to_litr3c(i) = val
ccf%hrv_livestemc_to_cwdc(i) = val
ccf%hrv_deadstemc_to_prod10c(i) = val
ccf%hrv_deadstemc_to_prod100c(i) = val
ccf%hrv_livecrootc_to_cwdc(i) = val
ccf%hrv_deadcrootc_to_cwdc(i) = val
ccf%hrv_leafc_storage_to_litr1c(i) = val
ccf%hrv_frootc_storage_to_litr1c(i) = val
ccf%hrv_livestemc_storage_to_litr1c(i) = val
ccf%hrv_deadstemc_storage_to_litr1c(i) = val
ccf%hrv_livecrootc_storage_to_litr1c(i) = val
ccf%hrv_deadcrootc_storage_to_litr1c(i) = val
#if (defined CROP)
ccf%livestemc_to_litr1c(i) = val
ccf%livestemc_to_litr2c(i) = val
ccf%livestemc_to_litr3c(i) = val
ccf%grainc_to_litr1c(i) = val
ccf%grainc_to_litr2c(i) = val
ccf%grainc_to_litr3c(i) = val
#endif
ccf%hrv_gresp_storage_to_litr1c(i) = val
ccf%hrv_leafc_xfer_to_litr1c(i) = val
ccf%hrv_frootc_xfer_to_litr1c(i) = val
ccf%hrv_livestemc_xfer_to_litr1c(i) = val
ccf%hrv_deadstemc_xfer_to_litr1c(i) = val
ccf%hrv_livecrootc_xfer_to_litr1c(i) = val
ccf%hrv_deadcrootc_xfer_to_litr1c(i) = val
ccf%hrv_gresp_xfer_to_litr1c(i) = val
ccf%m_deadstemc_to_cwdc_fire(i) = val
ccf%m_deadcrootc_to_cwdc_fire(i) = val
ccf%m_litr1c_to_fire(i) = val
ccf%m_litr2c_to_fire(i) = val
ccf%m_litr3c_to_fire(i) = val
ccf%m_cwdc_to_fire(i) = val
ccf%prod10c_loss(i) = val
ccf%prod100c_loss(i) = val
ccf%product_closs(i) = val
ccf%leafc_to_litr1c(i) = val
ccf%leafc_to_litr2c(i) = val
ccf%leafc_to_litr3c(i) = val
ccf%frootc_to_litr1c(i) = val
ccf%frootc_to_litr2c(i) = val
ccf%frootc_to_litr3c(i) = val
ccf%cwdc_to_litr2c(i) = val
ccf%cwdc_to_litr3c(i) = val
ccf%litr1_hr(i) = val
ccf%litr1c_to_soil1c(i) = val
ccf%litr2_hr(i) = val
ccf%litr2c_to_soil2c(i) = val
ccf%litr3_hr(i) = val
ccf%litr3c_to_soil3c(i) = val
ccf%soil1_hr(i) = val
ccf%soil1c_to_soil2c(i) = val
ccf%soil2_hr(i) = val
ccf%soil2c_to_soil3c(i) = val
ccf%soil3_hr(i) = val
ccf%soil3c_to_soil4c(i) = val
ccf%soil4_hr(i) = val
ccf%lithr(i) = val
ccf%somhr(i) = val
ccf%hr(i) = val
ccf%sr(i) = val
ccf%er(i) = val
ccf%litfire(i) = val
ccf%somfire(i) = val
ccf%totfire(i) = val
ccf%nep(i) = val
ccf%nbp(i) = val
ccf%nee(i) = val
ccf%col_cinputs(i) = val
ccf%col_coutputs(i) = val
ccf%col_fire_closs(i) = val
#if (defined CLAMP)
!CLAMP
ccf%cwdc_hr(i) = val
ccf%cwdc_loss(i) = val
ccf%litterc_loss(i) = val
#endif
end do
end subroutine CNSetCcf
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSetCnf
!
! !INTERFACE:
subroutine CNSetCnf(num, filter, val, cnf) 2
!
! !DESCRIPTION:
! Set column nitrogen flux variables
!
! !ARGUMENTS:
implicit none
integer , intent(in) :: num
integer , intent(in) :: filter(:)
real(r8), intent(in) :: val
type (column_nflux_type), intent(inout) :: cnf
!
! !REVISION HISTORY:
! Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in/out arrays
!
! !OTHER LOCAL VARIABLES:
integer :: fi,i ! loop index
!EOP
!------------------------------------------------------------------------
do fi = 1,num
i = filter(fi)
cnf%ndep_to_sminn(i) = val
cnf%nfix_to_sminn(i) = val
cnf%m_leafn_to_litr1n(i) = val
cnf%m_leafn_to_litr2n(i) = val
cnf%m_leafn_to_litr3n(i) = val
cnf%m_frootn_to_litr1n(i) = val
cnf%m_frootn_to_litr2n(i) = val
cnf%m_frootn_to_litr3n(i) = val
cnf%m_leafn_storage_to_litr1n(i) = val
cnf%m_frootn_storage_to_litr1n(i) = val
cnf%m_livestemn_storage_to_litr1n(i) = val
cnf%m_deadstemn_storage_to_litr1n(i) = val
cnf%m_livecrootn_storage_to_litr1n(i) = val
cnf%m_deadcrootn_storage_to_litr1n(i) = val
cnf%m_leafn_xfer_to_litr1n(i) = val
cnf%m_frootn_xfer_to_litr1n(i) = val
cnf%m_livestemn_xfer_to_litr1n(i) = val
cnf%m_deadstemn_xfer_to_litr1n(i) = val
cnf%m_livecrootn_xfer_to_litr1n(i) = val
cnf%m_deadcrootn_xfer_to_litr1n(i) = val
cnf%m_livestemn_to_cwdn(i) = val
cnf%m_deadstemn_to_cwdn(i) = val
cnf%m_livecrootn_to_cwdn(i) = val
cnf%m_deadcrootn_to_cwdn(i) = val
cnf%m_retransn_to_litr1n(i) = val
cnf%hrv_leafn_to_litr1n(i) = val
cnf%hrv_leafn_to_litr2n(i) = val
cnf%hrv_leafn_to_litr3n(i) = val
cnf%hrv_frootn_to_litr1n(i) = val
cnf%hrv_frootn_to_litr2n(i) = val
cnf%hrv_frootn_to_litr3n(i) = val
cnf%hrv_livestemn_to_cwdn(i) = val
cnf%hrv_deadstemn_to_prod10n(i) = val
cnf%hrv_deadstemn_to_prod100n(i) = val
cnf%hrv_livecrootn_to_cwdn(i) = val
cnf%hrv_deadcrootn_to_cwdn(i) = val
cnf%hrv_retransn_to_litr1n(i) = val
cnf%hrv_leafn_storage_to_litr1n(i) = val
cnf%hrv_frootn_storage_to_litr1n(i) = val
cnf%hrv_livestemn_storage_to_litr1n(i) = val
cnf%hrv_deadstemn_storage_to_litr1n(i) = val
cnf%hrv_livecrootn_storage_to_litr1n(i) = val
cnf%hrv_deadcrootn_storage_to_litr1n(i) = val
cnf%hrv_leafn_xfer_to_litr1n(i) = val
cnf%hrv_frootn_xfer_to_litr1n(i) = val
cnf%hrv_livestemn_xfer_to_litr1n(i) = val
cnf%hrv_deadstemn_xfer_to_litr1n(i) = val
cnf%hrv_livecrootn_xfer_to_litr1n(i) = val
cnf%hrv_deadcrootn_xfer_to_litr1n(i) = val
cnf%m_deadstemn_to_cwdn_fire(i) = val
cnf%m_deadcrootn_to_cwdn_fire(i) = val
cnf%m_litr1n_to_fire(i) = val
cnf%m_litr2n_to_fire(i) = val
cnf%m_litr3n_to_fire(i) = val
cnf%m_cwdn_to_fire(i) = val
cnf%prod10n_loss(i) = val
cnf%prod100n_loss(i) = val
cnf%product_nloss(i) = val
#if (defined CROP)
cnf%grainn_to_litr1n(i) = val
cnf%grainn_to_litr2n(i) = val
cnf%grainn_to_litr3n(i) = val
cnf%livestemn_to_litr1n(i) = val
cnf%livestemn_to_litr2n(i) = val
cnf%livestemn_to_litr3n(i) = val
#endif
cnf%leafn_to_litr1n(i) = val
cnf%leafn_to_litr2n(i) = val
cnf%leafn_to_litr3n(i) = val
cnf%frootn_to_litr1n(i) = val
cnf%frootn_to_litr2n(i) = val
cnf%frootn_to_litr3n(i) = val
cnf%cwdn_to_litr2n(i) = val
cnf%cwdn_to_litr3n(i) = val
cnf%litr1n_to_soil1n(i) = val
cnf%sminn_to_soil1n_l1(i) = val
cnf%litr2n_to_soil2n(i) = val
cnf%sminn_to_soil2n_l2(i) = val
cnf%litr3n_to_soil3n(i) = val
cnf%sminn_to_soil3n_l3(i) = val
cnf%soil1n_to_soil2n(i) = val
cnf%sminn_to_soil2n_s1(i) = val
cnf%soil2n_to_soil3n(i) = val
cnf%sminn_to_soil3n_s2(i) = val
cnf%soil3n_to_soil4n(i) = val
cnf%sminn_to_soil4n_s3(i) = val
cnf%soil4n_to_sminn(i) = val
cnf%sminn_to_denit_l1s1(i) = val
cnf%sminn_to_denit_l2s2(i) = val
cnf%sminn_to_denit_l3s3(i) = val
cnf%sminn_to_denit_s1s2(i) = val
cnf%sminn_to_denit_s2s3(i) = val
cnf%sminn_to_denit_s3s4(i) = val
cnf%sminn_to_denit_s4(i) = val
cnf%sminn_to_denit_excess(i) = val
cnf%sminn_leached(i) = val
cnf%potential_immob(i) = val
cnf%actual_immob(i) = val
cnf%sminn_to_plant(i) = val
cnf%supplement_to_sminn(i) = val
cnf%gross_nmin(i) = val
cnf%net_nmin(i) = val
cnf%denit(i) = val
cnf%col_ninputs(i) = val
cnf%col_noutputs(i) = val
cnf%col_fire_nloss(i) = val
end do
end subroutine CNSetCnf
!-----------------------------------------------------------------------
#endif
end module CNSetValueMod
module CNFireMod 1,3
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNFireMod
!
! !DESCRIPTION:
! Module holding routines fire mod
! nitrogen code.
!
! !USES:
use shr_kind_mod , only: r8 => shr_kind_r8
use shr_const_mod, only: SHR_CONST_PI,SHR_CONST_TKFRZ
use pft2colMod , only: p2c
! use clm_varctl , only: iulog
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: CNFireArea
public :: CNFireFluxes
!
! !REVISION HISTORY:
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNFireArea
!
! !INTERFACE:
subroutine CNFireArea (num_soilc, filter_soilc) 1,3
!
! !DESCRIPTION:
! Computes column-level area affected by fire in each timestep
! based on statistical fire model in Thonicke et al. 2001.
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size, get_nstep
use globals , only: dt,nstep
use clm_varpar , only: max_pft_per_col
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
!
! !CALLED FROM:
! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90
!
! !REVISION HISTORY:
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
! pft-level
real(r8), pointer :: wtcol(:) ! pft weight on the column
integer , pointer :: ivt(:) ! vegetation type for this pft
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
! column-level
integer , pointer :: npfts(:) ! number of pfts on the column
integer , pointer :: pfti(:) ! pft index array
real(r8), pointer :: pwtgcell(:) ! weight of pft relative to corresponding gridcell
real(r8), pointer :: wf(:) ! soil water as frac. of whc for top 0.5 m
real(r8), pointer :: t_grnd(:) ! ground temperature (Kelvin)
real(r8), pointer :: totlitc(:) ! (gC/m2) total litter C (not including cwdc)
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
! PET 5/20/08, test to increase fire area
real(r8), pointer :: totvegc(:) ! (gC/m2) total veg C (column-level mean)
! pointers for column averaging
!
! local pointers to implicit in/out scalars
!
! column-level
real(r8), pointer :: me(:) ! column-level moisture of extinction (proportion)
real(r8), pointer :: fire_prob(:) ! daily fire probability (0-1)
real(r8), pointer :: mean_fire_prob(:) ! e-folding mean of daily fire probability (0-1)
real(r8), pointer :: fireseasonl(:) ! annual fire season length (days, <= 365)
real(r8), pointer :: farea_burned(:) ! fractional area burned in this timestep (proportion)
real(r8), pointer :: ann_farea_burned(:) ! annual total fractional area burned (proportion)
!
! !OTHER LOCAL VARIABLES:
! real(r8), parameter:: minfuel = 200.0_r8 ! dead fuel threshold to carry a fire (gC/m2)
! PET, 5/30/08: changed from 200 to 100 gC/m2, since the original paper didn't specify
! the units as carbon, I am assuming that they were in dry biomass, so carbon would be ~50%
real(r8), parameter:: minfuel = 100.0_r8 ! dead fuel threshold to carry a fire (gC/m2)
real(r8), parameter:: me_woody = 0.3_r8 ! moisture of extinction for woody PFTs (proportion)
real(r8), parameter:: me_herb = 0.2_r8 ! moisture of extinction for herbaceous PFTs (proportion)
real(r8), parameter:: ef_time = 1.0_r8 ! e-folding time constant (years)
integer :: fc,c,pi,p ! index variables
! real(r8):: dt ! time step variable (s)
real(r8):: fuelc ! temporary column-level litter + cwd C (gC/m2)
integer :: nef ! number of e-folding timesteps
real(r8):: ef_nsteps ! number of e-folding timesteps (real)
! integer :: nstep ! current timestep number
real(r8):: m ! top-layer soil moisture (proportion)
real(r8):: mep ! pft-level moisture of extinction [proportion]
real(r8):: s2 ! (mean_fire_prob - 1.0)
!EOP
!-----------------------------------------------------------------------
! assign local pointers to derived type members (pft-level)
wtcol => clm3%g%l%c%p%wtcol
ivt => clm3%g%l%c%p%itype
pwtgcell => clm3%g%l%c%p%wtgcell
woody => pftcon%woody
! assign local pointers to derived type members (column-level)
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
wf => clm3%g%l%c%cps%wf
me => clm3%g%l%c%cps%me
fire_prob => clm3%g%l%c%cps%fire_prob
mean_fire_prob => clm3%g%l%c%cps%mean_fire_prob
fireseasonl => clm3%g%l%c%cps%fireseasonl
farea_burned => clm3%g%l%c%cps%farea_burned
ann_farea_burned => clm3%g%l%c%cps%ann_farea_burned
t_grnd => clm3%g%l%c%ces%t_grnd
totlitc => clm3%g%l%c%ccs%totlitc
cwdc => clm3%g%l%c%ccs%cwdc
! PET 5/20/08, test to increase fire area
totvegc => clm3%g%l%c%ccs%pcs_a%totvegc
! pft to column average for moisture of extinction
do fc = 1,num_soilc
c = filter_soilc(fc)
me(c) = 0._r8
end do
mep = me_woody
do pi = 1,max_pft_per_col
do fc = 1,num_soilc
c = filter_soilc(fc)
if (pi <= npfts(c)) then
p = pfti(c) + pi - 1
if (pwtgcell(p)>0._r8) then
if (woody(ivt(p)) == 1) then
mep = me_woody
else
mep = me_herb
end if
end if
me(c) = me(c) + mep*wtcol(p)
end if
end do
end do
! Get model step size
! dt = real( get_step_size(), r8 )
! Set the number of timesteps for e-folding.
! When the simulation has run fewer than this number of steps,
! re-scale the e-folding time to get a stable early estimate.
! nstep = get_nstep()
nef = (ef_time*365._r8*86400._r8)/dt
ef_nsteps = max(1,min(nstep,nef))
! test code, added 6/6/05, PET
! setting ef_nsteps to full count regardless of nstep, to see if this
! gets rid of transient in fire stats for initial run from spunup
! initial conditions
ef_nsteps = nef
! begin column loop to calculate fractional area affected by fire
do fc = 1, num_soilc
c = filter_soilc(fc)
! dead fuel C (total litter + CWD)
fuelc = totlitc(c) + cwdc(c)
! PET 5/20/08, test to increase fire area
! PET, 5/30/08. going back to original treatment using dead fuel only
! fuelc = fuelc + totvegc(c)
! m is the fractional soil mositure in the top layer (taken here
! as the top 0.5 m)
! PET 5/30/08 - note that this has been changed in Hydrology to use top 5 cm.
m = max(0._r8,wf(c))
! Calculate the probability of at least one fire in a day
! in the gridcell. minfuel is the limit for dead fuels below which
! fire is assumed unable to spread.
if (t_grnd(c)>SHR_CONST_TKFRZ .and. fuelc>minfuel .and. me(c)>0._r8 .and. m<=me(c)) then
fire_prob(c) = exp(-SHR_CONST_PI * (m/me(c))**2)
else
fire_prob(c) = 0._r8
end if
! Use e-folding to keep a running mean of daily fire probability,
! which is then used to calculate annual fractional area burned.
! mean_fire_prob corresponds to the variable s from Thonicke.
! fireseasonl corresponds to the variable N from Thonicke.
! ann_farea_burned corresponds to the variable A from Thonicke.
mean_fire_prob(c) = (mean_fire_prob(c)*(ef_nsteps-1._r8) + fire_prob(c))/ef_nsteps
fireseasonl(c) = mean_fire_prob(c) * 365._r8
s2 = mean_fire_prob(c)-1._r8
ann_farea_burned(c) = mean_fire_prob(c)*exp(s2/(0.45_r8*(s2**3) + 2.83_r8*(s2**2) + 2.96_r8*s2 + 1.04_r8))
! Estimate the fractional area of the column affected by fire in this time step.
! Over a year this should sum to a value near the annual
! fractional area burned from equations above.
if (fireseasonl(c) > 0._r8) then
farea_burned(c) = (fire_prob(c)/fireseasonl(c)) * ann_farea_burned(c) * (dt/86400._r8)
else
farea_burned(c) = 0._r8
end if
#if (defined NOFIRE)
! set the fire area 0 if NOFIRE flag is on
farea_burned(c) = 0._r8
#endif
end do ! end of column loop
end subroutine CNFireArea
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNFireFluxes
!
! !INTERFACE:
subroutine CNFireFluxes (num_soilc, filter_soilc, num_soilp, filter_soilp) 1,6
!
! !DESCRIPTION:
! Fire effects routine for coupled carbon-nitrogen code (CN).
! Relies primarily on estimate of fractional area burned in this
! timestep, from CNFireArea().
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size
use globals , only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn()
!
! !REVISION HISTORY:
! 7/23/04: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
#if (defined CNDV)
real(r8), pointer :: nind(:) ! number of individuals (#/m2)
#endif
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
real(r8), pointer :: resist(:) ! resistance to fire (no units)
integer , pointer :: pcolumn(:) ! pft's column index
real(r8), pointer :: farea_burned(:) ! timestep fractional area burned (proportion)
real(r8), pointer :: m_cwdc_to_fire(:)
real(r8), pointer :: m_deadcrootc_to_cwdc_fire(:)
real(r8), pointer :: m_deadstemc_to_cwdc_fire(:)
real(r8), pointer :: m_litr1c_to_fire(:)
real(r8), pointer :: m_litr2c_to_fire(:)
real(r8), pointer :: m_litr3c_to_fire(:)
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: m_cwdn_to_fire(:)
real(r8), pointer :: m_deadcrootn_to_cwdn_fire(:)
real(r8), pointer :: m_deadstemn_to_cwdn_fire(:)
real(r8), pointer :: m_litr1n_to_fire(:)
real(r8), pointer :: m_litr2n_to_fire(:)
real(r8), pointer :: m_litr3n_to_fire(:)
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: litr1n(:) ! (gN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (gN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (gN/m2) litter lignin N
real(r8), pointer :: m_deadcrootc_storage_to_fire(:)
real(r8), pointer :: m_deadcrootc_to_fire(:)
real(r8), pointer :: m_deadcrootc_to_litter_fire(:)
real(r8), pointer :: m_deadcrootc_xfer_to_fire(:)
real(r8), pointer :: m_deadstemc_storage_to_fire(:)
real(r8), pointer :: m_deadstemc_to_fire(:)
real(r8), pointer :: m_deadstemc_to_litter_fire(:)
real(r8), pointer :: m_deadstemc_to_litter(:)
real(r8), pointer :: m_livestemc_to_litter(:)
real(r8), pointer :: m_deadcrootc_to_litter(:)
real(r8), pointer :: m_livecrootc_to_litter(:)
real(r8), pointer :: m_deadstemc_xfer_to_fire(:)
real(r8), pointer :: m_frootc_storage_to_fire(:)
real(r8), pointer :: m_frootc_to_fire(:)
real(r8), pointer :: m_frootc_xfer_to_fire(:)
real(r8), pointer :: m_gresp_storage_to_fire(:)
real(r8), pointer :: m_gresp_xfer_to_fire(:)
real(r8), pointer :: m_leafc_storage_to_fire(:)
real(r8), pointer :: m_leafc_to_fire(:)
real(r8), pointer :: m_leafc_xfer_to_fire(:)
real(r8), pointer :: m_livecrootc_storage_to_fire(:)
real(r8), pointer :: m_livecrootc_to_fire(:)
real(r8), pointer :: m_livecrootc_xfer_to_fire(:)
real(r8), pointer :: m_livestemc_storage_to_fire(:)
real(r8), pointer :: m_livestemc_to_fire(:)
real(r8), pointer :: m_livestemc_xfer_to_fire(:)
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc_xfer(:) !(gC/m2) dead coarse root C transfer
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: leafcmax(:) ! (gC/m2) ann max leaf C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc_xfer(:) !(gC/m2) live coarse root C transfer
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: m_deadcrootn_storage_to_fire(:)
real(r8), pointer :: m_deadcrootn_to_fire(:)
real(r8), pointer :: m_deadcrootn_to_litter_fire(:)
real(r8), pointer :: m_deadcrootn_xfer_to_fire(:)
real(r8), pointer :: m_deadstemn_storage_to_fire(:)
real(r8), pointer :: m_deadstemn_to_fire(:)
real(r8), pointer :: m_deadstemn_to_litter_fire(:)
real(r8), pointer :: m_deadstemn_xfer_to_fire(:)
real(r8), pointer :: m_frootn_storage_to_fire(:)
real(r8), pointer :: m_frootn_to_fire(:)
real(r8), pointer :: m_frootn_xfer_to_fire(:)
real(r8), pointer :: m_leafn_storage_to_fire(:)
real(r8), pointer :: m_leafn_to_fire(:)
real(r8), pointer :: m_leafn_xfer_to_fire(:)
real(r8), pointer :: m_livecrootn_storage_to_fire(:)
real(r8), pointer :: m_livecrootn_to_fire(:)
real(r8), pointer :: m_livecrootn_xfer_to_fire(:)
real(r8), pointer :: m_livestemn_storage_to_fire(:)
real(r8), pointer :: m_livestemn_to_fire(:)
real(r8), pointer :: m_livestemn_xfer_to_fire(:)
real(r8), pointer :: m_retransn_to_fire(:)
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
!
! !OTHER LOCAL VARIABLES:
!real(r8), parameter:: wcf = 0.2_r8 ! wood combustion fraction
real(r8), parameter:: wcf = 0.4_r8 ! wood combustion fraction
integer :: c,p ! indices
integer :: fp,fc ! filter indices
real(r8):: f ! rate for fire effects (1/s)
! real(r8):: dt ! time step variable (s)
!EOP
!-----------------------------------------------------------------------
! assign local pointers
#if (defined CNDV)
nind => clm3%g%l%c%p%pdgvs%nind
#endif
ivt => clm3%g%l%c%p%itype
pcolumn => clm3%g%l%c%p%column
woody => pftcon%woody
resist => pftcon%resist
farea_burned => clm3%g%l%c%cps%farea_burned
m_cwdc_to_fire => clm3%g%l%c%ccf%m_cwdc_to_fire
m_deadcrootc_to_cwdc_fire => clm3%g%l%c%ccf%m_deadcrootc_to_cwdc_fire
m_deadstemc_to_cwdc_fire => clm3%g%l%c%ccf%m_deadstemc_to_cwdc_fire
m_litr1c_to_fire => clm3%g%l%c%ccf%m_litr1c_to_fire
m_litr2c_to_fire => clm3%g%l%c%ccf%m_litr2c_to_fire
m_litr3c_to_fire => clm3%g%l%c%ccf%m_litr3c_to_fire
cwdc => clm3%g%l%c%ccs%cwdc
litr1c => clm3%g%l%c%ccs%litr1c
litr2c => clm3%g%l%c%ccs%litr2c
litr3c => clm3%g%l%c%ccs%litr3c
m_cwdn_to_fire => clm3%g%l%c%cnf%m_cwdn_to_fire
m_deadcrootn_to_cwdn_fire => clm3%g%l%c%cnf%m_deadcrootn_to_cwdn_fire
m_deadstemn_to_cwdn_fire => clm3%g%l%c%cnf%m_deadstemn_to_cwdn_fire
m_litr1n_to_fire => clm3%g%l%c%cnf%m_litr1n_to_fire
m_litr2n_to_fire => clm3%g%l%c%cnf%m_litr2n_to_fire
m_litr3n_to_fire => clm3%g%l%c%cnf%m_litr3n_to_fire
cwdn => clm3%g%l%c%cns%cwdn
litr1n => clm3%g%l%c%cns%litr1n
litr2n => clm3%g%l%c%cns%litr2n
litr3n => clm3%g%l%c%cns%litr3n
m_deadcrootc_storage_to_fire => clm3%g%l%c%p%pcf%m_deadcrootc_storage_to_fire
m_deadcrootc_to_fire => clm3%g%l%c%p%pcf%m_deadcrootc_to_fire
m_deadcrootc_to_litter_fire => clm3%g%l%c%p%pcf%m_deadcrootc_to_litter_fire
m_deadcrootc_xfer_to_fire => clm3%g%l%c%p%pcf%m_deadcrootc_xfer_to_fire
m_deadstemc_storage_to_fire => clm3%g%l%c%p%pcf%m_deadstemc_storage_to_fire
m_deadstemc_to_fire => clm3%g%l%c%p%pcf%m_deadstemc_to_fire
m_deadstemc_to_litter_fire => clm3%g%l%c%p%pcf%m_deadstemc_to_litter_fire
m_deadstemc_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_to_litter
m_livestemc_to_litter => clm3%g%l%c%p%pcf%m_livestemc_to_litter
m_deadcrootc_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_to_litter
m_livecrootc_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_to_litter
m_deadstemc_xfer_to_fire => clm3%g%l%c%p%pcf%m_deadstemc_xfer_to_fire
m_frootc_storage_to_fire => clm3%g%l%c%p%pcf%m_frootc_storage_to_fire
m_frootc_to_fire => clm3%g%l%c%p%pcf%m_frootc_to_fire
m_frootc_xfer_to_fire => clm3%g%l%c%p%pcf%m_frootc_xfer_to_fire
m_gresp_storage_to_fire => clm3%g%l%c%p%pcf%m_gresp_storage_to_fire
m_gresp_xfer_to_fire => clm3%g%l%c%p%pcf%m_gresp_xfer_to_fire
m_leafc_storage_to_fire => clm3%g%l%c%p%pcf%m_leafc_storage_to_fire
m_leafc_to_fire => clm3%g%l%c%p%pcf%m_leafc_to_fire
m_leafc_xfer_to_fire => clm3%g%l%c%p%pcf%m_leafc_xfer_to_fire
m_livecrootc_storage_to_fire => clm3%g%l%c%p%pcf%m_livecrootc_storage_to_fire
m_livecrootc_to_fire => clm3%g%l%c%p%pcf%m_livecrootc_to_fire
m_livecrootc_xfer_to_fire => clm3%g%l%c%p%pcf%m_livecrootc_xfer_to_fire
m_livestemc_storage_to_fire => clm3%g%l%c%p%pcf%m_livestemc_storage_to_fire
m_livestemc_to_fire => clm3%g%l%c%p%pcf%m_livestemc_to_fire
m_livestemc_xfer_to_fire => clm3%g%l%c%p%pcf%m_livestemc_xfer_to_fire
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
deadstemc => clm3%g%l%c%p%pcs%deadstemc
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
frootc => clm3%g%l%c%p%pcs%frootc
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
leafc => clm3%g%l%c%p%pcs%leafc
leafcmax => clm3%g%l%c%p%pcs%leafcmax
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
livecrootc => clm3%g%l%c%p%pcs%livecrootc
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
livestemc => clm3%g%l%c%p%pcs%livestemc
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
m_deadcrootn_storage_to_fire => clm3%g%l%c%p%pnf%m_deadcrootn_storage_to_fire
m_deadcrootn_to_fire => clm3%g%l%c%p%pnf%m_deadcrootn_to_fire
m_deadcrootn_to_litter_fire => clm3%g%l%c%p%pnf%m_deadcrootn_to_litter_fire
m_deadcrootn_xfer_to_fire => clm3%g%l%c%p%pnf%m_deadcrootn_xfer_to_fire
m_deadstemn_storage_to_fire => clm3%g%l%c%p%pnf%m_deadstemn_storage_to_fire
m_deadstemn_to_fire => clm3%g%l%c%p%pnf%m_deadstemn_to_fire
m_deadstemn_to_litter_fire => clm3%g%l%c%p%pnf%m_deadstemn_to_litter_fire
m_deadstemn_xfer_to_fire => clm3%g%l%c%p%pnf%m_deadstemn_xfer_to_fire
m_frootn_storage_to_fire => clm3%g%l%c%p%pnf%m_frootn_storage_to_fire
m_frootn_to_fire => clm3%g%l%c%p%pnf%m_frootn_to_fire
m_frootn_xfer_to_fire => clm3%g%l%c%p%pnf%m_frootn_xfer_to_fire
m_leafn_storage_to_fire => clm3%g%l%c%p%pnf%m_leafn_storage_to_fire
m_leafn_to_fire => clm3%g%l%c%p%pnf%m_leafn_to_fire
m_leafn_xfer_to_fire => clm3%g%l%c%p%pnf%m_leafn_xfer_to_fire
m_livecrootn_storage_to_fire => clm3%g%l%c%p%pnf%m_livecrootn_storage_to_fire
m_livecrootn_to_fire => clm3%g%l%c%p%pnf%m_livecrootn_to_fire
m_livecrootn_xfer_to_fire => clm3%g%l%c%p%pnf%m_livecrootn_xfer_to_fire
m_livestemn_storage_to_fire => clm3%g%l%c%p%pnf%m_livestemn_storage_to_fire
m_livestemn_to_fire => clm3%g%l%c%p%pnf%m_livestemn_to_fire
m_livestemn_xfer_to_fire => clm3%g%l%c%p%pnf%m_livestemn_xfer_to_fire
m_retransn_to_fire => clm3%g%l%c%p%pnf%m_retransn_to_fire
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
deadstemn => clm3%g%l%c%p%pns%deadstemn
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
frootn => clm3%g%l%c%p%pns%frootn
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
leafn => clm3%g%l%c%p%pns%leafn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
livecrootn => clm3%g%l%c%p%pns%livecrootn
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
livestemn => clm3%g%l%c%p%pns%livestemn
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
retransn => clm3%g%l%c%p%pns%retransn
! Get model step size
! dt = real( get_step_size(), r8 )
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
c = pcolumn(p)
! get the column-level fractional area burned for this timestep
! and convert to a rate per second, then scale by the pft-level
! fire resistance
f = (farea_burned(c) / dt) * (1._r8 - resist(ivt(p)))
write(6,*) 'CNFire,farea_burned(',c,')=',farea_burned(c)
write(6,*) 'CNFire,resist(',ivt(p),')=',resist(ivt(p))
write(6,*) 'CNFire,dt=',dt
write(6,*) 'CNFire,f=',f
! apply this rate to the pft state variables to get flux rates
! NOTE: the deadstem and deadcroot pools are only partly consumed
! by fire, and the remaining affected fraction goes to the column-level
! as litter (coarse woody debris). This is controlled by wcf, the woody
! combustion fraction.
! carbon fluxes
m_leafc_to_fire(p) = leafc(p) * f
m_leafc_storage_to_fire(p) = leafc_storage(p) * f
m_leafc_xfer_to_fire(p) = leafc_xfer(p) * f
m_frootc_to_fire(p) = frootc(p) * f
m_frootc_storage_to_fire(p) = frootc_storage(p) * f
m_frootc_xfer_to_fire(p) = frootc_xfer(p) * f
m_livestemc_to_fire(p) = livestemc(p) * f
m_livestemc_storage_to_fire(p) = livestemc_storage(p) * f
m_livestemc_xfer_to_fire(p) = livestemc_xfer(p) * f
m_deadstemc_to_fire(p) = deadstemc(p) * f*wcf
m_deadstemc_to_litter_fire(p) = deadstemc(p) * f*(1._r8 - wcf)
write(6,*) 'CNFire, deadstemc(',p,')=',deadstemc(p)
m_deadstemc_storage_to_fire(p) = deadstemc_storage(p) * f
m_deadstemc_xfer_to_fire(p) = deadstemc_xfer(p) * f
m_livecrootc_to_fire(p) = livecrootc(p) * f
m_livecrootc_storage_to_fire(p) = livecrootc_storage(p) * f
m_livecrootc_xfer_to_fire(p) = livecrootc_xfer(p) * f
m_deadcrootc_to_fire(p) = deadcrootc(p) * f*wcf
m_deadcrootc_to_litter_fire(p) = deadcrootc(p) * f*(1._r8 - wcf)
write(6,*) 'CNFire, deadcrootc(',p,')=',deadcrootc(p)
m_deadcrootc_storage_to_fire(p) = deadcrootc_storage(p) * f
m_deadcrootc_xfer_to_fire(p) = deadcrootc_xfer(p) * f
m_gresp_storage_to_fire(p) = gresp_storage(p) * f
m_gresp_xfer_to_fire(p) = gresp_xfer(p) * f
! nitrogen fluxes
m_leafn_to_fire(p) = leafn(p) * f
m_leafn_storage_to_fire(p) = leafn_storage(p) * f
m_leafn_xfer_to_fire(p) = leafn_xfer(p) * f
m_frootn_to_fire(p) = frootn(p) * f
m_frootn_storage_to_fire(p) = frootn_storage(p) * f
m_frootn_xfer_to_fire(p) = frootn_xfer(p) * f
m_livestemn_to_fire(p) = livestemn(p) * f
m_livestemn_storage_to_fire(p) = livestemn_storage(p) * f
m_livestemn_xfer_to_fire(p) = livestemn_xfer(p) * f
m_deadstemn_to_fire(p) = deadstemn(p) * f*wcf
m_deadstemn_to_litter_fire(p) = deadstemn(p) * f*(1._r8 - wcf)
write(6,*) 'CNFire, deadstemn(',p,')=',deadstemn(p)
m_deadstemn_storage_to_fire(p) = deadstemn_storage(p) * f
m_deadstemn_xfer_to_fire(p) = deadstemn_xfer(p) * f
m_livecrootn_to_fire(p) = livecrootn(p) * f
m_livecrootn_storage_to_fire(p) = livecrootn_storage(p) * f
m_livecrootn_xfer_to_fire(p) = livecrootn_xfer(p) * f
m_deadcrootn_to_fire(p) = deadcrootn(p) * f*wcf
m_deadcrootn_to_litter_fire(p) = deadcrootn(p) * f*(1._r8 - wcf)
write(6,*) 'CNFire, deadcrootn(',p,')=',deadcrootn(p)
m_deadcrootn_storage_to_fire(p) = deadcrootn_storage(p) * f
m_deadcrootn_xfer_to_fire(p) = deadcrootn_xfer(p) * f
m_retransn_to_fire(p) = retransn(p) * f
#if (defined CNDV)
! Carbon per individual (c) remains constant in gap mortality & fire
! but individuals are removed from the population P (#/m2 naturally
! vegetated area), so
!
! c = Cnew*FPC/Pnew = Cold*FPC/Pold
!
! where C = carbon/m2 pft area & FPC = pft area/naturally vegetated area.
! FPC does not change from mortality or fire. FPC changes from Light and
! Establishment at the end of the year. So...
!
! Pnew = Pold * Cnew / Cold
!
! where "new" refers to after mortality & fire, while "old" refers to
! before mortality & fire. For C I use total wood. (slevis)
!
! nind calculation placed here for convenience; nind could be updated
! once per year instead if we saved Cold for that calculation;
! as is, nind slowly decreases through the year, while fpcgrid remains
! unchanged; this affects the htop calculation in CNVegStructUpdate
if (woody(ivt(p)) == 1._r8) then
if (livestemc(p)+deadstemc(p)+m_livestemc_to_litter(p)*dt+ &
m_deadstemc_to_litter(p)*dt > 0._r8) then
nind(p) = nind(p) * (livestemc(p) + deadstemc(p) + &
livecrootc(p) + deadcrootc(p) - dt * &
(m_livestemc_to_fire(p) + &
m_livecrootc_to_fire(p) + &
m_deadstemc_to_fire(p) + &
m_deadcrootc_to_fire(p) + &
m_deadcrootc_to_litter_fire(p) + &
m_deadstemc_to_litter_fire(p))) / &
(livestemc(p) + deadstemc(p) + &
livecrootc(p) + deadcrootc(p) + dt * &
(m_livestemc_to_litter(p) + &
m_livecrootc_to_litter(p) + &
m_deadcrootc_to_litter(p) + &
m_deadstemc_to_litter(p)))
else
nind(p) = 0._r8
end if
end if
! annual dgvm calculations use lm_ind = leafcmax * fpcgrid / nind
! leafcmax is reset to 0 once per yr
! could calculate leafcmax in CSummary instead; if so, should remove
! subtraction of m_leafc_to_fire(p)*dt from the calculation (slevis)
leafcmax(p) = max(leafc(p)-m_leafc_to_fire(p)*dt, leafcmax(p))
if (ivt(p) == 0) leafcmax(p) = 0._r8
#endif
end do ! end of pfts loop
! send the fire affected but uncombusted woody fraction to the column-level cwd fluxes
! use p2c for weighted averaging from pft to column
call p2c(num_soilc, filter_soilc, m_deadstemc_to_litter_fire, m_deadstemc_to_cwdc_fire)
call p2c(num_soilc, filter_soilc, m_deadcrootc_to_litter_fire, m_deadcrootc_to_cwdc_fire)
call p2c(num_soilc, filter_soilc, m_deadstemn_to_litter_fire, m_deadstemn_to_cwdn_fire)
call p2c(num_soilc, filter_soilc, m_deadcrootn_to_litter_fire, m_deadcrootn_to_cwdn_fire)
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! get the column-level fractional area burned for this timestep
! and convert to a rate per second, then scale by the pft-level
! fire resistance
f = farea_burned(c) / dt
! apply this rate to the column state variables to get flux rates
! NOTE: the coarse woody debris pools are only partly consumed
! by fire. This is controlled by wcf, the woody
! combustion fraction. For now using the same fraction for standing
! wood (deadstem and deadcroot pools) and woody litter (cwd pools).
! May be a good idea later to modify this to use different fractions
! for different woody pools, or make the combustion fraction a dynamic
! variable.
! carbon fluxes
m_litr1c_to_fire(c) = litr1c(c) * f
m_litr2c_to_fire(c) = litr2c(c) * f
m_litr3c_to_fire(c) = litr3c(c) * f
m_cwdc_to_fire(c) = cwdc(c) * f*wcf
! nitrogen fluxes
m_litr1n_to_fire(c) = litr1n(c) * f
m_litr2n_to_fire(c) = litr2n(c) * f
m_litr3n_to_fire(c) = litr3n(c) * f
m_cwdn_to_fire(c) = cwdn(c) * f*wcf
end do ! end of column loop
end subroutine CNFireFluxes
!-----------------------------------------------------------------------
#endif
end module CNFireMod
module CNGRespMod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNGRespMod
!
! !DESCRIPTION:
! Module for growth respiration fluxes,
! for coupled carbon-nitrogen code.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: CNGResp
!
! !REVISION HISTORY:
! 9/12/03: Created by Peter Thornton
! 10/27/03, Peter Thornton: migrated to vector data structures
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNGResp
!
! !INTERFACE:
subroutine CNGResp(num_soilp, filter_soilp) 1,7
!
! !DESCRIPTION:
! On the radiation time step, update all the prognostic carbon state
! variables
!
! !USES:
use clmtype
#ifdef CROP
use pftvarcon, only : npcropmin
#endif
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn, in module CNEcosystemDynMod.F90
!
! !REVISION HISTORY:
! 8/1/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: cpool_to_leafc(:)
real(r8), pointer :: cpool_to_leafc_storage(:)
real(r8), pointer :: cpool_to_frootc(:)
real(r8), pointer :: cpool_to_frootc_storage(:)
real(r8), pointer :: cpool_to_livestemc(:)
real(r8), pointer :: cpool_to_livestemc_storage(:)
real(r8), pointer :: cpool_to_deadstemc(:)
real(r8), pointer :: cpool_to_deadstemc_storage(:)
real(r8), pointer :: cpool_to_livecrootc(:)
real(r8), pointer :: cpool_to_livecrootc_storage(:)
real(r8), pointer :: cpool_to_deadcrootc(:)
real(r8), pointer :: cpool_to_deadcrootc_storage(:)
#if (defined CROP)
real(r8), pointer :: cpool_to_grainc(:)
real(r8), pointer :: cpool_to_grainc_storage(:)
real(r8), pointer :: grainc_xfer_to_grainc(:)
#endif
real(r8), pointer :: leafc_xfer_to_leafc(:)
real(r8), pointer :: frootc_xfer_to_frootc(:)
real(r8), pointer :: livestemc_xfer_to_livestemc(:)
real(r8), pointer :: deadstemc_xfer_to_deadstemc(:)
real(r8), pointer :: livecrootc_xfer_to_livecrootc(:)
real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:)
real(r8), pointer :: woody(:) !binary flag for woody lifeform (1=woody, 0=not woody)
!
! local pointers to implicit in/out scalars
!
#if (defined CROP)
real(r8), pointer :: cpool_grain_gr(:)
real(r8), pointer :: cpool_grain_storage_gr(:)
real(r8), pointer :: transfer_grain_gr(:)
#endif
real(r8), pointer :: cpool_leaf_gr(:)
real(r8), pointer :: cpool_leaf_storage_gr(:)
real(r8), pointer :: transfer_leaf_gr(:)
real(r8), pointer :: cpool_froot_gr(:)
real(r8), pointer :: cpool_froot_storage_gr(:)
real(r8), pointer :: transfer_froot_gr(:)
real(r8), pointer :: cpool_livestem_gr(:)
real(r8), pointer :: cpool_livestem_storage_gr(:)
real(r8), pointer :: transfer_livestem_gr(:)
real(r8), pointer :: cpool_deadstem_gr(:)
real(r8), pointer :: cpool_deadstem_storage_gr(:)
real(r8), pointer :: transfer_deadstem_gr(:)
real(r8), pointer :: cpool_livecroot_gr(:)
real(r8), pointer :: cpool_livecroot_storage_gr(:)
real(r8), pointer :: transfer_livecroot_gr(:)
real(r8), pointer :: cpool_deadcroot_gr(:)
real(r8), pointer :: cpool_deadcroot_storage_gr(:)
real(r8), pointer :: transfer_deadcroot_gr(:)
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: p ! indices
integer :: fp ! lake filter pft index
real(r8):: grperc, grpnow ! growth respirarion parameters
!EOP
!-----------------------------------------------------------------------
! Assign local pointers to derived type arrays (in)
ivt => clm3%g%l%c%p%itype
cpool_to_leafc => clm3%g%l%c%p%pcf%cpool_to_leafc
cpool_to_leafc_storage => clm3%g%l%c%p%pcf%cpool_to_leafc_storage
cpool_to_frootc => clm3%g%l%c%p%pcf%cpool_to_frootc
cpool_to_frootc_storage => clm3%g%l%c%p%pcf%cpool_to_frootc_storage
cpool_to_livestemc => clm3%g%l%c%p%pcf%cpool_to_livestemc
cpool_to_livestemc_storage => clm3%g%l%c%p%pcf%cpool_to_livestemc_storage
cpool_to_deadstemc => clm3%g%l%c%p%pcf%cpool_to_deadstemc
cpool_to_deadstemc_storage => clm3%g%l%c%p%pcf%cpool_to_deadstemc_storage
cpool_to_livecrootc => clm3%g%l%c%p%pcf%cpool_to_livecrootc
cpool_to_livecrootc_storage => clm3%g%l%c%p%pcf%cpool_to_livecrootc_storage
cpool_to_deadcrootc => clm3%g%l%c%p%pcf%cpool_to_deadcrootc
cpool_to_deadcrootc_storage => clm3%g%l%c%p%pcf%cpool_to_deadcrootc_storage
#if (defined CROP)
cpool_to_grainc => clm3%g%l%c%p%pcf%cpool_to_grainc
cpool_to_grainc_storage => clm3%g%l%c%p%pcf%cpool_to_grainc_storage
grainc_xfer_to_grainc => clm3%g%l%c%p%pcf%grainc_xfer_to_grainc
#endif
leafc_xfer_to_leafc => clm3%g%l%c%p%pcf%leafc_xfer_to_leafc
frootc_xfer_to_frootc => clm3%g%l%c%p%pcf%frootc_xfer_to_frootc
livestemc_xfer_to_livestemc => clm3%g%l%c%p%pcf%livestemc_xfer_to_livestemc
deadstemc_xfer_to_deadstemc => clm3%g%l%c%p%pcf%deadstemc_xfer_to_deadstemc
livecrootc_xfer_to_livecrootc => clm3%g%l%c%p%pcf%livecrootc_xfer_to_livecrootc
deadcrootc_xfer_to_deadcrootc => clm3%g%l%c%p%pcf%deadcrootc_xfer_to_deadcrootc
woody => pftcon%woody
! Assign local pointers to derived type arrays (out)
#if (defined CROP)
cpool_grain_gr => clm3%g%l%c%p%pcf%cpool_grain_gr
cpool_grain_storage_gr => clm3%g%l%c%p%pcf%cpool_grain_storage_gr
transfer_grain_gr => clm3%g%l%c%p%pcf%transfer_grain_gr
#endif
cpool_leaf_gr => clm3%g%l%c%p%pcf%cpool_leaf_gr
cpool_leaf_storage_gr => clm3%g%l%c%p%pcf%cpool_leaf_storage_gr
transfer_leaf_gr => clm3%g%l%c%p%pcf%transfer_leaf_gr
cpool_froot_gr => clm3%g%l%c%p%pcf%cpool_froot_gr
cpool_froot_storage_gr => clm3%g%l%c%p%pcf%cpool_froot_storage_gr
transfer_froot_gr => clm3%g%l%c%p%pcf%transfer_froot_gr
cpool_livestem_gr => clm3%g%l%c%p%pcf%cpool_livestem_gr
cpool_livestem_storage_gr => clm3%g%l%c%p%pcf%cpool_livestem_storage_gr
transfer_livestem_gr => clm3%g%l%c%p%pcf%transfer_livestem_gr
cpool_deadstem_gr => clm3%g%l%c%p%pcf%cpool_deadstem_gr
cpool_deadstem_storage_gr => clm3%g%l%c%p%pcf%cpool_deadstem_storage_gr
transfer_deadstem_gr => clm3%g%l%c%p%pcf%transfer_deadstem_gr
cpool_livecroot_gr => clm3%g%l%c%p%pcf%cpool_livecroot_gr
cpool_livecroot_storage_gr => clm3%g%l%c%p%pcf%cpool_livecroot_storage_gr
transfer_livecroot_gr => clm3%g%l%c%p%pcf%transfer_livecroot_gr
cpool_deadcroot_gr => clm3%g%l%c%p%pcf%cpool_deadcroot_gr
cpool_deadcroot_storage_gr => clm3%g%l%c%p%pcf%cpool_deadcroot_storage_gr
transfer_deadcroot_gr => clm3%g%l%c%p%pcf%transfer_deadcroot_gr
! set some parameters (temporary, these will eventually go into
! either pepc, or parameter file
grperc = 0.3_r8
grpnow = 1.0_r8
! Loop through pfts
! start pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
call CLMDebug('CNGResp--mark1')
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
grperc = 0.25_r8 ! had to set this again in CNAllocation
cpool_livestem_gr(p) = cpool_to_livestemc(p) * grperc
cpool_livestem_storage_gr(p) = cpool_to_livestemc_storage(p) * grperc * grpnow
call CLMDebug('CNGResp--mark11')
transfer_livestem_gr(p) = livestemc_xfer_to_livestemc(p) * grperc * (1._r8 - grpnow)
cpool_grain_gr(p) = cpool_to_grainc(p) * grperc
call CLMDebug('CNGResp--mark12')
cpool_grain_storage_gr(p) = cpool_to_grainc_storage(p) * grperc * grpnow
transfer_grain_gr(p) = grainc_xfer_to_grainc(p) * grperc * (1._r8 - grpnow)
else
grperc = 0.3_r8 ! need the else b/c the value from before the loop will not get used after
end if ! grperc is set to 0.25 once
#endif
call CLMDebug('CNGResp--mark2')
! leaf and fine root growth respiration
cpool_leaf_gr(p) = cpool_to_leafc(p) * grperc
cpool_leaf_storage_gr(p) = cpool_to_leafc_storage(p) * grperc * grpnow
transfer_leaf_gr(p) = leafc_xfer_to_leafc(p) * grperc * (1._r8 - grpnow)
cpool_froot_gr(p) = cpool_to_frootc(p) * grperc
cpool_froot_storage_gr(p) = cpool_to_frootc_storage(p) * grperc * grpnow
transfer_froot_gr(p) = frootc_xfer_to_frootc(p) * grperc * (1._r8 - grpnow)
call CLMDebug('CNGResp--mark3')
if (woody(ivt(p)) == 1._r8) then
cpool_livestem_gr(p) = cpool_to_livestemc(p) * grperc
cpool_livestem_storage_gr(p) = cpool_to_livestemc_storage(p) * grperc * grpnow
transfer_livestem_gr(p) = livestemc_xfer_to_livestemc(p) * grperc * (1._r8 - grpnow)
cpool_deadstem_gr(p) = cpool_to_deadstemc(p) * grperc
cpool_deadstem_storage_gr(p) = cpool_to_deadstemc_storage(p) * grperc * grpnow
transfer_deadstem_gr(p) = deadstemc_xfer_to_deadstemc(p) * grperc * (1._r8 - grpnow)
cpool_livecroot_gr(p) = cpool_to_livecrootc(p) * grperc
cpool_livecroot_storage_gr(p) = cpool_to_livecrootc_storage(p) * grperc * grpnow
transfer_livecroot_gr(p) = livecrootc_xfer_to_livecrootc(p) * grperc * (1._r8 - grpnow)
cpool_deadcroot_gr(p) = cpool_to_deadcrootc(p) * grperc
cpool_deadcroot_storage_gr(p) = cpool_to_deadcrootc_storage(p) * grperc * grpnow
transfer_deadcroot_gr(p) = deadcrootc_xfer_to_deadcrootc(p) * grperc * (1._r8 - grpnow)
end if
end do
end subroutine CNGResp
#endif
end module CNGRespMod
module CNGapMortalityMod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNGapMortalityMod
!
! !DESCRIPTION:
! Module holding routines used in gap mortality for coupled carbon
! nitrogen code.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: CNGapMortality
!
! !REVISION HISTORY:
! 3/29/04: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNGapMortality
!
! !INTERFACE:
subroutine CNGapMortality (num_soilc, filter_soilc, num_soilp, filter_soilp) 1,3
!
! !DESCRIPTION:
! Gap-phase mortality routine for coupled carbon-nitrogen code (CN)
!
! !USES:
use clmtype
! use clm_time_manager, only: get_days_per_year
use globals, only: day_per_year
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! column filter for soil points
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! pft filter for soil points
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 3/29/04: Created by Peter Thornton
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arrays
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: woody(:) ! binary flag for woody lifeform
! (1=woody, 0=not woody)
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
#if (defined CNDV)
real(r8), pointer :: greffic(:)
real(r8), pointer :: heatstress(:)
#endif
!
! local pointers to implicit in/out arrays
!
! local pointers to implicit out arrays
real(r8), pointer :: m_leafc_to_litter(:)
real(r8), pointer :: m_frootc_to_litter(:)
real(r8), pointer :: m_livestemc_to_litter(:)
real(r8), pointer :: m_deadstemc_to_litter(:)
real(r8), pointer :: m_livecrootc_to_litter(:)
real(r8), pointer :: m_deadcrootc_to_litter(:)
real(r8), pointer :: m_leafc_storage_to_litter(:)
real(r8), pointer :: m_frootc_storage_to_litter(:)
real(r8), pointer :: m_livestemc_storage_to_litter(:)
real(r8), pointer :: m_deadstemc_storage_to_litter(:)
real(r8), pointer :: m_livecrootc_storage_to_litter(:)
real(r8), pointer :: m_deadcrootc_storage_to_litter(:)
real(r8), pointer :: m_gresp_storage_to_litter(:)
real(r8), pointer :: m_leafc_xfer_to_litter(:)
real(r8), pointer :: m_frootc_xfer_to_litter(:)
real(r8), pointer :: m_livestemc_xfer_to_litter(:)
real(r8), pointer :: m_deadstemc_xfer_to_litter(:)
real(r8), pointer :: m_livecrootc_xfer_to_litter(:)
real(r8), pointer :: m_deadcrootc_xfer_to_litter(:)
real(r8), pointer :: m_gresp_xfer_to_litter(:)
real(r8), pointer :: m_leafn_to_litter(:)
real(r8), pointer :: m_frootn_to_litter(:)
real(r8), pointer :: m_livestemn_to_litter(:)
real(r8), pointer :: m_deadstemn_to_litter(:)
real(r8), pointer :: m_livecrootn_to_litter(:)
real(r8), pointer :: m_deadcrootn_to_litter(:)
real(r8), pointer :: m_retransn_to_litter(:)
real(r8), pointer :: m_leafn_storage_to_litter(:)
real(r8), pointer :: m_frootn_storage_to_litter(:)
real(r8), pointer :: m_livestemn_storage_to_litter(:)
real(r8), pointer :: m_deadstemn_storage_to_litter(:)
real(r8), pointer :: m_livecrootn_storage_to_litter(:)
real(r8), pointer :: m_deadcrootn_storage_to_litter(:)
real(r8), pointer :: m_leafn_xfer_to_litter(:)
real(r8), pointer :: m_frootn_xfer_to_litter(:)
real(r8), pointer :: m_livestemn_xfer_to_litter(:)
real(r8), pointer :: m_deadstemn_xfer_to_litter(:)
real(r8), pointer :: m_livecrootn_xfer_to_litter(:)
real(r8), pointer :: m_deadcrootn_xfer_to_litter(:)
!
! !OTHER LOCAL VARIABLES:
integer :: p ! pft index
integer :: fp ! pft filter index
real(r8):: am ! rate for fractional mortality (1/yr)
real(r8):: m ! rate for fractional mortality (1/s)
real(r8):: mort_max ! asymptotic max mortality rate (/yr)
real(r8), parameter :: k_mort = 0.3 !coeff of growth efficiency in mortality equation
!EOP
!-----------------------------------------------------------------------
! assign local pointers
woody => pftcon%woody
! assign local pointers to pft-level arrays
ivt => clm3%g%l%c%p%itype
leafc => clm3%g%l%c%p%pcs%leafc
frootc => clm3%g%l%c%p%pcs%frootc
livestemc => clm3%g%l%c%p%pcs%livestemc
deadstemc => clm3%g%l%c%p%pcs%deadstemc
livecrootc => clm3%g%l%c%p%pcs%livecrootc
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
leafn => clm3%g%l%c%p%pns%leafn
frootn => clm3%g%l%c%p%pns%frootn
livestemn => clm3%g%l%c%p%pns%livestemn
deadstemn => clm3%g%l%c%p%pns%deadstemn
livecrootn => clm3%g%l%c%p%pns%livecrootn
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
retransn => clm3%g%l%c%p%pns%retransn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
m_leafc_to_litter => clm3%g%l%c%p%pcf%m_leafc_to_litter
m_frootc_to_litter => clm3%g%l%c%p%pcf%m_frootc_to_litter
m_livestemc_to_litter => clm3%g%l%c%p%pcf%m_livestemc_to_litter
m_deadstemc_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_to_litter
m_livecrootc_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_to_litter
m_deadcrootc_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_to_litter
m_leafc_storage_to_litter => clm3%g%l%c%p%pcf%m_leafc_storage_to_litter
m_frootc_storage_to_litter => clm3%g%l%c%p%pcf%m_frootc_storage_to_litter
m_livestemc_storage_to_litter => clm3%g%l%c%p%pcf%m_livestemc_storage_to_litter
m_deadstemc_storage_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_storage_to_litter
m_livecrootc_storage_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_storage_to_litter
m_deadcrootc_storage_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_storage_to_litter
m_gresp_storage_to_litter => clm3%g%l%c%p%pcf%m_gresp_storage_to_litter
m_leafc_xfer_to_litter => clm3%g%l%c%p%pcf%m_leafc_xfer_to_litter
m_frootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_frootc_xfer_to_litter
m_livestemc_xfer_to_litter => clm3%g%l%c%p%pcf%m_livestemc_xfer_to_litter
m_deadstemc_xfer_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_xfer_to_litter
m_livecrootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_xfer_to_litter
m_deadcrootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_xfer_to_litter
m_gresp_xfer_to_litter => clm3%g%l%c%p%pcf%m_gresp_xfer_to_litter
m_leafn_to_litter => clm3%g%l%c%p%pnf%m_leafn_to_litter
m_frootn_to_litter => clm3%g%l%c%p%pnf%m_frootn_to_litter
m_livestemn_to_litter => clm3%g%l%c%p%pnf%m_livestemn_to_litter
m_deadstemn_to_litter => clm3%g%l%c%p%pnf%m_deadstemn_to_litter
m_livecrootn_to_litter => clm3%g%l%c%p%pnf%m_livecrootn_to_litter
m_deadcrootn_to_litter => clm3%g%l%c%p%pnf%m_deadcrootn_to_litter
m_retransn_to_litter => clm3%g%l%c%p%pnf%m_retransn_to_litter
m_leafn_storage_to_litter => clm3%g%l%c%p%pnf%m_leafn_storage_to_litter
m_frootn_storage_to_litter => clm3%g%l%c%p%pnf%m_frootn_storage_to_litter
m_livestemn_storage_to_litter => clm3%g%l%c%p%pnf%m_livestemn_storage_to_litter
m_deadstemn_storage_to_litter => clm3%g%l%c%p%pnf%m_deadstemn_storage_to_litter
m_livecrootn_storage_to_litter => clm3%g%l%c%p%pnf%m_livecrootn_storage_to_litter
m_deadcrootn_storage_to_litter => clm3%g%l%c%p%pnf%m_deadcrootn_storage_to_litter
m_leafn_xfer_to_litter => clm3%g%l%c%p%pnf%m_leafn_xfer_to_litter
m_frootn_xfer_to_litter => clm3%g%l%c%p%pnf%m_frootn_xfer_to_litter
m_livestemn_xfer_to_litter => clm3%g%l%c%p%pnf%m_livestemn_xfer_to_litter
m_deadstemn_xfer_to_litter => clm3%g%l%c%p%pnf%m_deadstemn_xfer_to_litter
m_livecrootn_xfer_to_litter => clm3%g%l%c%p%pnf%m_livecrootn_xfer_to_litter
m_deadcrootn_xfer_to_litter => clm3%g%l%c%p%pnf%m_deadcrootn_xfer_to_litter
#if (defined CNDV)
greffic => clm3%g%l%c%p%pdgvs%greffic
heatstress => clm3%g%l%c%p%pdgvs%heatstress
#endif
! set the mortality rate based on annual rate
am = 0.02_r8
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
#if (defined CNDV)
! Stress mortality from lpj's subr Mortality.
if (woody(ivt(p)) == 1._r8) then
if (ivt(p) == 8) then
mort_max = 0.03_r8 ! BDT boreal
else
mort_max = 0.01_r8 ! original value for all pfts
end if
! heatstress and greffic calculated in Establishment once/yr
! Mortality rate inversely related to growth efficiency
! (Prentice et al 1993)
am = mort_max / (1._r8 + k_mort * greffic(p))
am = min(1._r8, am + heatstress(p))
else ! lpj didn't set this for grasses; cn does
! set the mortality rate based on annual rate
am = 0.02_r8
end if
#endif
!ylu removed and add
! m = am/(get_days_per_year() * 86400._r8)
m = am/(day_per_year * 86400._r8)
write(6,*) 'am=',am
write(6,*) 'day_per_year=',day_per_year
! pft-level gap mortality carbon fluxes
! displayed pools
m_leafc_to_litter(p) = leafc(p) * m
m_frootc_to_litter(p) = frootc(p) * m
m_livestemc_to_litter(p) = livestemc(p) * m
m_deadstemc_to_litter(p) = deadstemc(p) * m
m_livecrootc_to_litter(p) = livecrootc(p) * m
m_deadcrootc_to_litter(p) = deadcrootc(p) * m
! storage pools
m_leafc_storage_to_litter(p) = leafc_storage(p) * m
m_frootc_storage_to_litter(p) = frootc_storage(p) * m
m_livestemc_storage_to_litter(p) = livestemc_storage(p) * m
m_deadstemc_storage_to_litter(p) = deadstemc_storage(p) * m
m_livecrootc_storage_to_litter(p) = livecrootc_storage(p) * m
m_deadcrootc_storage_to_litter(p) = deadcrootc_storage(p) * m
m_gresp_storage_to_litter(p) = gresp_storage(p) * m
! transfer pools
m_leafc_xfer_to_litter(p) = leafc_xfer(p) * m
m_frootc_xfer_to_litter(p) = frootc_xfer(p) * m
m_livestemc_xfer_to_litter(p) = livestemc_xfer(p) * m
m_deadstemc_xfer_to_litter(p) = deadstemc_xfer(p) * m
m_livecrootc_xfer_to_litter(p) = livecrootc_xfer(p) * m
m_deadcrootc_xfer_to_litter(p) = deadcrootc_xfer(p) * m
m_gresp_xfer_to_litter(p) = gresp_xfer(p) * m
! pft-level gap mortality nitrogen fluxes
! displayed pools
m_leafn_to_litter(p) = leafn(p) * m
m_frootn_to_litter(p) = frootn(p) * m
m_livestemn_to_litter(p) = livestemn(p) * m
m_deadstemn_to_litter(p) = deadstemn(p) * m
write(6,*) 'deadstemn(',p,')=',deadstemn(p)
write(6,*) 'm_deadstemn_to_litter(',p,')=', m_deadstemn_to_litter(p)
m_livecrootn_to_litter(p) = livecrootn(p) * m
m_deadcrootn_to_litter(p) = deadcrootn(p) * m
m_retransn_to_litter(p) = retransn(p) * m
! storage pools
m_leafn_storage_to_litter(p) = leafn_storage(p) * m
m_frootn_storage_to_litter(p) = frootn_storage(p) * m
m_livestemn_storage_to_litter(p) = livestemn_storage(p) * m
m_deadstemn_storage_to_litter(p) = deadstemn_storage(p) * m
m_livecrootn_storage_to_litter(p) = livecrootn_storage(p) * m
m_deadcrootn_storage_to_litter(p) = deadcrootn_storage(p) * m
! transfer pools
m_leafn_xfer_to_litter(p) = leafn_xfer(p) * m
m_frootn_xfer_to_litter(p) = frootn_xfer(p) * m
m_livestemn_xfer_to_litter(p) = livestemn_xfer(p) * m
m_deadstemn_xfer_to_litter(p) = deadstemn_xfer(p) * m
m_livecrootn_xfer_to_litter(p) = livecrootn_xfer(p) * m
m_deadcrootn_xfer_to_litter(p) = deadcrootn_xfer(p) * m
end do ! end of pft loop
! gather all pft-level litterfall fluxes to the column
! for litter C and N inputs
call CNGapPftToColumn(num_soilc, filter_soilc)
end subroutine CNGapMortality
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNGapPftToColumn
!
! !INTERFACE:
subroutine CNGapPftToColumn (num_soilc, filter_soilc) 1,2
!
! !DESCRIPTION:
! called in the middle of CNGapMoratlity to gather all pft-level gap mortality fluxes
! to the column level and assign them to the three litter pools
!
! !USES:
use clmtype
use clm_varpar, only : maxpatch_pft
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! soil column filter
!
! !CALLED FROM:
! subroutine CNphenology
!
! !REVISION HISTORY:
! 9/8/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in scalars
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: wtcol(:) ! pft weight relative to column (0-1)
real(r8), pointer :: pwtgcell(:) ! weight of pft relative to corresponding gridcell
real(r8), pointer :: lf_flab(:) ! leaf litter labile fraction
real(r8), pointer :: lf_fcel(:) ! leaf litter cellulose fraction
real(r8), pointer :: lf_flig(:) ! leaf litter lignin fraction
real(r8), pointer :: fr_flab(:) ! fine root litter labile fraction
real(r8), pointer :: fr_fcel(:) ! fine root litter cellulose fraction
real(r8), pointer :: fr_flig(:) ! fine root litter lignin fraction
integer , pointer :: npfts(:) ! number of pfts for each column
integer , pointer :: pfti(:) ! beginning pft index for each column
real(r8), pointer :: m_leafc_to_litter(:)
real(r8), pointer :: m_frootc_to_litter(:)
real(r8), pointer :: m_livestemc_to_litter(:)
real(r8), pointer :: m_deadstemc_to_litter(:)
real(r8), pointer :: m_livecrootc_to_litter(:)
real(r8), pointer :: m_deadcrootc_to_litter(:)
real(r8), pointer :: m_leafc_storage_to_litter(:)
real(r8), pointer :: m_frootc_storage_to_litter(:)
real(r8), pointer :: m_livestemc_storage_to_litter(:)
real(r8), pointer :: m_deadstemc_storage_to_litter(:)
real(r8), pointer :: m_livecrootc_storage_to_litter(:)
real(r8), pointer :: m_deadcrootc_storage_to_litter(:)
real(r8), pointer :: m_gresp_storage_to_litter(:)
real(r8), pointer :: m_leafc_xfer_to_litter(:)
real(r8), pointer :: m_frootc_xfer_to_litter(:)
real(r8), pointer :: m_livestemc_xfer_to_litter(:)
real(r8), pointer :: m_deadstemc_xfer_to_litter(:)
real(r8), pointer :: m_livecrootc_xfer_to_litter(:)
real(r8), pointer :: m_deadcrootc_xfer_to_litter(:)
real(r8), pointer :: m_gresp_xfer_to_litter(:)
real(r8), pointer :: m_leafn_to_litter(:)
real(r8), pointer :: m_frootn_to_litter(:)
real(r8), pointer :: m_livestemn_to_litter(:)
real(r8), pointer :: m_deadstemn_to_litter(:)
real(r8), pointer :: m_livecrootn_to_litter(:)
real(r8), pointer :: m_deadcrootn_to_litter(:)
real(r8), pointer :: m_retransn_to_litter(:)
real(r8), pointer :: m_leafn_storage_to_litter(:)
real(r8), pointer :: m_frootn_storage_to_litter(:)
real(r8), pointer :: m_livestemn_storage_to_litter(:)
real(r8), pointer :: m_deadstemn_storage_to_litter(:)
real(r8), pointer :: m_livecrootn_storage_to_litter(:)
real(r8), pointer :: m_deadcrootn_storage_to_litter(:)
real(r8), pointer :: m_leafn_xfer_to_litter(:)
real(r8), pointer :: m_frootn_xfer_to_litter(:)
real(r8), pointer :: m_livestemn_xfer_to_litter(:)
real(r8), pointer :: m_deadstemn_xfer_to_litter(:)
real(r8), pointer :: m_livecrootn_xfer_to_litter(:)
real(r8), pointer :: m_deadcrootn_xfer_to_litter(:)
!
! local pointers to implicit in/out arrays
real(r8), pointer :: m_leafc_to_litr1c(:)
real(r8), pointer :: m_leafc_to_litr2c(:)
real(r8), pointer :: m_leafc_to_litr3c(:)
real(r8), pointer :: m_frootc_to_litr1c(:)
real(r8), pointer :: m_frootc_to_litr2c(:)
real(r8), pointer :: m_frootc_to_litr3c(:)
real(r8), pointer :: m_livestemc_to_cwdc(:)
real(r8), pointer :: m_deadstemc_to_cwdc(:)
real(r8), pointer :: m_livecrootc_to_cwdc(:)
real(r8), pointer :: m_deadcrootc_to_cwdc(:)
real(r8), pointer :: m_leafc_storage_to_litr1c(:)
real(r8), pointer :: m_frootc_storage_to_litr1c(:)
real(r8), pointer :: m_livestemc_storage_to_litr1c(:)
real(r8), pointer :: m_deadstemc_storage_to_litr1c(:)
real(r8), pointer :: m_livecrootc_storage_to_litr1c(:)
real(r8), pointer :: m_deadcrootc_storage_to_litr1c(:)
real(r8), pointer :: m_gresp_storage_to_litr1c(:)
real(r8), pointer :: m_leafc_xfer_to_litr1c(:)
real(r8), pointer :: m_frootc_xfer_to_litr1c(:)
real(r8), pointer :: m_livestemc_xfer_to_litr1c(:)
real(r8), pointer :: m_deadstemc_xfer_to_litr1c(:)
real(r8), pointer :: m_livecrootc_xfer_to_litr1c(:)
real(r8), pointer :: m_deadcrootc_xfer_to_litr1c(:)
real(r8), pointer :: m_gresp_xfer_to_litr1c(:)
real(r8), pointer :: m_leafn_to_litr1n(:)
real(r8), pointer :: m_leafn_to_litr2n(:)
real(r8), pointer :: m_leafn_to_litr3n(:)
real(r8), pointer :: m_frootn_to_litr1n(:)
real(r8), pointer :: m_frootn_to_litr2n(:)
real(r8), pointer :: m_frootn_to_litr3n(:)
real(r8), pointer :: m_livestemn_to_cwdn(:)
real(r8), pointer :: m_deadstemn_to_cwdn(:)
real(r8), pointer :: m_livecrootn_to_cwdn(:)
real(r8), pointer :: m_deadcrootn_to_cwdn(:)
real(r8), pointer :: m_retransn_to_litr1n(:)
real(r8), pointer :: m_leafn_storage_to_litr1n(:)
real(r8), pointer :: m_frootn_storage_to_litr1n(:)
real(r8), pointer :: m_livestemn_storage_to_litr1n(:)
real(r8), pointer :: m_deadstemn_storage_to_litr1n(:)
real(r8), pointer :: m_livecrootn_storage_to_litr1n(:)
real(r8), pointer :: m_deadcrootn_storage_to_litr1n(:)
real(r8), pointer :: m_leafn_xfer_to_litr1n(:)
real(r8), pointer :: m_frootn_xfer_to_litr1n(:)
real(r8), pointer :: m_livestemn_xfer_to_litr1n(:)
real(r8), pointer :: m_deadstemn_xfer_to_litr1n(:)
real(r8), pointer :: m_livecrootn_xfer_to_litr1n(:)
real(r8), pointer :: m_deadcrootn_xfer_to_litr1n(:)
!
! local pointers to implicit out arrays
!
!
! !OTHER LOCAL VARIABLES:
integer :: fc,c,pi,p ! indices
!EOP
!-----------------------------------------------------------------------
! assign local pointers
lf_flab => pftcon%lf_flab
lf_fcel => pftcon%lf_fcel
lf_flig => pftcon%lf_flig
fr_flab => pftcon%fr_flab
fr_fcel => pftcon%fr_fcel
fr_flig => pftcon%fr_flig
! assign local pointers to column-level arrays
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
m_leafc_to_litr1c => clm3%g%l%c%ccf%m_leafc_to_litr1c
m_leafc_to_litr2c => clm3%g%l%c%ccf%m_leafc_to_litr2c
m_leafc_to_litr3c => clm3%g%l%c%ccf%m_leafc_to_litr3c
m_frootc_to_litr1c => clm3%g%l%c%ccf%m_frootc_to_litr1c
m_frootc_to_litr2c => clm3%g%l%c%ccf%m_frootc_to_litr2c
m_frootc_to_litr3c => clm3%g%l%c%ccf%m_frootc_to_litr3c
m_livestemc_to_cwdc => clm3%g%l%c%ccf%m_livestemc_to_cwdc
m_deadstemc_to_cwdc => clm3%g%l%c%ccf%m_deadstemc_to_cwdc
m_livecrootc_to_cwdc => clm3%g%l%c%ccf%m_livecrootc_to_cwdc
m_deadcrootc_to_cwdc => clm3%g%l%c%ccf%m_deadcrootc_to_cwdc
m_leafc_storage_to_litr1c => clm3%g%l%c%ccf%m_leafc_storage_to_litr1c
m_frootc_storage_to_litr1c => clm3%g%l%c%ccf%m_frootc_storage_to_litr1c
m_livestemc_storage_to_litr1c => clm3%g%l%c%ccf%m_livestemc_storage_to_litr1c
m_deadstemc_storage_to_litr1c => clm3%g%l%c%ccf%m_deadstemc_storage_to_litr1c
m_livecrootc_storage_to_litr1c => clm3%g%l%c%ccf%m_livecrootc_storage_to_litr1c
m_deadcrootc_storage_to_litr1c => clm3%g%l%c%ccf%m_deadcrootc_storage_to_litr1c
m_gresp_storage_to_litr1c => clm3%g%l%c%ccf%m_gresp_storage_to_litr1c
m_leafc_xfer_to_litr1c => clm3%g%l%c%ccf%m_leafc_xfer_to_litr1c
m_frootc_xfer_to_litr1c => clm3%g%l%c%ccf%m_frootc_xfer_to_litr1c
m_livestemc_xfer_to_litr1c => clm3%g%l%c%ccf%m_livestemc_xfer_to_litr1c
m_deadstemc_xfer_to_litr1c => clm3%g%l%c%ccf%m_deadstemc_xfer_to_litr1c
m_livecrootc_xfer_to_litr1c => clm3%g%l%c%ccf%m_livecrootc_xfer_to_litr1c
m_deadcrootc_xfer_to_litr1c => clm3%g%l%c%ccf%m_deadcrootc_xfer_to_litr1c
m_gresp_xfer_to_litr1c => clm3%g%l%c%ccf%m_gresp_xfer_to_litr1c
m_leafn_to_litr1n => clm3%g%l%c%cnf%m_leafn_to_litr1n
m_leafn_to_litr2n => clm3%g%l%c%cnf%m_leafn_to_litr2n
m_leafn_to_litr3n => clm3%g%l%c%cnf%m_leafn_to_litr3n
m_frootn_to_litr1n => clm3%g%l%c%cnf%m_frootn_to_litr1n
m_frootn_to_litr2n => clm3%g%l%c%cnf%m_frootn_to_litr2n
m_frootn_to_litr3n => clm3%g%l%c%cnf%m_frootn_to_litr3n
m_livestemn_to_cwdn => clm3%g%l%c%cnf%m_livestemn_to_cwdn
m_deadstemn_to_cwdn => clm3%g%l%c%cnf%m_deadstemn_to_cwdn
m_livecrootn_to_cwdn => clm3%g%l%c%cnf%m_livecrootn_to_cwdn
m_deadcrootn_to_cwdn => clm3%g%l%c%cnf%m_deadcrootn_to_cwdn
m_retransn_to_litr1n => clm3%g%l%c%cnf%m_retransn_to_litr1n
m_leafn_storage_to_litr1n => clm3%g%l%c%cnf%m_leafn_storage_to_litr1n
m_frootn_storage_to_litr1n => clm3%g%l%c%cnf%m_frootn_storage_to_litr1n
m_livestemn_storage_to_litr1n => clm3%g%l%c%cnf%m_livestemn_storage_to_litr1n
m_deadstemn_storage_to_litr1n => clm3%g%l%c%cnf%m_deadstemn_storage_to_litr1n
m_livecrootn_storage_to_litr1n => clm3%g%l%c%cnf%m_livecrootn_storage_to_litr1n
m_deadcrootn_storage_to_litr1n => clm3%g%l%c%cnf%m_deadcrootn_storage_to_litr1n
m_leafn_xfer_to_litr1n => clm3%g%l%c%cnf%m_leafn_xfer_to_litr1n
m_frootn_xfer_to_litr1n => clm3%g%l%c%cnf%m_frootn_xfer_to_litr1n
m_livestemn_xfer_to_litr1n => clm3%g%l%c%cnf%m_livestemn_xfer_to_litr1n
m_deadstemn_xfer_to_litr1n => clm3%g%l%c%cnf%m_deadstemn_xfer_to_litr1n
m_livecrootn_xfer_to_litr1n => clm3%g%l%c%cnf%m_livecrootn_xfer_to_litr1n
m_deadcrootn_xfer_to_litr1n => clm3%g%l%c%cnf%m_deadcrootn_xfer_to_litr1n
! assign local pointers to pft-level arrays
ivt => clm3%g%l%c%p%itype
wtcol => clm3%g%l%c%p%wtcol
pwtgcell => clm3%g%l%c%p%wtgcell
m_leafc_to_litter => clm3%g%l%c%p%pcf%m_leafc_to_litter
m_frootc_to_litter => clm3%g%l%c%p%pcf%m_frootc_to_litter
m_livestemc_to_litter => clm3%g%l%c%p%pcf%m_livestemc_to_litter
m_deadstemc_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_to_litter
m_livecrootc_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_to_litter
m_deadcrootc_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_to_litter
m_leafc_storage_to_litter => clm3%g%l%c%p%pcf%m_leafc_storage_to_litter
m_frootc_storage_to_litter => clm3%g%l%c%p%pcf%m_frootc_storage_to_litter
m_livestemc_storage_to_litter => clm3%g%l%c%p%pcf%m_livestemc_storage_to_litter
m_deadstemc_storage_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_storage_to_litter
m_livecrootc_storage_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_storage_to_litter
m_deadcrootc_storage_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_storage_to_litter
m_gresp_storage_to_litter => clm3%g%l%c%p%pcf%m_gresp_storage_to_litter
m_leafc_xfer_to_litter => clm3%g%l%c%p%pcf%m_leafc_xfer_to_litter
m_frootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_frootc_xfer_to_litter
m_livestemc_xfer_to_litter => clm3%g%l%c%p%pcf%m_livestemc_xfer_to_litter
m_deadstemc_xfer_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_xfer_to_litter
m_livecrootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_xfer_to_litter
m_deadcrootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_xfer_to_litter
m_gresp_xfer_to_litter => clm3%g%l%c%p%pcf%m_gresp_xfer_to_litter
m_leafn_to_litter => clm3%g%l%c%p%pnf%m_leafn_to_litter
m_frootn_to_litter => clm3%g%l%c%p%pnf%m_frootn_to_litter
m_livestemn_to_litter => clm3%g%l%c%p%pnf%m_livestemn_to_litter
m_deadstemn_to_litter => clm3%g%l%c%p%pnf%m_deadstemn_to_litter
m_livecrootn_to_litter => clm3%g%l%c%p%pnf%m_livecrootn_to_litter
m_deadcrootn_to_litter => clm3%g%l%c%p%pnf%m_deadcrootn_to_litter
m_retransn_to_litter => clm3%g%l%c%p%pnf%m_retransn_to_litter
m_leafn_storage_to_litter => clm3%g%l%c%p%pnf%m_leafn_storage_to_litter
m_frootn_storage_to_litter => clm3%g%l%c%p%pnf%m_frootn_storage_to_litter
m_livestemn_storage_to_litter => clm3%g%l%c%p%pnf%m_livestemn_storage_to_litter
m_deadstemn_storage_to_litter => clm3%g%l%c%p%pnf%m_deadstemn_storage_to_litter
m_livecrootn_storage_to_litter => clm3%g%l%c%p%pnf%m_livecrootn_storage_to_litter
m_deadcrootn_storage_to_litter => clm3%g%l%c%p%pnf%m_deadcrootn_storage_to_litter
m_leafn_xfer_to_litter => clm3%g%l%c%p%pnf%m_leafn_xfer_to_litter
m_frootn_xfer_to_litter => clm3%g%l%c%p%pnf%m_frootn_xfer_to_litter
m_livestemn_xfer_to_litter => clm3%g%l%c%p%pnf%m_livestemn_xfer_to_litter
m_deadstemn_xfer_to_litter => clm3%g%l%c%p%pnf%m_deadstemn_xfer_to_litter
m_livecrootn_xfer_to_litter => clm3%g%l%c%p%pnf%m_livecrootn_xfer_to_litter
m_deadcrootn_xfer_to_litter => clm3%g%l%c%p%pnf%m_deadcrootn_xfer_to_litter
do pi = 1,maxpatch_pft
do fc = 1,num_soilc
c = filter_soilc(fc)
if (pi <= npfts(c)) then
p = pfti(c) + pi - 1
if (pwtgcell(p)>0._r8) then
! leaf gap mortality carbon fluxes
m_leafc_to_litr1c(c) = m_leafc_to_litr1c(c) + &
m_leafc_to_litter(p) * lf_flab(ivt(p)) * wtcol(p)
m_leafc_to_litr2c(c) = m_leafc_to_litr2c(c) + &
m_leafc_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p)
m_leafc_to_litr3c(c) = m_leafc_to_litr3c(c) + &
m_leafc_to_litter(p) * lf_flig(ivt(p)) * wtcol(p)
! fine root gap mortality carbon fluxes
m_frootc_to_litr1c(c) = m_frootc_to_litr1c(c) + &
m_frootc_to_litter(p) * fr_flab(ivt(p)) * wtcol(p)
m_frootc_to_litr2c(c) = m_frootc_to_litr2c(c) + &
m_frootc_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p)
m_frootc_to_litr3c(c) = m_frootc_to_litr3c(c) + &
m_frootc_to_litter(p) * fr_flig(ivt(p)) * wtcol(p)
! wood gap mortality carbon fluxes
m_livestemc_to_cwdc(c) = m_livestemc_to_cwdc(c) + &
m_livestemc_to_litter(p) * wtcol(p)
m_deadstemc_to_cwdc(c) = m_deadstemc_to_cwdc(c) + &
m_deadstemc_to_litter(p) * wtcol(p)
m_livecrootc_to_cwdc(c) = m_livecrootc_to_cwdc(c) + &
m_livecrootc_to_litter(p) * wtcol(p)
m_deadcrootc_to_cwdc(c) = m_deadcrootc_to_cwdc(c) + &
m_deadcrootc_to_litter(p) * wtcol(p)
! storage gap mortality carbon fluxes
m_leafc_storage_to_litr1c(c) = m_leafc_storage_to_litr1c(c) + &
m_leafc_storage_to_litter(p) * wtcol(p)
m_frootc_storage_to_litr1c(c) = m_frootc_storage_to_litr1c(c) + &
m_frootc_storage_to_litter(p) * wtcol(p)
m_livestemc_storage_to_litr1c(c) = m_livestemc_storage_to_litr1c(c) + &
m_livestemc_storage_to_litter(p) * wtcol(p)
m_deadstemc_storage_to_litr1c(c) = m_deadstemc_storage_to_litr1c(c) + &
m_deadstemc_storage_to_litter(p) * wtcol(p)
m_livecrootc_storage_to_litr1c(c) = m_livecrootc_storage_to_litr1c(c) + &
m_livecrootc_storage_to_litter(p) * wtcol(p)
m_deadcrootc_storage_to_litr1c(c) = m_deadcrootc_storage_to_litr1c(c) + &
m_deadcrootc_storage_to_litter(p) * wtcol(p)
m_gresp_storage_to_litr1c(c) = m_gresp_storage_to_litr1c(c) + &
m_gresp_storage_to_litter(p) * wtcol(p)
! transfer gap mortality carbon fluxes
m_leafc_xfer_to_litr1c(c) = m_leafc_xfer_to_litr1c(c) + &
m_leafc_xfer_to_litter(p) * wtcol(p)
m_frootc_xfer_to_litr1c(c) = m_frootc_xfer_to_litr1c(c) + &
m_frootc_xfer_to_litter(p) * wtcol(p)
m_livestemc_xfer_to_litr1c(c) = m_livestemc_xfer_to_litr1c(c) + &
m_livestemc_xfer_to_litter(p) * wtcol(p)
m_deadstemc_xfer_to_litr1c(c) = m_deadstemc_xfer_to_litr1c(c) + &
m_deadstemc_xfer_to_litter(p) * wtcol(p)
m_livecrootc_xfer_to_litr1c(c) = m_livecrootc_xfer_to_litr1c(c) + &
m_livecrootc_xfer_to_litter(p) * wtcol(p)
m_deadcrootc_xfer_to_litr1c(c) = m_deadcrootc_xfer_to_litr1c(c) + &
m_deadcrootc_xfer_to_litter(p) * wtcol(p)
m_gresp_xfer_to_litr1c(c) = m_gresp_xfer_to_litr1c(c) + &
m_gresp_xfer_to_litter(p) * wtcol(p)
! leaf gap mortality nitrogen fluxes
m_leafn_to_litr1n(c) = m_leafn_to_litr1n(c) + &
m_leafn_to_litter(p) * lf_flab(ivt(p)) * wtcol(p)
m_leafn_to_litr2n(c) = m_leafn_to_litr2n(c) + &
m_leafn_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p)
m_leafn_to_litr3n(c) = m_leafn_to_litr3n(c) + &
m_leafn_to_litter(p) * lf_flig(ivt(p)) * wtcol(p)
! fine root litter nitrogen fluxes
m_frootn_to_litr1n(c) = m_frootn_to_litr1n(c) + &
m_frootn_to_litter(p) * fr_flab(ivt(p)) * wtcol(p)
m_frootn_to_litr2n(c) = m_frootn_to_litr2n(c) + &
m_frootn_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p)
m_frootn_to_litr3n(c) = m_frootn_to_litr3n(c) + &
m_frootn_to_litter(p) * fr_flig(ivt(p)) * wtcol(p)
! wood gap mortality nitrogen fluxes
m_livestemn_to_cwdn(c) = m_livestemn_to_cwdn(c) + &
m_livestemn_to_litter(p) * wtcol(p)
m_deadstemn_to_cwdn(c) = m_deadstemn_to_cwdn(c) + &
m_deadstemn_to_litter(p) * wtcol(p)
m_livecrootn_to_cwdn(c) = m_livecrootn_to_cwdn(c) + &
m_livecrootn_to_litter(p) * wtcol(p)
m_deadcrootn_to_cwdn(c) = m_deadcrootn_to_cwdn(c) + &
m_deadcrootn_to_litter(p) * wtcol(p)
! retranslocated N pool gap mortality fluxes
m_retransn_to_litr1n(c) = m_retransn_to_litr1n(c) + &
m_retransn_to_litter(p) * wtcol(p)
! storage gap mortality nitrogen fluxes
m_leafn_storage_to_litr1n(c) = m_leafn_storage_to_litr1n(c) + &
m_leafn_storage_to_litter(p) * wtcol(p)
m_frootn_storage_to_litr1n(c) = m_frootn_storage_to_litr1n(c) + &
m_frootn_storage_to_litter(p) * wtcol(p)
m_livestemn_storage_to_litr1n(c) = m_livestemn_storage_to_litr1n(c) + &
m_livestemn_storage_to_litter(p) * wtcol(p)
m_deadstemn_storage_to_litr1n(c) = m_deadstemn_storage_to_litr1n(c) + &
m_deadstemn_storage_to_litter(p) * wtcol(p)
m_livecrootn_storage_to_litr1n(c) = m_livecrootn_storage_to_litr1n(c) + &
m_livecrootn_storage_to_litter(p) * wtcol(p)
m_deadcrootn_storage_to_litr1n(c) = m_deadcrootn_storage_to_litr1n(c) + &
m_deadcrootn_storage_to_litter(p) * wtcol(p)
! transfer gap mortality nitrogen fluxes
m_leafn_xfer_to_litr1n(c) = m_leafn_xfer_to_litr1n(c) + &
m_leafn_xfer_to_litter(p) * wtcol(p)
m_frootn_xfer_to_litr1n(c) = m_frootn_xfer_to_litr1n(c) + &
m_frootn_xfer_to_litter(p) * wtcol(p)
m_livestemn_xfer_to_litr1n(c) = m_livestemn_xfer_to_litr1n(c) + &
m_livestemn_xfer_to_litter(p) * wtcol(p)
m_deadstemn_xfer_to_litr1n(c) = m_deadstemn_xfer_to_litr1n(c) + &
m_deadstemn_xfer_to_litter(p) * wtcol(p)
m_livecrootn_xfer_to_litr1n(c) = m_livecrootn_xfer_to_litr1n(c) + &
m_livecrootn_xfer_to_litter(p) * wtcol(p)
m_deadcrootn_xfer_to_litr1n(c) = m_deadcrootn_xfer_to_litr1n(c) + &
m_deadcrootn_xfer_to_litter(p) * wtcol(p)
end if
end if
end do
end do
end subroutine CNGapPftToColumn
!-----------------------------------------------------------------------
#endif
end module CNGapMortalityMod
module CNMRespMod 1,3
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNMRespMod
!
! !DESCRIPTION:
! Module holding maintenance respiration routines for coupled carbon
! nitrogen code.
!
! !USES:
use shr_kind_mod , only: r8 => shr_kind_r8
use clm_varpar , only: nlevgrnd
use shr_const_mod, only: SHR_CONST_TKFRZ
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: CNMResp
!
! !REVISION HISTORY:
! 8/14/03: Created by Peter Thornton
! 10/23/03, Peter Thornton: Migrated all subroutines to vector data structures.
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNMResp
!
! !INTERFACE:
subroutine CNMResp(lbc, ubc, num_soilc, filter_soilc, num_soilp, filter_soilp) 1,1
!
! !DESCRIPTION:
!
! !USES:
use clmtype
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column-index bounds
integer, intent(in) :: num_soilc ! number of soil points in column filter
integer, intent(in) :: filter_soilc(:) ! column filter for soil points
integer, intent(in) :: num_soilp ! number of soil points in pft filter
integer, intent(in) :: filter_soilp(:) ! pft filter for soil points
!
! !CALLED FROM:
! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90
!
! !REVISION HISTORY:
! 8/14/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
!
! column level
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd)
! pft level
real(r8), pointer :: t_ref2m(:) ! 2 m height surface air temperature (Kelvin)
real(r8), pointer :: leafn(:) ! (kgN/m2) leaf N
real(r8), pointer :: frootn(:) ! (kgN/m2) fine root N
real(r8), pointer :: livestemn(:) ! (kgN/m2) live stem N
real(r8), pointer :: livecrootn(:) ! (kgN/m2) live coarse root N
real(r8), pointer :: rootfr(:,:) ! fraction of roots in each soil layer (nlevgrnd)
integer , pointer :: ivt(:) ! pft vegetation type
integer , pointer :: pcolumn(:) ! index into column level quantities
integer , pointer :: plandunit(:) ! index into landunit level quantities
integer , pointer :: clandunit(:) ! index into landunit level quantities
integer , pointer :: itypelun(:) ! landunit type
! ecophysiological constants
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
!
! local pointers to implicit in/out arrays
!
! pft level
real(r8), pointer :: leaf_mr(:)
real(r8), pointer :: froot_mr(:)
real(r8), pointer :: livestem_mr(:)
real(r8), pointer :: livecroot_mr(:)
!
! !OTHER LOCAL VARIABLES:
integer :: c,p,j ! indices
integer :: fp ! soil filter pft index
integer :: fc ! soil filter column index
real(r8):: mr ! maintenance respiration (gC/m2/s)
real(r8):: br ! base rate (gC/gN/s)
real(r8):: q10 ! temperature dependence
real(r8):: tc ! temperature correction, 2m air temp (unitless)
real(r8):: tcsoi(lbc:ubc,nlevgrnd) ! temperature correction by soil layer (unitless)
!EOP
!-----------------------------------------------------------------------
! Assign local pointers to derived type arrays
t_soisno => clm3%g%l%c%ces%t_soisno
t_ref2m => clm3%g%l%c%p%pes%t_ref2m
leafn => clm3%g%l%c%p%pns%leafn
frootn => clm3%g%l%c%p%pns%frootn
livestemn => clm3%g%l%c%p%pns%livestemn
livecrootn => clm3%g%l%c%p%pns%livecrootn
rootfr => clm3%g%l%c%p%pps%rootfr
leaf_mr => clm3%g%l%c%p%pcf%leaf_mr
froot_mr => clm3%g%l%c%p%pcf%froot_mr
livestem_mr => clm3%g%l%c%p%pcf%livestem_mr
livecroot_mr => clm3%g%l%c%p%pcf%livecroot_mr
ivt => clm3%g%l%c%p%itype
pcolumn => clm3%g%l%c%p%column
plandunit => clm3%g%l%c%p%landunit
clandunit => clm3%g%l%c%landunit
itypelun => clm3%g%l%itype
woody => pftcon%woody
! base rate for maintenance respiration is from:
! M. Ryan, 1991. Effects of climate change on plant respiration.
! Ecological Applications, 1(2), 157-167.
! Original expression is br = 0.0106 molC/(molN h)
! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s)
br = 2.525e-6_r8
! Peter Thornton: 3/13/09
! Q10 was originally set to 2.0, an arbitrary choice, but reduced to 1.5 as part of the tuning
! to improve seasonal cycle of atmospheric CO2 concentration in global
! simulatoins
q10 = 1.5_r8
! column loop to calculate temperature factors in each soil layer
do j=1,nlevgrnd
!dir$ concurrent
!cdir nodep
do fc = 1, num_soilc
c = filter_soilc(fc)
! calculate temperature corrections for each soil layer, for use in
! estimating fine root maintenance respiration with depth
tcsoi(c,j) = q10**((t_soisno(c,j)-SHR_CONST_TKFRZ - 20.0_r8)/10.0_r8)
end do
end do
! pft loop for leaves and live wood
!dir$ concurrent
!cdir nodep
do fp = 1, num_soilp
p = filter_soilp(fp)
! calculate maintenance respiration fluxes in
! gC/m2/s for each of the live plant tissues.
! Leaf and live wood MR
tc = q10**((t_ref2m(p)-SHR_CONST_TKFRZ - 20.0_r8)/10.0_r8)
leaf_mr(p) = leafn(p)*br*tc
write(6,*) 'check leaf_mr in CNMRespMod'
write(6,*) 'leafn(',p,')=',leafn(p)
write(6,*) 'tc=',tc
write(6,*) 'q10=',q10
write(6,*) 't_ref2m(',p,')=',t_ref2m(p)
if (woody(ivt(p)) == 1) then
livestem_mr(p) = livestemn(p)*br*tc
livecroot_mr(p) = livecrootn(p)*br*tc
end if
end do
! soil and pft loop for fine root
do j = 1,nlevgrnd
!dir$ concurrent
!cdir nodep
do fp = 1,num_soilp
p = filter_soilp(fp)
c = pcolumn(p)
! Fine root MR
! rootfr(j) sums to 1.0 over all soil layers, and
! describes the fraction of root mass that is in each
! layer. This is used with the layer temperature correction
! to estimate the total fine root maintenance respiration as a
! function of temperature and N content.
froot_mr(p) = froot_mr(p) + frootn(p)*br*tcsoi(c,j)*rootfr(p,j)
end do
end do
end subroutine CNMResp
#endif
end module CNMRespMod
module CNNDynamicsMod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNNDynamicsMod
!
! !DESCRIPTION:
! Module for mineral nitrogen dynamics (deposition, fixation, leaching)
! for coupled carbon-nitrogen code.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: CNNDeposition
public :: CNNFixation
public :: CNNLeaching
!
! !REVISION HISTORY:
! 6/1/04: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNNDeposition
!
! !INTERFACE:
subroutine CNNDeposition( lbc, ubc ) 1,1
!
! !DESCRIPTION:
! On the radiation time step, update the nitrogen deposition rate
! from atmospheric forcing. For now it is assumed that all the atmospheric
! N deposition goes to the soil mineral N pool.
! This could be updated later to divide the inputs between mineral N absorbed
! directly into the canopy and mineral N entering the soil pool.
!
! !USES:
use clmtype
! ylu removed use clm_atmlnd , only : clm_a2l
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
!
! !CALLED FROM:
! subroutine CNEcosystemDyn, in module CNEcosystemDynMod.F90
!
! !REVISION HISTORY:
! 6/1/04: Created by Peter Thornton
! 11/06/09: Copy to all columns NOT just over soil. S. Levis
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
real(r8), pointer :: forc_ndep(:) ! nitrogen deposition rate (gN/m2/s)
integer , pointer :: gridcell(:) ! index into gridcell level quantities
!
! local pointers to implicit out scalars
!
real(r8), pointer :: ndep_to_sminn(:)
!
! !OTHER LOCAL VARIABLES:
integer :: g,c ! indices
!EOP
!-----------------------------------------------------------------------
! Assign local pointers to derived type arrays (in)
!TODO_ylu:
forc_ndep => clm_a2l%forc_ndep
gridcell => clm3%g%l%c%gridcell
! Assign local pointers to derived type arrays (out)
ndep_to_sminn => clm3%g%l%c%cnf%ndep_to_sminn
! Loop through columns
do c = lbc, ubc
g = gridcell(c)
ndep_to_sminn(c) = forc_ndep(g)
end do
end subroutine CNNDeposition
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNNFixation
!
! !INTERFACE:
subroutine CNNFixation(num_soilc, filter_soilc) 1,1
!
! !DESCRIPTION:
! On the radiation time step, update the nitrogen fixation rate
! as a function of annual total NPP. This rate gets updated once per year.
! All N fixation goes to the soil mineral N pool.
!
! !USES:
use clmtype
!ylu remove, seems not been used
! use clm_varctl, only: iulog
! use shr_sys_mod, only: shr_sys_flush
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
!
! !CALLED FROM:
! subroutine CNEcosystemDyn, in module CNEcosystemDynMod.F90
!
! !REVISION HISTORY:
! 6/1/04: Created by Peter Thornton
! 2/14/05, PET: After looking at a number of point simulations,
! it looks like a constant Nfix might be more efficient and
! maybe more realistic - setting to constant 0.4 gN/m2/yr.
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
real(r8), pointer :: cannsum_npp(:) ! nitrogen deposition rate (gN/m2/s)
!
! local pointers to implicit out scalars
!
real(r8), pointer :: nfix_to_sminn(:)
!
! !OTHER LOCAL VARIABLES:
integer :: c,fc ! indices
real(r8) :: t ! temporary
!EOP
!-----------------------------------------------------------------------
! Assign local pointers to derived type arrays (in)
cannsum_npp => clm3%g%l%c%cps%cannsum_npp
! Assign local pointers to derived type arrays (out)
nfix_to_sminn => clm3%g%l%c%cnf%nfix_to_sminn
! Loop through columns
do fc = 1,num_soilc
c = filter_soilc(fc)
! the value 0.001666 is set to give 100 TgN/yr when global
! NPP = 60 PgC/yr. (Cleveland et al., 1999)
! Convert from gN/m2/yr -> gN/m2/s
!t = cannsum_npp(c) * 0.001666_r8 / (86400._r8 * 365._r8)
t = (1.8_r8 * (1._r8 - exp(-0.003_r8 * cannsum_npp(c))))/(86400._r8 * 365._r8)
nfix_to_sminn(c) = max(0._r8,t)
! PET 2/14/05: commenting out the dependence on NPP, and
! forcing Nfix to global constant = 0.4 gN/m2/yr
!nfix_to_sminn(c) = 0.4 / (86400._r8*365._r8)
end do
end subroutine CNNFixation
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNNLeaching
!
! !INTERFACE:
subroutine CNNLeaching(lbc, ubc, num_soilc, filter_soilc) 1,3
!
! !DESCRIPTION:
! On the radiation time step, update the nitrogen leaching rate
! as a function of soluble mineral N and total soil water outflow.
!
! !USES:
use clmtype
use clm_varpar , only : nlevsoi
!ylu removed
! use clm_time_manager , only : get_step_size
use globals, only : dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 6/9/04: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2) (new) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s)
real(r8), pointer :: sminn(:) ! (gN/m2) soil mineral N
!
! local pointers to implicit out scalars
!
real(r8), pointer :: sminn_leached(:) ! rate of mineral N leaching (gN/m2/s)
!
! !OTHER LOCAL VARIABLES:
integer :: j,c,fc ! indices
!ylu removed 10-22-10
! real(r8) :: dt ! radiation time step (seconds)
real(r8) :: tot_water(lbc:ubc) ! total column liquid water (kg water/m2)
real(r8) :: sf ! soluble fraction of mineral N (unitless)
real(r8) :: disn_conc ! dissolved mineral N concentration
! (gN/kg water)
!EOP
!-----------------------------------------------------------------------
! Assign local pointers to derived type arrays (in)
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
qflx_drain => clm3%g%l%c%cwf%qflx_drain
sminn => clm3%g%l%c%cns%sminn
! Assign local pointers to derived type arrays (out)
sminn_leached => clm3%g%l%c%cnf%sminn_leached
! set time steps
!ylu removed
! dt = real( get_step_size(), r8 )
! Assume that 10% of the soil mineral N is in a soluble form
sf = 0.1_r8
! calculate the total soil water
tot_water(lbc:ubc) = 0._r8
do j = 1,nlevsoi
do fc = 1,num_soilc
c = filter_soilc(fc)
tot_water(c) = tot_water(c) + h2osoi_liq(c,j)
end do
end do
! Loop through columns
do fc = 1,num_soilc
c = filter_soilc(fc)
! calculate the dissolved mineral N concentration (gN/kg water)
! assumes that 10% of mineral nitrogen is soluble
disn_conc = 0._r8
if (tot_water(c) > 0._r8) then
disn_conc = (sf * sminn(c))/tot_water(c)
end if
! calculate the N leaching flux as a function of the dissolved
! concentration and the sub-surface drainage flux
sminn_leached(c) = disn_conc * qflx_drain(c)
! limit the flux based on current sminn state
! only let at most the assumed soluble fraction
! of sminn be leached on any given timestep
sminn_leached(c) = min(sminn_leached(c), (sf * sminn(c))/dt)
! limit the flux to a positive value
sminn_leached(c) = max(sminn_leached(c), 0._r8)
end do
end subroutine CNNLeaching
#endif
end module CNNDynamicsMod
module CNNStateUpdate1Mod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: NStateUpdate1Mod
!
! !DESCRIPTION:
! Module for nitrogen state variable updates, non-mortality fluxes.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public:: NStateUpdate1
!
! !REVISION HISTORY:
! 4/23/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: NStateUpdate1
!
! !INTERFACE:
subroutine NStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,3
!
! !DESCRIPTION:
! On the radiation time step, update all the prognostic nitrogen state
! variables (except for gap-phase mortality and fire fluxes)
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size
use globals, only: dt
#if (defined CROP)
use pftvarcon , only: npcropmin
#endif
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 8/1/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
real(r8), pointer :: cwdn_to_litr2n(:)
real(r8), pointer :: cwdn_to_litr3n(:)
#if (defined CROP)
real(r8), pointer :: grainn_to_litr1n(:)
real(r8), pointer :: grainn_to_litr2n(:)
real(r8), pointer :: grainn_to_litr3n(:)
real(r8), pointer :: livestemn_to_litr1n(:)
real(r8), pointer :: livestemn_to_litr2n(:)
real(r8), pointer :: livestemn_to_litr3n(:)
#endif
real(r8), pointer :: frootn_to_litr1n(:)
real(r8), pointer :: frootn_to_litr2n(:)
real(r8), pointer :: frootn_to_litr3n(:)
real(r8), pointer :: leafn_to_litr1n(:)
real(r8), pointer :: leafn_to_litr2n(:)
real(r8), pointer :: leafn_to_litr3n(:)
real(r8), pointer :: litr1n_to_soil1n(:)
real(r8), pointer :: litr2n_to_soil2n(:)
real(r8), pointer :: litr3n_to_soil3n(:)
real(r8), pointer :: ndep_to_sminn(:)
real(r8), pointer :: nfix_to_sminn(:)
real(r8), pointer :: sminn_to_denit_excess(:)
real(r8), pointer :: sminn_to_denit_l1s1(:)
real(r8), pointer :: sminn_to_denit_l2s2(:)
real(r8), pointer :: sminn_to_denit_l3s3(:)
real(r8), pointer :: sminn_to_denit_s1s2(:)
real(r8), pointer :: sminn_to_denit_s2s3(:)
real(r8), pointer :: sminn_to_denit_s3s4(:)
real(r8), pointer :: sminn_to_denit_s4(:)
real(r8), pointer :: sminn_to_plant(:)
real(r8), pointer :: sminn_to_soil1n_l1(:)
real(r8), pointer :: sminn_to_soil2n_l2(:)
real(r8), pointer :: sminn_to_soil2n_s1(:)
real(r8), pointer :: sminn_to_soil3n_l3(:)
real(r8), pointer :: sminn_to_soil3n_s2(:)
real(r8), pointer :: sminn_to_soil4n_s3(:)
real(r8), pointer :: soil1n_to_soil2n(:)
real(r8), pointer :: soil2n_to_soil3n(:)
real(r8), pointer :: soil3n_to_soil4n(:)
real(r8), pointer :: soil4n_to_sminn(:)
real(r8), pointer :: supplement_to_sminn(:)
real(r8), pointer :: deadcrootn_storage_to_xfer(:)
real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:)
real(r8), pointer :: deadstemn_storage_to_xfer(:)
real(r8), pointer :: deadstemn_xfer_to_deadstemn(:)
real(r8), pointer :: frootn_storage_to_xfer(:)
real(r8), pointer :: frootn_to_litter(:)
real(r8), pointer :: frootn_xfer_to_frootn(:)
real(r8), pointer :: leafn_storage_to_xfer(:)
real(r8), pointer :: leafn_to_litter(:)
real(r8), pointer :: leafn_to_retransn(:)
real(r8), pointer :: leafn_xfer_to_leafn(:)
real(r8), pointer :: livecrootn_storage_to_xfer(:)
real(r8), pointer :: livecrootn_to_deadcrootn(:)
real(r8), pointer :: livecrootn_to_retransn(:)
real(r8), pointer :: livecrootn_xfer_to_livecrootn(:)
real(r8), pointer :: livestemn_storage_to_xfer(:)
real(r8), pointer :: livestemn_to_deadstemn(:)
real(r8), pointer :: livestemn_to_retransn(:)
real(r8), pointer :: livestemn_xfer_to_livestemn(:)
real(r8), pointer :: npool_to_deadcrootn(:)
real(r8), pointer :: npool_to_deadcrootn_storage(:)
real(r8), pointer :: npool_to_deadstemn(:)
real(r8), pointer :: npool_to_deadstemn_storage(:)
real(r8), pointer :: npool_to_frootn(:)
real(r8), pointer :: npool_to_frootn_storage(:)
real(r8), pointer :: npool_to_leafn(:)
real(r8), pointer :: npool_to_leafn_storage(:)
real(r8), pointer :: npool_to_livecrootn(:)
real(r8), pointer :: npool_to_livecrootn_storage(:)
real(r8), pointer :: npool_to_livestemn(:)
real(r8), pointer :: npool_to_livestemn_storage(:)
real(r8), pointer :: retransn_to_npool(:)
real(r8), pointer :: sminn_to_npool(:)
#if (defined CROP)
real(r8), pointer :: grainn_storage_to_xfer(:)
real(r8), pointer :: grainn_to_food(:)
real(r8), pointer :: grainn_xfer_to_grainn(:)
real(r8), pointer :: livestemn_to_litter(:)
real(r8), pointer :: npool_to_grainn(:)
real(r8), pointer :: npool_to_grainn_storage(:)
#endif
!
! local pointers to implicit in/out scalars
#if (defined CROP)
real(r8), pointer :: grainn(:) ! (gN/m2) grain N
real(r8), pointer :: grainn_storage(:) ! (gN/m2) grain N storage
real(r8), pointer :: grainn_xfer(:) ! (gN/m2) grain N transfer
#endif
real(r8), pointer :: litr1n(:) ! (gN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (gN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (gN/m2) litter lignin N
real(r8), pointer :: sminn(:) ! (gN/m2) soil mineral N
real(r8), pointer :: soil1n(:) ! (gN/m2) soil organic matter N (fast pool)
real(r8), pointer :: soil2n(:) ! (gN/m2) soil organic matter N (medium pool)
real(r8), pointer :: soil3n(:) ! (gN/m2) soil orgainc matter N (slow pool)
real(r8), pointer :: soil4n(:) ! (gN/m2) soil orgainc matter N (slowest pool)
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool
! local pointers for dynamic landcover fluxes and states
real(r8), pointer :: dwt_seedn_to_leaf(:)
real(r8), pointer :: dwt_seedn_to_deadstem(:)
real(r8), pointer :: dwt_frootn_to_litr1n(:)
real(r8), pointer :: dwt_frootn_to_litr2n(:)
real(r8), pointer :: dwt_frootn_to_litr3n(:)
real(r8), pointer :: dwt_livecrootn_to_cwdn(:)
real(r8), pointer :: dwt_deadcrootn_to_cwdn(:)
real(r8), pointer :: seedn(:)
!
! local pointers to implicit out scalars
real(r8), pointer :: col_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2)
real(r8), pointer :: pft_begnb(:) ! nitrogen mass, beginning of time step (gN/m**2)
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
! real(r8):: dt ! radiation time step (seconds)
!EOP
!-----------------------------------------------------------------------
! assign local pointers
woody => pftcon%woody
! assign local pointers at the column level
cwdn_to_litr2n => clm3%g%l%c%cnf%cwdn_to_litr2n
cwdn_to_litr3n => clm3%g%l%c%cnf%cwdn_to_litr3n
#if (defined CROP)
livestemn_to_litr1n => clm3%g%l%c%cnf%livestemn_to_litr1n
livestemn_to_litr2n => clm3%g%l%c%cnf%livestemn_to_litr2n
livestemn_to_litr3n => clm3%g%l%c%cnf%livestemn_to_litr3n
grainn_to_litr1n => clm3%g%l%c%cnf%grainn_to_litr1n
grainn_to_litr2n => clm3%g%l%c%cnf%grainn_to_litr2n
grainn_to_litr3n => clm3%g%l%c%cnf%grainn_to_litr3n
#endif
frootn_to_litr1n => clm3%g%l%c%cnf%frootn_to_litr1n
frootn_to_litr2n => clm3%g%l%c%cnf%frootn_to_litr2n
frootn_to_litr3n => clm3%g%l%c%cnf%frootn_to_litr3n
leafn_to_litr1n => clm3%g%l%c%cnf%leafn_to_litr1n
leafn_to_litr2n => clm3%g%l%c%cnf%leafn_to_litr2n
leafn_to_litr3n => clm3%g%l%c%cnf%leafn_to_litr3n
litr1n_to_soil1n => clm3%g%l%c%cnf%litr1n_to_soil1n
litr2n_to_soil2n => clm3%g%l%c%cnf%litr2n_to_soil2n
litr3n_to_soil3n => clm3%g%l%c%cnf%litr3n_to_soil3n
ndep_to_sminn => clm3%g%l%c%cnf%ndep_to_sminn
nfix_to_sminn => clm3%g%l%c%cnf%nfix_to_sminn
sminn_to_denit_excess => clm3%g%l%c%cnf%sminn_to_denit_excess
sminn_to_denit_l1s1 => clm3%g%l%c%cnf%sminn_to_denit_l1s1
sminn_to_denit_l2s2 => clm3%g%l%c%cnf%sminn_to_denit_l2s2
sminn_to_denit_l3s3 => clm3%g%l%c%cnf%sminn_to_denit_l3s3
sminn_to_denit_s1s2 => clm3%g%l%c%cnf%sminn_to_denit_s1s2
sminn_to_denit_s2s3 => clm3%g%l%c%cnf%sminn_to_denit_s2s3
sminn_to_denit_s3s4 => clm3%g%l%c%cnf%sminn_to_denit_s3s4
sminn_to_denit_s4 => clm3%g%l%c%cnf%sminn_to_denit_s4
sminn_to_plant => clm3%g%l%c%cnf%sminn_to_plant
sminn_to_soil1n_l1 => clm3%g%l%c%cnf%sminn_to_soil1n_l1
sminn_to_soil2n_l2 => clm3%g%l%c%cnf%sminn_to_soil2n_l2
sminn_to_soil2n_s1 => clm3%g%l%c%cnf%sminn_to_soil2n_s1
sminn_to_soil3n_l3 => clm3%g%l%c%cnf%sminn_to_soil3n_l3
sminn_to_soil3n_s2 => clm3%g%l%c%cnf%sminn_to_soil3n_s2
sminn_to_soil4n_s3 => clm3%g%l%c%cnf%sminn_to_soil4n_s3
soil1n_to_soil2n => clm3%g%l%c%cnf%soil1n_to_soil2n
soil2n_to_soil3n => clm3%g%l%c%cnf%soil2n_to_soil3n
soil3n_to_soil4n => clm3%g%l%c%cnf%soil3n_to_soil4n
soil4n_to_sminn => clm3%g%l%c%cnf%soil4n_to_sminn
supplement_to_sminn => clm3%g%l%c%cnf%supplement_to_sminn
cwdn => clm3%g%l%c%cns%cwdn
litr1n => clm3%g%l%c%cns%litr1n
litr2n => clm3%g%l%c%cns%litr2n
litr3n => clm3%g%l%c%cns%litr3n
sminn => clm3%g%l%c%cns%sminn
soil1n => clm3%g%l%c%cns%soil1n
soil2n => clm3%g%l%c%cns%soil2n
soil3n => clm3%g%l%c%cns%soil3n
soil4n => clm3%g%l%c%cns%soil4n
! new pointers for dynamic landcover
dwt_seedn_to_leaf => clm3%g%l%c%cnf%dwt_seedn_to_leaf
dwt_seedn_to_deadstem => clm3%g%l%c%cnf%dwt_seedn_to_deadstem
dwt_frootn_to_litr1n => clm3%g%l%c%cnf%dwt_frootn_to_litr1n
dwt_frootn_to_litr2n => clm3%g%l%c%cnf%dwt_frootn_to_litr2n
dwt_frootn_to_litr3n => clm3%g%l%c%cnf%dwt_frootn_to_litr3n
dwt_livecrootn_to_cwdn => clm3%g%l%c%cnf%dwt_livecrootn_to_cwdn
dwt_deadcrootn_to_cwdn => clm3%g%l%c%cnf%dwt_deadcrootn_to_cwdn
seedn => clm3%g%l%c%cns%seedn
! assign local pointers at the pft level
ivt => clm3%g%l%c%p%itype
deadcrootn_storage_to_xfer => clm3%g%l%c%p%pnf%deadcrootn_storage_to_xfer
deadcrootn_xfer_to_deadcrootn => clm3%g%l%c%p%pnf%deadcrootn_xfer_to_deadcrootn
deadstemn_storage_to_xfer => clm3%g%l%c%p%pnf%deadstemn_storage_to_xfer
deadstemn_xfer_to_deadstemn => clm3%g%l%c%p%pnf%deadstemn_xfer_to_deadstemn
frootn_storage_to_xfer => clm3%g%l%c%p%pnf%frootn_storage_to_xfer
frootn_to_litter => clm3%g%l%c%p%pnf%frootn_to_litter
frootn_xfer_to_frootn => clm3%g%l%c%p%pnf%frootn_xfer_to_frootn
leafn_storage_to_xfer => clm3%g%l%c%p%pnf%leafn_storage_to_xfer
leafn_to_litter => clm3%g%l%c%p%pnf%leafn_to_litter
leafn_to_retransn => clm3%g%l%c%p%pnf%leafn_to_retransn
leafn_xfer_to_leafn => clm3%g%l%c%p%pnf%leafn_xfer_to_leafn
livecrootn_storage_to_xfer => clm3%g%l%c%p%pnf%livecrootn_storage_to_xfer
livecrootn_to_deadcrootn => clm3%g%l%c%p%pnf%livecrootn_to_deadcrootn
livecrootn_to_retransn => clm3%g%l%c%p%pnf%livecrootn_to_retransn
livecrootn_xfer_to_livecrootn => clm3%g%l%c%p%pnf%livecrootn_xfer_to_livecrootn
livestemn_storage_to_xfer => clm3%g%l%c%p%pnf%livestemn_storage_to_xfer
livestemn_to_deadstemn => clm3%g%l%c%p%pnf%livestemn_to_deadstemn
livestemn_to_retransn => clm3%g%l%c%p%pnf%livestemn_to_retransn
livestemn_xfer_to_livestemn => clm3%g%l%c%p%pnf%livestemn_xfer_to_livestemn
npool_to_deadcrootn => clm3%g%l%c%p%pnf%npool_to_deadcrootn
npool_to_deadcrootn_storage => clm3%g%l%c%p%pnf%npool_to_deadcrootn_storage
npool_to_deadstemn => clm3%g%l%c%p%pnf%npool_to_deadstemn
npool_to_deadstemn_storage => clm3%g%l%c%p%pnf%npool_to_deadstemn_storage
npool_to_frootn => clm3%g%l%c%p%pnf%npool_to_frootn
npool_to_frootn_storage => clm3%g%l%c%p%pnf%npool_to_frootn_storage
npool_to_leafn => clm3%g%l%c%p%pnf%npool_to_leafn
npool_to_leafn_storage => clm3%g%l%c%p%pnf%npool_to_leafn_storage
npool_to_livecrootn => clm3%g%l%c%p%pnf%npool_to_livecrootn
npool_to_livecrootn_storage => clm3%g%l%c%p%pnf%npool_to_livecrootn_storage
npool_to_livestemn => clm3%g%l%c%p%pnf%npool_to_livestemn
npool_to_livestemn_storage => clm3%g%l%c%p%pnf%npool_to_livestemn_storage
retransn_to_npool => clm3%g%l%c%p%pnf%retransn_to_npool
sminn_to_npool => clm3%g%l%c%p%pnf%sminn_to_npool
#if (defined CROP)
grainn_storage_to_xfer => clm3%g%l%c%p%pnf%grainn_storage_to_xfer
grainn_to_food => clm3%g%l%c%p%pnf%grainn_to_food
grainn_xfer_to_grainn => clm3%g%l%c%p%pnf%grainn_xfer_to_grainn
livestemn_to_litter => clm3%g%l%c%p%pnf%livestemn_to_litter
npool_to_grainn => clm3%g%l%c%p%pnf%npool_to_grainn
npool_to_grainn_storage => clm3%g%l%c%p%pnf%npool_to_grainn_storage
grainn => clm3%g%l%c%p%pns%grainn
grainn_storage => clm3%g%l%c%p%pns%grainn_storage
grainn_xfer => clm3%g%l%c%p%pns%grainn_xfer
#endif
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
deadstemn => clm3%g%l%c%p%pns%deadstemn
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
frootn => clm3%g%l%c%p%pns%frootn
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
leafn => clm3%g%l%c%p%pns%leafn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
livecrootn => clm3%g%l%c%p%pns%livecrootn
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
livestemn => clm3%g%l%c%p%pns%livestemn
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
npool => clm3%g%l%c%p%pns%npool
retransn => clm3%g%l%c%p%pns%retransn
! set time steps
! dt = real( get_step_size(), r8 )
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! column-level fluxes
! N deposition and fixation
sminn(c) = sminn(c) + ndep_to_sminn(c)*dt
sminn(c) = sminn(c) + nfix_to_sminn(c)*dt
! plant to litter fluxes
! leaf litter
litr1n(c) = litr1n(c) + leafn_to_litr1n(c)*dt
litr2n(c) = litr2n(c) + leafn_to_litr2n(c)*dt
litr3n(c) = litr3n(c) + leafn_to_litr3n(c)*dt
! fine root litter
litr1n(c) = litr1n(c) + frootn_to_litr1n(c)*dt
litr2n(c) = litr2n(c) + frootn_to_litr2n(c)*dt
litr3n(c) = litr3n(c) + frootn_to_litr3n(c)*dt
#if (defined CROP)
! livestem litter
litr1n(c) = litr1n(c) + livestemn_to_litr1n(c)*dt
litr2n(c) = litr2n(c) + livestemn_to_litr2n(c)*dt
litr3n(c) = litr3n(c) + livestemn_to_litr3n(c)*dt
! grain litter
litr1n(c) = litr1n(c) + grainn_to_litr1n(c)*dt
litr2n(c) = litr2n(c) + grainn_to_litr2n(c)*dt
litr3n(c) = litr3n(c) + grainn_to_litr3n(c)*dt
#endif
! seeding fluxes, from dynamic landcover
seedn(c) = seedn(c) - dwt_seedn_to_leaf(c) * dt
seedn(c) = seedn(c) - dwt_seedn_to_deadstem(c) * dt
! fluxes into litter and CWD, from dynamic landcover
litr1n(c) = litr1n(c) + dwt_frootn_to_litr1n(c)*dt
litr2n(c) = litr2n(c) + dwt_frootn_to_litr2n(c)*dt
litr3n(c) = litr3n(c) + dwt_frootn_to_litr3n(c)*dt
cwdn(c) = cwdn(c) + dwt_livecrootn_to_cwdn(c)*dt
cwdn(c) = cwdn(c) + dwt_deadcrootn_to_cwdn(c)*dt
! CWD to litter fluxes
cwdn(c) = cwdn(c) - cwdn_to_litr2n(c)*dt
litr2n(c) = litr2n(c) + cwdn_to_litr2n(c)*dt
cwdn(c) = cwdn(c) - cwdn_to_litr3n(c)*dt
litr3n(c) = litr3n(c) + cwdn_to_litr3n(c)*dt
! update litter states
litr1n(c) = litr1n(c) - litr1n_to_soil1n(c)*dt
litr2n(c) = litr2n(c) - litr2n_to_soil2n(c)*dt
litr3n(c) = litr3n(c) - litr3n_to_soil3n(c)*dt
! update SOM states
soil1n(c) = soil1n(c) + &
(litr1n_to_soil1n(c) + sminn_to_soil1n_l1(c) - soil1n_to_soil2n(c))*dt
soil2n(c) = soil2n(c) + &
(litr2n_to_soil2n(c) + sminn_to_soil2n_l2(c) + &
soil1n_to_soil2n(c) + sminn_to_soil2n_s1(c) - soil2n_to_soil3n(c))*dt
soil3n(c) = soil3n(c) + &
(litr3n_to_soil3n(c) + sminn_to_soil3n_l3(c) + &
soil2n_to_soil3n(c) + sminn_to_soil3n_s2(c) - soil3n_to_soil4n(c))*dt
soil4n(c) = soil4n(c) + &
(soil3n_to_soil4n(c) + sminn_to_soil4n_s3(c) - soil4n_to_sminn(c))*dt
! immobilization/mineralization in litter-to-SOM and SOM-to-SOM fluxes
sminn(c) = sminn(c) - &
(sminn_to_soil1n_l1(c) + sminn_to_soil2n_l2(c) + &
sminn_to_soil3n_l3(c) + sminn_to_soil2n_s1(c) + &
sminn_to_soil3n_s2(c) + sminn_to_soil4n_s3(c) - &
soil4n_to_sminn(c))*dt
! denitrification fluxes
sminn(c) = sminn(c) - &
(sminn_to_denit_l1s1(c) + sminn_to_denit_l2s2(c) + &
sminn_to_denit_l3s3(c) + sminn_to_denit_s1s2(c) + &
sminn_to_denit_s2s3(c) + sminn_to_denit_s3s4(c) + &
sminn_to_denit_s4(c) + sminn_to_denit_excess(c))*dt
! total plant uptake from mineral N
sminn(c) = sminn(c) - sminn_to_plant(c)*dt
! flux that prevents N limitation (when SUPLN is set)
sminn(c) = sminn(c) + supplement_to_sminn(c)*dt
end do ! end of column loop
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! phenology: transfer growth fluxes
leafn(p) = leafn(p) + leafn_xfer_to_leafn(p)*dt
leafn_xfer(p) = leafn_xfer(p) - leafn_xfer_to_leafn(p)*dt
frootn(p) = frootn(p) + frootn_xfer_to_frootn(p)*dt
frootn_xfer(p) = frootn_xfer(p) - frootn_xfer_to_frootn(p)*dt
if (woody(ivt(p)) == 1.0_r8) then
livestemn(p) = livestemn(p) + livestemn_xfer_to_livestemn(p)*dt
livestemn_xfer(p) = livestemn_xfer(p) - livestemn_xfer_to_livestemn(p)*dt
deadstemn(p) = deadstemn(p) + deadstemn_xfer_to_deadstemn(p)*dt
deadstemn_xfer(p) = deadstemn_xfer(p) - deadstemn_xfer_to_deadstemn(p)*dt
livecrootn(p) = livecrootn(p) + livecrootn_xfer_to_livecrootn(p)*dt
livecrootn_xfer(p) = livecrootn_xfer(p) - livecrootn_xfer_to_livecrootn(p)*dt
deadcrootn(p) = deadcrootn(p) + deadcrootn_xfer_to_deadcrootn(p)*dt
deadcrootn_xfer(p) = deadcrootn_xfer(p) - deadcrootn_xfer_to_deadcrootn(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
! lines here for consistency; the transfer terms are zero
livestemn(p) = livestemn(p) + livestemn_xfer_to_livestemn(p)*dt
livestemn_xfer(p) = livestemn_xfer(p) - livestemn_xfer_to_livestemn(p)*dt
grainn(p) = grainn(p) + grainn_xfer_to_grainn(p)*dt
grainn_xfer(p) = grainn_xfer(p) - grainn_xfer_to_grainn(p)*dt
write(6,*) 'in CNNStateUpdate1, grainn(',p,')=',grainn(p)
write(6,*) 'in CNNStateUpdate1, grainn_xfer_to_grainn(',p,')=',grainn_xfer_to_grainn(p)
end if
#endif
! phenology: litterfall and retranslocation fluxes
leafn(p) = leafn(p) - leafn_to_litter(p)*dt
frootn(p) = frootn(p) - frootn_to_litter(p)*dt
leafn(p) = leafn(p) - leafn_to_retransn(p)*dt
retransn(p) = retransn(p) + leafn_to_retransn(p)*dt
! live wood turnover and retranslocation fluxes
if (woody(ivt(p)) == 1._r8) then
livestemn(p) = livestemn(p) - livestemn_to_deadstemn(p)*dt
deadstemn(p) = deadstemn(p) + livestemn_to_deadstemn(p)*dt
livestemn(p) = livestemn(p) - livestemn_to_retransn(p)*dt
retransn(p) = retransn(p) + livestemn_to_retransn(p)*dt
livecrootn(p) = livecrootn(p) - livecrootn_to_deadcrootn(p)*dt
deadcrootn(p) = deadcrootn(p) + livecrootn_to_deadcrootn(p)*dt
livecrootn(p) = livecrootn(p) - livecrootn_to_retransn(p)*dt
retransn(p) = retransn(p) + livecrootn_to_retransn(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
livestemn(p) = livestemn(p) - livestemn_to_litter(p)*dt
livestemn(p) = livestemn(p) - livestemn_to_retransn(p)*dt
retransn(p) = retransn(p) + livestemn_to_retransn(p)*dt
grainn(p) = grainn(p) - grainn_to_food(p)*dt
end if
#endif
! uptake from soil mineral N pool
npool(p) = npool(p) + sminn_to_npool(p)*dt
! deployment from retranslocation pool
npool(p) = npool(p) + retransn_to_npool(p)*dt
retransn(p) = retransn(p) - retransn_to_npool(p)*dt
! allocation fluxes
npool(p) = npool(p) - npool_to_leafn(p)*dt
leafn(p) = leafn(p) + npool_to_leafn(p)*dt
npool(p) = npool(p) - npool_to_leafn_storage(p)*dt
leafn_storage(p) = leafn_storage(p) + npool_to_leafn_storage(p)*dt
npool(p) = npool(p) - npool_to_frootn(p)*dt
frootn(p) = frootn(p) + npool_to_frootn(p)*dt
npool(p) = npool(p) - npool_to_frootn_storage(p)*dt
frootn_storage(p) = frootn_storage(p) + npool_to_frootn_storage(p)*dt
if (woody(ivt(p)) == 1._r8) then
npool(p) = npool(p) - npool_to_livestemn(p)*dt
livestemn(p) = livestemn(p) + npool_to_livestemn(p)*dt
npool(p) = npool(p) - npool_to_livestemn_storage(p)*dt
livestemn_storage(p) = livestemn_storage(p) + npool_to_livestemn_storage(p)*dt
npool(p) = npool(p) - npool_to_deadstemn(p)*dt
deadstemn(p) = deadstemn(p) + npool_to_deadstemn(p)*dt
npool(p) = npool(p) - npool_to_deadstemn_storage(p)*dt
deadstemn_storage(p) = deadstemn_storage(p) + npool_to_deadstemn_storage(p)*dt
npool(p) = npool(p) - npool_to_livecrootn(p)*dt
livecrootn(p) = livecrootn(p) + npool_to_livecrootn(p)*dt
npool(p) = npool(p) - npool_to_livecrootn_storage(p)*dt
livecrootn_storage(p) = livecrootn_storage(p) + npool_to_livecrootn_storage(p)*dt
npool(p) = npool(p) - npool_to_deadcrootn(p)*dt
deadcrootn(p) = deadcrootn(p) + npool_to_deadcrootn(p)*dt
npool(p) = npool(p) - npool_to_deadcrootn_storage(p)*dt
deadcrootn_storage(p) = deadcrootn_storage(p) + npool_to_deadcrootn_storage(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
npool(p) = npool(p) - npool_to_livestemn(p)*dt
livestemn(p) = livestemn(p) + npool_to_livestemn(p)*dt
npool(p) = npool(p) - npool_to_livestemn_storage(p)*dt
livestemn_storage(p) = livestemn_storage(p) + npool_to_livestemn_storage(p)*dt
npool(p) = npool(p) - npool_to_grainn(p)*dt
grainn(p) = grainn(p) + npool_to_grainn(p)*dt
npool(p) = npool(p) - npool_to_grainn_storage(p)*dt
grainn_storage(p) = grainn_storage(p) + npool_to_grainn_storage(p)*dt
end if
#endif
! move storage pools into transfer pools
leafn_storage(p) = leafn_storage(p) - leafn_storage_to_xfer(p)*dt
leafn_xfer(p) = leafn_xfer(p) + leafn_storage_to_xfer(p)*dt
frootn_storage(p) = frootn_storage(p) - frootn_storage_to_xfer(p)*dt
frootn_xfer(p) = frootn_xfer(p) + frootn_storage_to_xfer(p)*dt
if (woody(ivt(p)) == 1._r8) then
livestemn_storage(p) = livestemn_storage(p) - livestemn_storage_to_xfer(p)*dt
livestemn_xfer(p) = livestemn_xfer(p) + livestemn_storage_to_xfer(p)*dt
deadstemn_storage(p) = deadstemn_storage(p) - deadstemn_storage_to_xfer(p)*dt
deadstemn_xfer(p) = deadstemn_xfer(p) + deadstemn_storage_to_xfer(p)*dt
livecrootn_storage(p) = livecrootn_storage(p) - livecrootn_storage_to_xfer(p)*dt
livecrootn_xfer(p) = livecrootn_xfer(p) + livecrootn_storage_to_xfer(p)*dt
deadcrootn_storage(p) = deadcrootn_storage(p) - deadcrootn_storage_to_xfer(p)*dt
deadcrootn_xfer(p) = deadcrootn_xfer(p) + deadcrootn_storage_to_xfer(p)*dt
end if
#if (defined CROP)
if (ivt(p) >= npcropmin) then ! skip 2 generic crops
! lines here for consistency; the transfer terms are zero
livestemn_storage(p) = livestemn_storage(p) - livestemn_storage_to_xfer(p)*dt
livestemn_xfer(p) = livestemn_xfer(p) + livestemn_storage_to_xfer(p)*dt
grainn_storage(p) = grainn_storage(p) - grainn_storage_to_xfer(p)*dt
grainn_xfer(p) = grainn_xfer(p) + grainn_storage_to_xfer(p)*dt
end if
#endif
end do
write(6,*) 'after NStateUpdate1,deadstemn=',deadstemn
end subroutine NStateUpdate1
!-----------------------------------------------------------------------
#endif
end module CNNStateUpdate1Mod
module CNNStateUpdate2Mod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: NStateUpdate2Mod
!
! !DESCRIPTION:
! Module for nitrogen state variable update, mortality fluxes.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public:: NStateUpdate2
public:: NStateUpdate2h
!
! !REVISION HISTORY:
! 4/23/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: NStateUpdate2
!
! !INTERFACE:
subroutine NStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! On the radiation time step, update all the prognostic nitrogen state
! variables affected by gap-phase mortality fluxes
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size
use globals,only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 8/1/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
real(r8), pointer :: m_deadcrootn_storage_to_litr1n(:)
real(r8), pointer :: m_deadcrootn_to_cwdn(:)
real(r8), pointer :: m_deadcrootn_xfer_to_litr1n(:)
real(r8), pointer :: m_deadstemn_storage_to_litr1n(:)
real(r8), pointer :: m_deadstemn_to_cwdn(:)
real(r8), pointer :: m_deadstemn_xfer_to_litr1n(:)
real(r8), pointer :: m_frootn_storage_to_litr1n(:)
real(r8), pointer :: m_frootn_to_litr1n(:)
real(r8), pointer :: m_frootn_to_litr2n(:)
real(r8), pointer :: m_frootn_to_litr3n(:)
real(r8), pointer :: m_frootn_xfer_to_litr1n(:)
real(r8), pointer :: m_leafn_storage_to_litr1n(:)
real(r8), pointer :: m_leafn_to_litr1n(:)
real(r8), pointer :: m_leafn_to_litr2n(:)
real(r8), pointer :: m_leafn_to_litr3n(:)
real(r8), pointer :: m_leafn_xfer_to_litr1n(:)
real(r8), pointer :: m_livecrootn_storage_to_litr1n(:)
real(r8), pointer :: m_livecrootn_to_cwdn(:)
real(r8), pointer :: m_livecrootn_xfer_to_litr1n(:)
real(r8), pointer :: m_livestemn_storage_to_litr1n(:)
real(r8), pointer :: m_livestemn_to_cwdn(:)
real(r8), pointer :: m_livestemn_xfer_to_litr1n(:)
real(r8), pointer :: m_retransn_to_litr1n(:)
real(r8), pointer :: m_deadcrootn_storage_to_litter(:)
real(r8), pointer :: m_deadcrootn_to_litter(:)
real(r8), pointer :: m_deadcrootn_xfer_to_litter(:)
real(r8), pointer :: m_deadstemn_storage_to_litter(:)
real(r8), pointer :: m_deadstemn_to_litter(:)
real(r8), pointer :: m_deadstemn_xfer_to_litter(:)
real(r8), pointer :: m_frootn_storage_to_litter(:)
real(r8), pointer :: m_frootn_to_litter(:)
real(r8), pointer :: m_frootn_xfer_to_litter(:)
real(r8), pointer :: m_leafn_storage_to_litter(:)
real(r8), pointer :: m_leafn_to_litter(:)
real(r8), pointer :: m_leafn_xfer_to_litter(:)
real(r8), pointer :: m_livecrootn_storage_to_litter(:)
real(r8), pointer :: m_livecrootn_to_litter(:)
real(r8), pointer :: m_livecrootn_xfer_to_litter(:)
real(r8), pointer :: m_livestemn_storage_to_litter(:)
real(r8), pointer :: m_livestemn_to_litter(:)
real(r8), pointer :: m_livestemn_xfer_to_litter(:)
real(r8), pointer :: m_retransn_to_litter(:)
!
! local pointers to implicit in/out scalars
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: litr1n(:) ! (gN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (gN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (gN/m2) litter lignin N
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
! real(r8):: dt ! radiation time step (seconds)
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the column level
m_deadcrootn_storage_to_litr1n => clm3%g%l%c%cnf%m_deadcrootn_storage_to_litr1n
m_deadcrootn_to_cwdn => clm3%g%l%c%cnf%m_deadcrootn_to_cwdn
m_deadcrootn_xfer_to_litr1n => clm3%g%l%c%cnf%m_deadcrootn_xfer_to_litr1n
m_deadstemn_storage_to_litr1n => clm3%g%l%c%cnf%m_deadstemn_storage_to_litr1n
m_deadstemn_to_cwdn => clm3%g%l%c%cnf%m_deadstemn_to_cwdn
m_deadstemn_xfer_to_litr1n => clm3%g%l%c%cnf%m_deadstemn_xfer_to_litr1n
m_frootn_storage_to_litr1n => clm3%g%l%c%cnf%m_frootn_storage_to_litr1n
m_frootn_to_litr1n => clm3%g%l%c%cnf%m_frootn_to_litr1n
m_frootn_to_litr2n => clm3%g%l%c%cnf%m_frootn_to_litr2n
m_frootn_to_litr3n => clm3%g%l%c%cnf%m_frootn_to_litr3n
m_frootn_xfer_to_litr1n => clm3%g%l%c%cnf%m_frootn_xfer_to_litr1n
m_leafn_storage_to_litr1n => clm3%g%l%c%cnf%m_leafn_storage_to_litr1n
m_leafn_to_litr1n => clm3%g%l%c%cnf%m_leafn_to_litr1n
m_leafn_to_litr2n => clm3%g%l%c%cnf%m_leafn_to_litr2n
m_leafn_to_litr3n => clm3%g%l%c%cnf%m_leafn_to_litr3n
m_leafn_xfer_to_litr1n => clm3%g%l%c%cnf%m_leafn_xfer_to_litr1n
m_livecrootn_storage_to_litr1n => clm3%g%l%c%cnf%m_livecrootn_storage_to_litr1n
m_livecrootn_to_cwdn => clm3%g%l%c%cnf%m_livecrootn_to_cwdn
m_livecrootn_xfer_to_litr1n => clm3%g%l%c%cnf%m_livecrootn_xfer_to_litr1n
m_livestemn_storage_to_litr1n => clm3%g%l%c%cnf%m_livestemn_storage_to_litr1n
m_livestemn_to_cwdn => clm3%g%l%c%cnf%m_livestemn_to_cwdn
m_livestemn_xfer_to_litr1n => clm3%g%l%c%cnf%m_livestemn_xfer_to_litr1n
m_retransn_to_litr1n => clm3%g%l%c%cnf%m_retransn_to_litr1n
cwdn => clm3%g%l%c%cns%cwdn
litr1n => clm3%g%l%c%cns%litr1n
litr2n => clm3%g%l%c%cns%litr2n
litr3n => clm3%g%l%c%cns%litr3n
! assign local pointers at the pft level
m_deadcrootn_storage_to_litter => clm3%g%l%c%p%pnf%m_deadcrootn_storage_to_litter
m_deadcrootn_to_litter => clm3%g%l%c%p%pnf%m_deadcrootn_to_litter
m_deadcrootn_xfer_to_litter => clm3%g%l%c%p%pnf%m_deadcrootn_xfer_to_litter
m_deadstemn_storage_to_litter => clm3%g%l%c%p%pnf%m_deadstemn_storage_to_litter
m_deadstemn_to_litter => clm3%g%l%c%p%pnf%m_deadstemn_to_litter
m_deadstemn_xfer_to_litter => clm3%g%l%c%p%pnf%m_deadstemn_xfer_to_litter
m_frootn_storage_to_litter => clm3%g%l%c%p%pnf%m_frootn_storage_to_litter
m_frootn_to_litter => clm3%g%l%c%p%pnf%m_frootn_to_litter
m_frootn_xfer_to_litter => clm3%g%l%c%p%pnf%m_frootn_xfer_to_litter
m_leafn_storage_to_litter => clm3%g%l%c%p%pnf%m_leafn_storage_to_litter
m_leafn_to_litter => clm3%g%l%c%p%pnf%m_leafn_to_litter
m_leafn_xfer_to_litter => clm3%g%l%c%p%pnf%m_leafn_xfer_to_litter
m_livecrootn_storage_to_litter => clm3%g%l%c%p%pnf%m_livecrootn_storage_to_litter
m_livecrootn_to_litter => clm3%g%l%c%p%pnf%m_livecrootn_to_litter
m_livecrootn_xfer_to_litter => clm3%g%l%c%p%pnf%m_livecrootn_xfer_to_litter
m_livestemn_storage_to_litter => clm3%g%l%c%p%pnf%m_livestemn_storage_to_litter
m_livestemn_to_litter => clm3%g%l%c%p%pnf%m_livestemn_to_litter
m_livestemn_xfer_to_litter => clm3%g%l%c%p%pnf%m_livestemn_xfer_to_litter
m_retransn_to_litter => clm3%g%l%c%p%pnf%m_retransn_to_litter
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
deadstemn => clm3%g%l%c%p%pns%deadstemn
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
frootn => clm3%g%l%c%p%pns%frootn
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
leafn => clm3%g%l%c%p%pns%leafn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
livecrootn => clm3%g%l%c%p%pns%livecrootn
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
livestemn => clm3%g%l%c%p%pns%livestemn
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
retransn => clm3%g%l%c%p%pns%retransn
! set time steps
! dt = real( get_step_size(), r8 )
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! column-level nitrogen fluxes from gap-phase mortality
! leaf to litter
litr1n(c) = litr1n(c) + m_leafn_to_litr1n(c) * dt
litr2n(c) = litr2n(c) + m_leafn_to_litr2n(c) * dt
litr3n(c) = litr3n(c) + m_leafn_to_litr3n(c) * dt
! fine root to litter
litr1n(c) = litr1n(c) + m_frootn_to_litr1n(c) * dt
litr2n(c) = litr2n(c) + m_frootn_to_litr2n(c) * dt
litr3n(c) = litr3n(c) + m_frootn_to_litr3n(c) * dt
! wood to CWD
cwdn(c) = cwdn(c) + m_livestemn_to_cwdn(c) * dt
cwdn(c) = cwdn(c) + m_deadstemn_to_cwdn(c) * dt
cwdn(c) = cwdn(c) + m_livecrootn_to_cwdn(c) * dt
cwdn(c) = cwdn(c) + m_deadcrootn_to_cwdn(c) * dt
! retranslocated N pool to litter
litr1n(c) = litr1n(c) + m_retransn_to_litr1n(c) * dt
! storage pools to litter
litr1n(c) = litr1n(c) + m_leafn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_frootn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_livestemn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_deadstemn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_livecrootn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_deadcrootn_storage_to_litr1n(c) * dt
! transfer pools to litter
litr1n(c) = litr1n(c) + m_leafn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_frootn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_livestemn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_deadstemn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_livecrootn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + m_deadcrootn_xfer_to_litr1n(c) * dt
end do ! end of column loop
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! pft-level nitrogen fluxes from gap-phase mortality
! displayed pools
leafn(p) = leafn(p) - m_leafn_to_litter(p) * dt
frootn(p) = frootn(p) - m_frootn_to_litter(p) * dt
livestemn(p) = livestemn(p) - m_livestemn_to_litter(p) * dt
deadstemn(p) = deadstemn(p) - m_deadstemn_to_litter(p) * dt
livecrootn(p) = livecrootn(p) - m_livecrootn_to_litter(p) * dt
deadcrootn(p) = deadcrootn(p) - m_deadcrootn_to_litter(p) * dt
retransn(p) = retransn(p) - m_retransn_to_litter(p) * dt
! storage pools
leafn_storage(p) = leafn_storage(p) - m_leafn_storage_to_litter(p) * dt
frootn_storage(p) = frootn_storage(p) - m_frootn_storage_to_litter(p) * dt
livestemn_storage(p) = livestemn_storage(p) - m_livestemn_storage_to_litter(p) * dt
deadstemn_storage(p) = deadstemn_storage(p) - m_deadstemn_storage_to_litter(p) * dt
livecrootn_storage(p) = livecrootn_storage(p) - m_livecrootn_storage_to_litter(p) * dt
deadcrootn_storage(p) = deadcrootn_storage(p) - m_deadcrootn_storage_to_litter(p) * dt
! transfer pools
leafn_xfer(p) = leafn_xfer(p) - m_leafn_xfer_to_litter(p) * dt
frootn_xfer(p) = frootn_xfer(p) - m_frootn_xfer_to_litter(p) * dt
livestemn_xfer(p) = livestemn_xfer(p) - m_livestemn_xfer_to_litter(p) * dt
deadstemn_xfer(p) = deadstemn_xfer(p) - m_deadstemn_xfer_to_litter(p) * dt
livecrootn_xfer(p) = livecrootn_xfer(p) - m_livecrootn_xfer_to_litter(p) * dt
deadcrootn_xfer(p) = deadcrootn_xfer(p) - m_deadcrootn_xfer_to_litter(p) * dt
end do
end subroutine NStateUpdate2
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: NStateUpdate2h
!
! !INTERFACE:
subroutine NStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! Update all the prognostic nitrogen state
! variables affected by harvest mortality fluxes
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size
use globals, only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 8/1/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
real(r8), pointer :: hrv_deadcrootn_storage_to_litr1n(:)
real(r8), pointer :: hrv_deadcrootn_to_cwdn(:)
real(r8), pointer :: hrv_deadcrootn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_deadstemn_storage_to_litr1n(:)
real(r8), pointer :: hrv_deadstemn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_frootn_storage_to_litr1n(:)
real(r8), pointer :: hrv_frootn_to_litr1n(:)
real(r8), pointer :: hrv_frootn_to_litr2n(:)
real(r8), pointer :: hrv_frootn_to_litr3n(:)
real(r8), pointer :: hrv_frootn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_leafn_storage_to_litr1n(:)
real(r8), pointer :: hrv_leafn_to_litr1n(:)
real(r8), pointer :: hrv_leafn_to_litr2n(:)
real(r8), pointer :: hrv_leafn_to_litr3n(:)
real(r8), pointer :: hrv_leafn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_livecrootn_storage_to_litr1n(:)
real(r8), pointer :: hrv_livecrootn_to_cwdn(:)
real(r8), pointer :: hrv_livecrootn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_livestemn_storage_to_litr1n(:)
real(r8), pointer :: hrv_livestemn_to_cwdn(:)
real(r8), pointer :: hrv_livestemn_xfer_to_litr1n(:)
real(r8), pointer :: hrv_retransn_to_litr1n(:)
real(r8), pointer :: hrv_deadcrootn_storage_to_litter(:)
real(r8), pointer :: hrv_deadcrootn_to_litter(:)
real(r8), pointer :: hrv_deadcrootn_xfer_to_litter(:)
real(r8), pointer :: hrv_deadstemn_storage_to_litter(:)
real(r8), pointer :: hrv_deadstemn_to_prod10n(:)
real(r8), pointer :: hrv_deadstemn_to_prod100n(:)
real(r8), pointer :: hrv_deadstemn_xfer_to_litter(:)
real(r8), pointer :: hrv_frootn_storage_to_litter(:)
real(r8), pointer :: hrv_frootn_to_litter(:)
real(r8), pointer :: hrv_frootn_xfer_to_litter(:)
real(r8), pointer :: hrv_leafn_storage_to_litter(:)
real(r8), pointer :: hrv_leafn_to_litter(:)
real(r8), pointer :: hrv_leafn_xfer_to_litter(:)
real(r8), pointer :: hrv_livecrootn_storage_to_litter(:)
real(r8), pointer :: hrv_livecrootn_to_litter(:)
real(r8), pointer :: hrv_livecrootn_xfer_to_litter(:)
real(r8), pointer :: hrv_livestemn_storage_to_litter(:)
real(r8), pointer :: hrv_livestemn_to_litter(:)
real(r8), pointer :: hrv_livestemn_xfer_to_litter(:)
real(r8), pointer :: hrv_retransn_to_litter(:)
!
! local pointers to implicit in/out scalars
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: litr1n(:) ! (gN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (gN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (gN/m2) litter lignin N
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
! real(r8):: dt ! radiation time step (seconds)
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the column level
hrv_deadcrootn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_deadcrootn_storage_to_litr1n
hrv_deadcrootn_to_cwdn => clm3%g%l%c%cnf%hrv_deadcrootn_to_cwdn
hrv_deadcrootn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_deadcrootn_xfer_to_litr1n
hrv_deadstemn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_deadstemn_storage_to_litr1n
hrv_deadstemn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_deadstemn_xfer_to_litr1n
hrv_frootn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_frootn_storage_to_litr1n
hrv_frootn_to_litr1n => clm3%g%l%c%cnf%hrv_frootn_to_litr1n
hrv_frootn_to_litr2n => clm3%g%l%c%cnf%hrv_frootn_to_litr2n
hrv_frootn_to_litr3n => clm3%g%l%c%cnf%hrv_frootn_to_litr3n
hrv_frootn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_frootn_xfer_to_litr1n
hrv_leafn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_leafn_storage_to_litr1n
hrv_leafn_to_litr1n => clm3%g%l%c%cnf%hrv_leafn_to_litr1n
hrv_leafn_to_litr2n => clm3%g%l%c%cnf%hrv_leafn_to_litr2n
hrv_leafn_to_litr3n => clm3%g%l%c%cnf%hrv_leafn_to_litr3n
hrv_leafn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_leafn_xfer_to_litr1n
hrv_livecrootn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_livecrootn_storage_to_litr1n
hrv_livecrootn_to_cwdn => clm3%g%l%c%cnf%hrv_livecrootn_to_cwdn
hrv_livecrootn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_livecrootn_xfer_to_litr1n
hrv_livestemn_storage_to_litr1n => clm3%g%l%c%cnf%hrv_livestemn_storage_to_litr1n
hrv_livestemn_to_cwdn => clm3%g%l%c%cnf%hrv_livestemn_to_cwdn
hrv_livestemn_xfer_to_litr1n => clm3%g%l%c%cnf%hrv_livestemn_xfer_to_litr1n
hrv_retransn_to_litr1n => clm3%g%l%c%cnf%hrv_retransn_to_litr1n
cwdn => clm3%g%l%c%cns%cwdn
litr1n => clm3%g%l%c%cns%litr1n
litr2n => clm3%g%l%c%cns%litr2n
litr3n => clm3%g%l%c%cns%litr3n
! assign local pointers at the pft level
hrv_deadcrootn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_deadcrootn_storage_to_litter
hrv_deadcrootn_to_litter => clm3%g%l%c%p%pnf%hrv_deadcrootn_to_litter
hrv_deadcrootn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_deadcrootn_xfer_to_litter
hrv_deadstemn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_deadstemn_storage_to_litter
hrv_deadstemn_to_prod10n => clm3%g%l%c%p%pnf%hrv_deadstemn_to_prod10n
hrv_deadstemn_to_prod100n => clm3%g%l%c%p%pnf%hrv_deadstemn_to_prod100n
hrv_deadstemn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_deadstemn_xfer_to_litter
hrv_frootn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_frootn_storage_to_litter
hrv_frootn_to_litter => clm3%g%l%c%p%pnf%hrv_frootn_to_litter
hrv_frootn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_frootn_xfer_to_litter
hrv_leafn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_leafn_storage_to_litter
hrv_leafn_to_litter => clm3%g%l%c%p%pnf%hrv_leafn_to_litter
hrv_leafn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_leafn_xfer_to_litter
hrv_livecrootn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_livecrootn_storage_to_litter
hrv_livecrootn_to_litter => clm3%g%l%c%p%pnf%hrv_livecrootn_to_litter
hrv_livecrootn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_livecrootn_xfer_to_litter
hrv_livestemn_storage_to_litter => clm3%g%l%c%p%pnf%hrv_livestemn_storage_to_litter
hrv_livestemn_to_litter => clm3%g%l%c%p%pnf%hrv_livestemn_to_litter
hrv_livestemn_xfer_to_litter => clm3%g%l%c%p%pnf%hrv_livestemn_xfer_to_litter
hrv_retransn_to_litter => clm3%g%l%c%p%pnf%hrv_retransn_to_litter
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
deadstemn => clm3%g%l%c%p%pns%deadstemn
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
frootn => clm3%g%l%c%p%pns%frootn
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
leafn => clm3%g%l%c%p%pns%leafn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
livecrootn => clm3%g%l%c%p%pns%livecrootn
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
livestemn => clm3%g%l%c%p%pns%livestemn
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
retransn => clm3%g%l%c%p%pns%retransn
! set time steps
! dt = real( get_step_size(), r8 )
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! column-level nitrogen fluxes from harvest mortality
! leaf to litter
litr1n(c) = litr1n(c) + hrv_leafn_to_litr1n(c) * dt
litr2n(c) = litr2n(c) + hrv_leafn_to_litr2n(c) * dt
litr3n(c) = litr3n(c) + hrv_leafn_to_litr3n(c) * dt
! fine root to litter
litr1n(c) = litr1n(c) + hrv_frootn_to_litr1n(c) * dt
litr2n(c) = litr2n(c) + hrv_frootn_to_litr2n(c) * dt
litr3n(c) = litr3n(c) + hrv_frootn_to_litr3n(c) * dt
! wood to CWD
cwdn(c) = cwdn(c) + hrv_livestemn_to_cwdn(c) * dt
cwdn(c) = cwdn(c) + hrv_livecrootn_to_cwdn(c) * dt
cwdn(c) = cwdn(c) + hrv_deadcrootn_to_cwdn(c) * dt
! wood to product pools - updates done in CNWoodProducts()
! retranslocated N pool to litter
litr1n(c) = litr1n(c) + hrv_retransn_to_litr1n(c) * dt
! storage pools to litter
litr1n(c) = litr1n(c) + hrv_leafn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_frootn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_livestemn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_deadstemn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_livecrootn_storage_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_deadcrootn_storage_to_litr1n(c) * dt
! transfer pools to litter
litr1n(c) = litr1n(c) + hrv_leafn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_frootn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_livestemn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_deadstemn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_livecrootn_xfer_to_litr1n(c) * dt
litr1n(c) = litr1n(c) + hrv_deadcrootn_xfer_to_litr1n(c) * dt
end do ! end of column loop
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! pft-level nitrogen fluxes from harvest mortality
! displayed pools
leafn(p) = leafn(p) - hrv_leafn_to_litter(p) * dt
frootn(p) = frootn(p) - hrv_frootn_to_litter(p) * dt
livestemn(p) = livestemn(p) - hrv_livestemn_to_litter(p) * dt
deadstemn(p) = deadstemn(p) - hrv_deadstemn_to_prod10n(p) * dt
deadstemn(p) = deadstemn(p) - hrv_deadstemn_to_prod100n(p)* dt
livecrootn(p) = livecrootn(p) - hrv_livecrootn_to_litter(p) * dt
deadcrootn(p) = deadcrootn(p) - hrv_deadcrootn_to_litter(p) * dt
retransn(p) = retransn(p) - hrv_retransn_to_litter(p) * dt
! storage pools
leafn_storage(p) = leafn_storage(p) - hrv_leafn_storage_to_litter(p) * dt
frootn_storage(p) = frootn_storage(p) - hrv_frootn_storage_to_litter(p) * dt
livestemn_storage(p) = livestemn_storage(p) - hrv_livestemn_storage_to_litter(p) * dt
deadstemn_storage(p) = deadstemn_storage(p) - hrv_deadstemn_storage_to_litter(p) * dt
livecrootn_storage(p) = livecrootn_storage(p) - hrv_livecrootn_storage_to_litter(p) * dt
deadcrootn_storage(p) = deadcrootn_storage(p) - hrv_deadcrootn_storage_to_litter(p) * dt
! transfer pools
leafn_xfer(p) = leafn_xfer(p) - hrv_leafn_xfer_to_litter(p) * dt
frootn_xfer(p) = frootn_xfer(p) - hrv_frootn_xfer_to_litter(p) * dt
livestemn_xfer(p) = livestemn_xfer(p) - hrv_livestemn_xfer_to_litter(p) * dt
deadstemn_xfer(p) = deadstemn_xfer(p) - hrv_deadstemn_xfer_to_litter(p) * dt
livecrootn_xfer(p) = livecrootn_xfer(p) - hrv_livecrootn_xfer_to_litter(p) * dt
deadcrootn_xfer(p) = deadcrootn_xfer(p) - hrv_deadcrootn_xfer_to_litter(p) * dt
end do
end subroutine NStateUpdate2h
!-----------------------------------------------------------------------
#endif
end module CNNStateUpdate2Mod
module CNNStateUpdate3Mod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: NStateUpdate3Mod
!
! !DESCRIPTION:
! Module for nitrogen state variable update, mortality fluxes.
! Also, sminn leaching flux.
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public:: NStateUpdate3
!
! !REVISION HISTORY:
! 7/27/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: NStateUpdate3
!
! !INTERFACE:
subroutine NStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! On the radiation time step, update all the prognostic nitrogen state
! variables affected by gap-phase mortality fluxes. Also the Sminn leaching flux.
!
! !USES:
use clmtype
! use clm_time_manager, only: get_step_size
use globals , only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 8/1/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
real(r8), pointer :: sminn_leached(:)
real(r8), pointer :: m_cwdn_to_fire(:)
real(r8), pointer :: m_deadcrootn_to_cwdn_fire(:)
real(r8), pointer :: m_deadstemn_to_cwdn_fire(:)
real(r8), pointer :: m_litr1n_to_fire(:)
real(r8), pointer :: m_litr2n_to_fire(:)
real(r8), pointer :: m_litr3n_to_fire(:)
real(r8), pointer :: m_deadcrootn_storage_to_fire(:)
real(r8), pointer :: m_deadcrootn_to_fire(:)
real(r8), pointer :: m_deadcrootn_to_litter_fire(:)
real(r8), pointer :: m_deadcrootn_xfer_to_fire(:)
real(r8), pointer :: m_deadstemn_storage_to_fire(:)
real(r8), pointer :: m_deadstemn_to_fire(:)
real(r8), pointer :: m_deadstemn_to_litter_fire(:)
real(r8), pointer :: m_deadstemn_xfer_to_fire(:)
real(r8), pointer :: m_frootn_storage_to_fire(:)
real(r8), pointer :: m_frootn_to_fire(:)
real(r8), pointer :: m_frootn_xfer_to_fire(:)
real(r8), pointer :: m_leafn_storage_to_fire(:)
real(r8), pointer :: m_leafn_to_fire(:)
real(r8), pointer :: m_leafn_xfer_to_fire(:)
real(r8), pointer :: m_livecrootn_storage_to_fire(:)
real(r8), pointer :: m_livecrootn_to_fire(:)
real(r8), pointer :: m_livecrootn_xfer_to_fire(:)
real(r8), pointer :: m_livestemn_storage_to_fire(:)
real(r8), pointer :: m_livestemn_to_fire(:)
real(r8), pointer :: m_livestemn_xfer_to_fire(:)
real(r8), pointer :: m_retransn_to_fire(:)
!
! local pointers to implicit in/out scalars
real(r8), pointer :: sminn(:) ! (gN/m2) soil mineral N
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: litr1n(:) ! (gN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (gN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (gN/m2) litter lignin N
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
!
! local pointers to implicit out scalars
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
! real(r8):: dt ! radiation time step (seconds)
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the column level
sminn_leached => clm3%g%l%c%cnf%sminn_leached
m_cwdn_to_fire => clm3%g%l%c%cnf%m_cwdn_to_fire
m_deadcrootn_to_cwdn_fire => clm3%g%l%c%cnf%m_deadcrootn_to_cwdn_fire
m_deadstemn_to_cwdn_fire => clm3%g%l%c%cnf%m_deadstemn_to_cwdn_fire
m_litr1n_to_fire => clm3%g%l%c%cnf%m_litr1n_to_fire
m_litr2n_to_fire => clm3%g%l%c%cnf%m_litr2n_to_fire
m_litr3n_to_fire => clm3%g%l%c%cnf%m_litr3n_to_fire
sminn => clm3%g%l%c%cns%sminn
cwdn => clm3%g%l%c%cns%cwdn
litr1n => clm3%g%l%c%cns%litr1n
litr2n => clm3%g%l%c%cns%litr2n
litr3n => clm3%g%l%c%cns%litr3n
! assign local pointers at the pft level
m_deadcrootn_storage_to_fire => clm3%g%l%c%p%pnf%m_deadcrootn_storage_to_fire
m_deadcrootn_to_fire => clm3%g%l%c%p%pnf%m_deadcrootn_to_fire
m_deadcrootn_to_litter_fire => clm3%g%l%c%p%pnf%m_deadcrootn_to_litter_fire
m_deadcrootn_xfer_to_fire => clm3%g%l%c%p%pnf%m_deadcrootn_xfer_to_fire
m_deadstemn_storage_to_fire => clm3%g%l%c%p%pnf%m_deadstemn_storage_to_fire
m_deadstemn_to_fire => clm3%g%l%c%p%pnf%m_deadstemn_to_fire
m_deadstemn_to_litter_fire => clm3%g%l%c%p%pnf%m_deadstemn_to_litter_fire
m_deadstemn_xfer_to_fire => clm3%g%l%c%p%pnf%m_deadstemn_xfer_to_fire
m_frootn_storage_to_fire => clm3%g%l%c%p%pnf%m_frootn_storage_to_fire
m_frootn_to_fire => clm3%g%l%c%p%pnf%m_frootn_to_fire
m_frootn_xfer_to_fire => clm3%g%l%c%p%pnf%m_frootn_xfer_to_fire
m_leafn_storage_to_fire => clm3%g%l%c%p%pnf%m_leafn_storage_to_fire
m_leafn_to_fire => clm3%g%l%c%p%pnf%m_leafn_to_fire
m_leafn_xfer_to_fire => clm3%g%l%c%p%pnf%m_leafn_xfer_to_fire
m_livecrootn_storage_to_fire => clm3%g%l%c%p%pnf%m_livecrootn_storage_to_fire
m_livecrootn_to_fire => clm3%g%l%c%p%pnf%m_livecrootn_to_fire
m_livecrootn_xfer_to_fire => clm3%g%l%c%p%pnf%m_livecrootn_xfer_to_fire
m_livestemn_storage_to_fire => clm3%g%l%c%p%pnf%m_livestemn_storage_to_fire
m_livestemn_to_fire => clm3%g%l%c%p%pnf%m_livestemn_to_fire
m_livestemn_xfer_to_fire => clm3%g%l%c%p%pnf%m_livestemn_xfer_to_fire
m_retransn_to_fire => clm3%g%l%c%p%pnf%m_retransn_to_fire
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
deadstemn => clm3%g%l%c%p%pns%deadstemn
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
frootn => clm3%g%l%c%p%pns%frootn
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
leafn => clm3%g%l%c%p%pns%leafn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
livecrootn => clm3%g%l%c%p%pns%livecrootn
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
livestemn => clm3%g%l%c%p%pns%livestemn
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
retransn => clm3%g%l%c%p%pns%retransn
! set time steps
! dt = real( get_step_size(), r8 )
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! mineral N loss due to leaching
sminn(c) = sminn(c) - sminn_leached(c) * dt
! column level nitrogen fluxes from fire
! pft-level wood to column-level CWD (uncombusted wood)
cwdn(c) = cwdn(c) + m_deadstemn_to_cwdn_fire(c) * dt
cwdn(c) = cwdn(c) + m_deadcrootn_to_cwdn_fire(c) * dt
! litter and CWD losses to fire
litr1n(c) = litr1n(c) - m_litr1n_to_fire(c) * dt
litr2n(c) = litr2n(c) - m_litr2n_to_fire(c) * dt
litr3n(c) = litr3n(c) - m_litr3n_to_fire(c) * dt
cwdn(c) = cwdn(c) - m_cwdn_to_fire(c) * dt
end do ! end of column loop
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! pft-level nitrogen fluxes from fire
! displayed pools
leafn(p) = leafn(p) - m_leafn_to_fire(p) * dt
frootn(p) = frootn(p) - m_frootn_to_fire(p) * dt
livestemn(p) = livestemn(p) - m_livestemn_to_fire(p) * dt
deadstemn(p) = deadstemn(p) - m_deadstemn_to_fire(p) * dt
deadstemn(p) = deadstemn(p) - m_deadstemn_to_litter_fire(p) * dt
livecrootn(p) = livecrootn(p) - m_livecrootn_to_fire(p) * dt
deadcrootn(p) = deadcrootn(p) - m_deadcrootn_to_fire(p) * dt
deadcrootn(p) = deadcrootn(p) - m_deadcrootn_to_litter_fire(p) * dt
! storage pools
leafn_storage(p) = leafn_storage(p) - m_leafn_storage_to_fire(p) * dt
frootn_storage(p) = frootn_storage(p) - m_frootn_storage_to_fire(p) * dt
livestemn_storage(p) = livestemn_storage(p) - m_livestemn_storage_to_fire(p) * dt
deadstemn_storage(p) = deadstemn_storage(p) - m_deadstemn_storage_to_fire(p) * dt
livecrootn_storage(p) = livecrootn_storage(p) - m_livecrootn_storage_to_fire(p) * dt
deadcrootn_storage(p) = deadcrootn_storage(p) - m_deadcrootn_storage_to_fire(p) * dt
! transfer pools
leafn_xfer(p) = leafn_xfer(p) - m_leafn_xfer_to_fire(p) * dt
frootn_xfer(p) = frootn_xfer(p) - m_frootn_xfer_to_fire(p) * dt
livestemn_xfer(p) = livestemn_xfer(p) - m_livestemn_xfer_to_fire(p) * dt
deadstemn_xfer(p) = deadstemn_xfer(p) - m_deadstemn_xfer_to_fire(p) * dt
livecrootn_xfer(p) = livecrootn_xfer(p) - m_livecrootn_xfer_to_fire(p) * dt
deadcrootn_xfer(p) = deadcrootn_xfer(p) - m_deadcrootn_xfer_to_fire(p) * dt
! retranslocated N pool
retransn(p) = retransn(p) - m_retransn_to_fire(p) * dt
end do
end subroutine NStateUpdate3
!-----------------------------------------------------------------------
#endif
end module CNNStateUpdate3Mod
module CNPhenologyMod 1,3
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNPhenologyMod
!
! !DESCRIPTION:
! Module holding routines used in phenology model for coupled carbon
! nitrogen code.
!
! !USES:
use clmtype
use shr_kind_mod, only: r8 => shr_kind_r8
#if (defined CROP)
use clm_varcon , only: tfrz
! use clm_varctl , only: iulog
!ylu remove
! use shr_sys_mod , only: shr_sys_flush
#endif
implicit none
save
private
! local variables to the whole module
#if (defined CROP)
integer, parameter :: irotation = 0 ! eventually from dataset? (slevis)
#endif
! !PUBLIC MEMBER FUNCTIONS:
public :: CNPhenology
!
! !REVISION HISTORY:
! 8/1/03: Created by Peter Thornton
! 10/23/03, Peter Thornton: migrated all routines to vector data structures
! 2/4/08, slevis: adding crop phenology from AgroIBIS
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNPhenology
!
! !INTERFACE:
#if (defined CROP)
subroutine CNPhenology (num_soilc, filter_soilc, num_soilp, filter_soilp, num_pcropp, filter_pcropp) 2,11
#else
subroutine CNPhenology (num_soilc, filter_soilc, num_soilp, filter_soilp) 2,11
#endif
!
! !DESCRIPTION:
! Dynamic phenology routine for coupled carbon-nitrogen code (CN)
! 1. grass phenology
!
! !USES:
!
! !ARGUMENTS:
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
#if (defined CROP)
integer, intent(in) :: num_pcropp ! number of prog. crop pfts in filter
integer, intent(in) :: filter_pcropp(:)! filter for prognostic crop pfts
#endif
!
! !CALLED FROM:
! subroutine CNEcosystemDyn in module CNEcosystemDynMod.F90
!
! !REVISION HISTORY:
! 7/28/03: Created by Peter Thornton
! 9/05/03, Peter Thornton: moved from call with (p) to call with (c)
! 10/3/03, Peter Thornton: added subroutine calls for different phenology types
! 11/7/03, Peter Thornton: moved phenology type tests into phenology type
! routines, and moved onset, offset, background litfall routines into
! main phenology call.
! !LOCAL VARIABLES:
! local pointers to implicit in arrays
!
! local pointers to implicit in/out scalars
!
! local pointers to implicit out scalars
!
! !OTHER LOCAL VARIABLES:
!EOP
!-----------------------------------------------------------------------
! each of the following phenology type routines includes a filter
! to operate only on the relevant pfts
#if (defined CROP)
call CNPhenologyClimate(num_soilp, filter_soilp, num_pcropp, filter_pcropp)
#else
call CNPhenologyClimate(num_soilp, filter_soilp)
#endif
call CNEvergreenPhenology(num_soilp, filter_soilp)
call CNSeasonDecidPhenology(num_soilp, filter_soilp)
call CNStressDecidPhenology(num_soilp, filter_soilp)
#if (defined CROP)
call CropPhenology(num_pcropp, filter_pcropp)
#endif
! the same onset and offset routines are called regardless of
! phenology type - they depend only on onset_flag, offset_flag, bglfr, and bgtr
call CNOnsetGrowth(num_soilp, filter_soilp)
call CNOffsetLitterfall(num_soilp, filter_soilp)
call CNBackgroundLitterfall(num_soilp, filter_soilp)
call CNLivewoodTurnover(num_soilp, filter_soilp)
! gather all pft-level litterfall fluxes to the column
! for litter C and N inputs
call CNLitterToColumn(num_soilc, filter_soilc)
end subroutine CNPhenology
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNPhenologyClimate
!
! !INTERFACE:
#if (defined CROP)
subroutine CNPhenologyClimate (num_soilp, filter_soilp, num_pcropp, filter_pcropp) 2,2
#else
subroutine CNPhenologyClimate (num_soilp, filter_soilp) 2,2
#endif
!
! !DESCRIPTION:
! For coupled carbon-nitrogen code (CN).
!
! !USES:
! use clm_time_manager, only: get_step_size
use globals, only : dt
#if (defined CROP)
! use clm_time_manager, only: get_start_date, get_curr_date
use globals, only: iyear0,year,month,day,secs !ylu add
#endif
!
! !ARGUMENTS:
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
#if (defined CROP)
integer, intent(in) :: num_pcropp ! number of prognostic crops in filter
integer, intent(in) :: filter_pcropp(:)! filter for prognostic crop pfts
#endif
!
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 3/13/07: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
integer , pointer :: ivt(:) ! pft vegetation type
! ecophysiological constants
real(r8), pointer :: t_ref2m(:) ! 2m air temperature (K)
real(r8), pointer :: tempavg_t2m(:) ! temp. avg 2m air temperature (K)
#if (defined CROP)
real(r8), pointer :: gdd0(:) ! growing deg. days base 0 deg C
real(r8), pointer :: gdd8(:) ! 8
real(r8), pointer :: gdd10(:) ! 10 (ddays)
real(r8), pointer :: gdd020(:) ! 20-yr means of same variables
real(r8), pointer :: gdd820(:)
real(r8), pointer :: gdd1020(:)
real(r8), pointer :: latdeg(:) ! latitude (radians)
integer , pointer :: pgridcell(:) ! pft's gridcell index
#endif
!
! local pointers to implicit in/out scalars
!
!
! local pointers to implicit out scalars
!
! !OTHER LOCAL VARIABLES:
integer :: p ! indices
integer :: fp !lake filter pft index
! real(r8):: dt !radiation time step delta t (seconds)
real(r8):: fracday !dtime as a fraction of day
#if (defined CROP)
! integer iyear0 ! initial year of initial run
integer kyr ! current year
integer kmo ! month of year (1, ..., 12)
integer kda ! day of month (1, ..., 31)
integer mcsec ! seconds of day (0, ..., 86400)
#endif
!EOP
!-----------------------------------------------------------------------
! assign local pointers to derived type arrays
ivt => clm3%g%l%c%p%itype
t_ref2m => clm3%g%l%c%p%pes%t_ref2m
tempavg_t2m => clm3%g%l%c%p%pepv%tempavg_t2m
#if (defined CROP)
gdd0 => clm3%g%l%c%p%pps%gdd0
gdd8 => clm3%g%l%c%p%pps%gdd8
gdd10 => clm3%g%l%c%p%pps%gdd10
gdd020 => clm3%g%l%c%p%pps%gdd020
gdd820 => clm3%g%l%c%p%pps%gdd820
gdd1020 => clm3%g%l%c%p%pps%gdd1020
latdeg => clm3%g%latdeg
pgridcell => clm3%g%l%c%p%gridcell
! get time-related info
!ylu removed and add
! call get_start_date(iyear0, kmo, kda, mcsec)
! call get_curr_date ( kyr, kmo, kda, mcsec)
kyr=year
kmo=month
kda=day
mcsec=secs
#endif
! set time steps
!ylu removed
! dt = real( get_step_size(), r8 )
fracday = dt/86400.0_r8
do fp = 1,num_soilp
p = filter_soilp(fp)
tempavg_t2m(p) = tempavg_t2m(p) + t_ref2m(p) * (fracday/365._r8)
end do
! The following lines come from ibis's climate.f + stats.f
! gdd SUMMATIONS ARE RELATIVE TO THE PLANTING DATE (see subr. updateAccFlds)
#if (defined CROP)
do fp = 1,num_pcropp
p = filter_pcropp(fp)
if (kmo == 1 .and. kda == 1 .and. kyr-iyear0 == 0) then ! YR 1:
gdd020(p) = 0._r8 ! set gdd..20 variables to 0
gdd820(p) = 0._r8 ! and crops will not be planted
gdd1020(p) = 0._r8
end if
if (kmo == 1 .and. kda == 1 .and. mcsec == 0) then ! <-- END of EVERY YR:
if (kyr-iyear0 == 1) then ! <-- END of YR 1
gdd020(p) = gdd0(p) ! <-- END of YR 1
gdd820(p) = gdd8(p) ! <-- END of YR 1
gdd1020(p) = gdd10(p) ! <-- END of YR 1
end if ! <-- END of YR 1
gdd020(p) = (19._r8 * gdd020(p) + gdd0(p)) / 20._r8 ! gdd..20 must be long term avgs
gdd820(p) = (19._r8 * gdd820(p) + gdd8(p)) / 20._r8 ! so ignore results for yrs 1 & 2
gdd1020(p) = (19._r8 * gdd1020(p) + gdd10(p)) / 20._r8
end if
end do
#endif
end subroutine CNPhenologyClimate
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNEvergreenPhenology
!
! !INTERFACE:
subroutine CNEvergreenPhenology (num_soilp, filter_soilp) 1
!
! !DESCRIPTION:
! For coupled carbon-nitrogen code (CN).
!
! !USES:
!
! !ARGUMENTS:
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 10/2/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
integer , pointer :: ivt(:) ! pft vegetation type
! ecophysiological constants
real(r8), pointer :: evergreen(:) ! binary flag for evergreen leaf habit (0 or 1)
real(r8), pointer :: leaf_long(:) ! leaf longevity (yrs)
!
! local pointers to implicit in/out scalars
!
real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s)
real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s)
real(r8), pointer :: lgsf(:) ! long growing season factor [0-1]
!
! local pointers to implicit out scalars
!
! !OTHER LOCAL VARIABLES:
integer :: p ! indices
integer :: fp ! lake filter pft index
!EOP
!-----------------------------------------------------------------------
! assign local pointers to derived type arrays
ivt => clm3%g%l%c%p%itype
evergreen => pftcon%evergreen
leaf_long => pftcon%leaf_long
bglfr => clm3%g%l%c%p%pepv%bglfr
bgtr => clm3%g%l%c%p%pepv%bgtr
lgsf => clm3%g%l%c%p%pepv%lgsf
do fp = 1,num_soilp
p = filter_soilp(fp)
if (evergreen(ivt(p)) == 1._r8) then
bglfr(p) = 1._r8/(leaf_long(ivt(p))*365._r8*86400._r8)
bgtr(p) = 0._r8
lgsf(p) = 0._r8
end if
end do
end subroutine CNEvergreenPhenology
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNSeasonDecidPhenology
!
! !INTERFACE:
subroutine CNSeasonDecidPhenology (num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! For coupled carbon-nitrogen code (CN).
! This routine handles the seasonal deciduous phenology code (temperate
! deciduous vegetation that has only one growing season per year).
!
! !USES:
!ylu removed
! use clm_time_manager, only: get_step_size
use globals, only : dt
use shr_const_mod, only: SHR_CONST_TKFRZ, SHR_CONST_PI
!
! !ARGUMENTS:
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 10/6/03: Created by Peter Thornton
! 10/24/03, Peter Thornton: migrated to vector data structures
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
integer , pointer :: ivt(:) ! pft vegetation type
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: pgridcell(:) ! pft's gridcell index
real(r8), pointer :: latdeg(:) ! latitude (radians)
real(r8), pointer :: decl(:) ! solar declination (radians)
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa)
real(r8), pointer :: leafc_storage(:) ! (kgC/m2) leaf C storage
real(r8), pointer :: frootc_storage(:) ! (kgC/m2) fine root C storage
real(r8), pointer :: livestemc_storage(:) ! (kgC/m2) live stem C storage
real(r8), pointer :: deadstemc_storage(:) ! (kgC/m2) dead stem C storage
real(r8), pointer :: livecrootc_storage(:) ! (kgC/m2) live coarse root C storage
real(r8), pointer :: deadcrootc_storage(:) ! (kgC/m2) dead coarse root C storage
real(r8), pointer :: gresp_storage(:) ! (kgC/m2) growth respiration storage
real(r8), pointer :: leafn_storage(:) ! (kgN/m2) leaf N storage
real(r8), pointer :: frootn_storage(:) ! (kgN/m2) fine root N storage
real(r8), pointer :: livestemn_storage(:) ! (kgN/m2) live stem N storage
real(r8), pointer :: deadstemn_storage(:) ! (kgN/m2) dead stem N storage
real(r8), pointer :: livecrootn_storage(:) ! (kgN/m2) live coarse root N storage
real(r8), pointer :: deadcrootn_storage(:) ! (kgN/m2) dead coarse root N storage
! ecophysiological constants
real(r8), pointer :: season_decid(:) ! binary flag for seasonal-deciduous leaf habit (0 or 1)
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
!
! local pointers to implicit in/out scalars
real(r8), pointer :: dormant_flag(:) ! dormancy flag
real(r8), pointer :: days_active(:) ! number of days since last dormancy
real(r8), pointer :: onset_flag(:) ! onset flag
real(r8), pointer :: onset_counter(:) ! onset counter (seconds)
real(r8), pointer :: onset_gddflag(:) ! onset freeze flag
real(r8), pointer :: onset_gdd(:) ! onset growing degree days
real(r8), pointer :: offset_flag(:) ! offset flag
real(r8), pointer :: offset_counter(:) ! offset counter (seconds)
real(r8), pointer :: dayl(:) ! daylength (seconds)
real(r8), pointer :: prev_dayl(:) ! daylength from previous albedo timestep (seconds)
real(r8), pointer :: annavg_t2m(:) ! annual average 2m air temperature (K)
real(r8), pointer :: prev_leafc_to_litter(:) ! previous timestep leaf C litterfall flux (gC/m2/s)
real(r8), pointer :: prev_frootc_to_litter(:) ! previous timestep froot C litterfall flux (gC/m2/s)
real(r8), pointer :: lgsf(:) ! long growing season factor [0-1]
real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s)
real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s)
real(r8), pointer :: leafc_xfer_to_leafc(:)
real(r8), pointer :: frootc_xfer_to_frootc(:)
real(r8), pointer :: livestemc_xfer_to_livestemc(:)
real(r8), pointer :: deadstemc_xfer_to_deadstemc(:)
real(r8), pointer :: livecrootc_xfer_to_livecrootc(:)
real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:)
real(r8), pointer :: leafn_xfer_to_leafn(:)
real(r8), pointer :: frootn_xfer_to_frootn(:)
real(r8), pointer :: livestemn_xfer_to_livestemn(:)
real(r8), pointer :: deadstemn_xfer_to_deadstemn(:)
real(r8), pointer :: livecrootn_xfer_to_livecrootn(:)
real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:)
real(r8), pointer :: leafc_xfer(:) ! (kgC/m2) leaf C transfer
real(r8), pointer :: frootc_xfer(:) ! (kgC/m2) fine root C transfer
real(r8), pointer :: livestemc_xfer(:) ! (kgC/m2) live stem C transfer
real(r8), pointer :: deadstemc_xfer(:) ! (kgC/m2) dead stem C transfer
real(r8), pointer :: livecrootc_xfer(:) ! (kgC/m2) live coarse root C transfer
real(r8), pointer :: deadcrootc_xfer(:) ! (kgC/m2) dead coarse root C transfer
real(r8), pointer :: leafn_xfer(:) ! (kgN/m2) leaf N transfer
real(r8), pointer :: frootn_xfer(:) ! (kgN/m2) fine root N transfer
real(r8), pointer :: livestemn_xfer(:) ! (kgN/m2) live stem N transfer
real(r8), pointer :: deadstemn_xfer(:) ! (kgN/m2) dead stem N transfer
real(r8), pointer :: livecrootn_xfer(:) ! (kgN/m2) live coarse root N transfer
real(r8), pointer :: deadcrootn_xfer(:) ! (kgN/m2) dead coarse root N transfer
real(r8), pointer :: leafc_storage_to_xfer(:)
real(r8), pointer :: frootc_storage_to_xfer(:)
real(r8), pointer :: livestemc_storage_to_xfer(:)
real(r8), pointer :: deadstemc_storage_to_xfer(:)
real(r8), pointer :: livecrootc_storage_to_xfer(:)
real(r8), pointer :: deadcrootc_storage_to_xfer(:)
real(r8), pointer :: gresp_storage_to_xfer(:)
real(r8), pointer :: leafn_storage_to_xfer(:)
real(r8), pointer :: frootn_storage_to_xfer(:)
real(r8), pointer :: livestemn_storage_to_xfer(:)
real(r8), pointer :: deadstemn_storage_to_xfer(:)
real(r8), pointer :: livecrootn_storage_to_xfer(:)
real(r8), pointer :: deadcrootn_storage_to_xfer(:)
#if (defined CNDV)
logical , pointer :: pftmayexist(:) ! exclude seasonal decid pfts from tropics
#endif
!
! local pointers to implicit out scalars
!
! !OTHER LOCAL VARIABLES:
integer :: c,p !indices
integer :: fp !lake filter pft index
! real(r8):: dt !radiation time step delta t (seconds)
real(r8):: fracday !dtime as a fraction of day
real(r8):: crit_dayl !critical daylength for offset (seconds)
real(r8):: ws_flag !winter-summer solstice flag (0 or 1)
real(r8):: crit_onset_gdd !critical onset growing degree-day sum
real(r8):: ndays_on !number of days to complete onset
real(r8):: ndays_off !number of days to complete offset
real(r8):: soilt
real(r8):: lat !latitude (radians)
real(r8):: temp !temporary variable for daylength calculation
real(r8):: fstor2tran !fraction of storage to move to transfer on each onset
!EOP
!-----------------------------------------------------------------------
! Assign local pointers to derived type arrays (in)
ivt => clm3%g%l%c%p%itype
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
latdeg => clm3%g%latdeg
decl => clm3%g%l%c%cps%decl
t_soisno => clm3%g%l%c%ces%t_soisno
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
season_decid => pftcon%season_decid
woody => pftcon%woody
! Assign local pointers to derived type arrays (out)
dormant_flag => clm3%g%l%c%p%pepv%dormant_flag
days_active => clm3%g%l%c%p%pepv%days_active
onset_flag => clm3%g%l%c%p%pepv%onset_flag
onset_counter => clm3%g%l%c%p%pepv%onset_counter
onset_gddflag => clm3%g%l%c%p%pepv%onset_gddflag
onset_gdd => clm3%g%l%c%p%pepv%onset_gdd
offset_flag => clm3%g%l%c%p%pepv%offset_flag
offset_counter => clm3%g%l%c%p%pepv%offset_counter
dayl => clm3%g%l%c%p%pepv%dayl
prev_dayl => clm3%g%l%c%p%pepv%prev_dayl
annavg_t2m => clm3%g%l%c%p%pepv%annavg_t2m
prev_leafc_to_litter => clm3%g%l%c%p%pepv%prev_leafc_to_litter
prev_frootc_to_litter => clm3%g%l%c%p%pepv%prev_frootc_to_litter
bglfr => clm3%g%l%c%p%pepv%bglfr
bgtr => clm3%g%l%c%p%pepv%bgtr
lgsf => clm3%g%l%c%p%pepv%lgsf
leafc_xfer_to_leafc => clm3%g%l%c%p%pcf%leafc_xfer_to_leafc
frootc_xfer_to_frootc => clm3%g%l%c%p%pcf%frootc_xfer_to_frootc
livestemc_xfer_to_livestemc => clm3%g%l%c%p%pcf%livestemc_xfer_to_livestemc
deadstemc_xfer_to_deadstemc => clm3%g%l%c%p%pcf%deadstemc_xfer_to_deadstemc
livecrootc_xfer_to_livecrootc => clm3%g%l%c%p%pcf%livecrootc_xfer_to_livecrootc
deadcrootc_xfer_to_deadcrootc => clm3%g%l%c%p%pcf%deadcrootc_xfer_to_deadcrootc
leafn_xfer_to_leafn => clm3%g%l%c%p%pnf%leafn_xfer_to_leafn
frootn_xfer_to_frootn => clm3%g%l%c%p%pnf%frootn_xfer_to_frootn
livestemn_xfer_to_livestemn => clm3%g%l%c%p%pnf%livestemn_xfer_to_livestemn
deadstemn_xfer_to_deadstemn => clm3%g%l%c%p%pnf%deadstemn_xfer_to_deadstemn
livecrootn_xfer_to_livecrootn => clm3%g%l%c%p%pnf%livecrootn_xfer_to_livecrootn
deadcrootn_xfer_to_deadcrootn => clm3%g%l%c%p%pnf%deadcrootn_xfer_to_deadcrootn
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
leafc_storage_to_xfer => clm3%g%l%c%p%pcf%leafc_storage_to_xfer
frootc_storage_to_xfer => clm3%g%l%c%p%pcf%frootc_storage_to_xfer
livestemc_storage_to_xfer => clm3%g%l%c%p%pcf%livestemc_storage_to_xfer
deadstemc_storage_to_xfer => clm3%g%l%c%p%pcf%deadstemc_storage_to_xfer
livecrootc_storage_to_xfer => clm3%g%l%c%p%pcf%livecrootc_storage_to_xfer
deadcrootc_storage_to_xfer => clm3%g%l%c%p%pcf%deadcrootc_storage_to_xfer
gresp_storage_to_xfer => clm3%g%l%c%p%pcf%gresp_storage_to_xfer
leafn_storage_to_xfer => clm3%g%l%c%p%pnf%leafn_storage_to_xfer
frootn_storage_to_xfer => clm3%g%l%c%p%pnf%frootn_storage_to_xfer
livestemn_storage_to_xfer => clm3%g%l%c%p%pnf%livestemn_storage_to_xfer
deadstemn_storage_to_xfer => clm3%g%l%c%p%pnf%deadstemn_storage_to_xfer
livecrootn_storage_to_xfer => clm3%g%l%c%p%pnf%livecrootn_storage_to_xfer
deadcrootn_storage_to_xfer => clm3%g%l%c%p%pnf%deadcrootn_storage_to_xfer
#if (defined CNDV)
pftmayexist => clm3%g%l%c%p%pdgvs%pftmayexist
#endif
! set time steps
! dt = real( get_step_size(), r8 )
fracday = dt/86400.0_r8
! critical daylength from Biome-BGC, v4.1.2
crit_dayl = 39300._r8
ndays_on = 30._r8
ndays_off = 15._r8
! transfer parameters
fstor2tran = 0.5_r8
! start pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
c = pcolumn(p)
if (season_decid(ivt(p)) == 1._r8) then
! set background litterfall rate, background transfer rate, and
! long growing season factor to 0 for seasonal deciduous types
bglfr(p) = 0._r8
bgtr(p) = 0._r8
lgsf(p) = 0._r8
! onset gdd sum from Biome-BGC, v4.1.2
crit_onset_gdd = exp(4.8_r8 + 0.13_r8*(annavg_t2m(p) - SHR_CONST_TKFRZ))
! use solar declination information stored during Surface Albedo()
! and latitude from gps to calcluate daylength (convert latitude from degrees to radians)
! the constant 13750.9871 is the number of seconds per radian of hour-angle
prev_dayl(p) = dayl(p)
lat = (SHR_CONST_PI/180._r8)*latdeg(pgridcell(p))
temp = -(sin(lat)*sin(decl(c)))/(cos(lat) * cos(decl(c)))
temp = min(1._r8,max(-1._r8,temp))
dayl(p) = 2.0_r8 * 13750.9871_r8 * acos(temp)
! set flag for solstice period (winter->summer = 1, summer->winter = 0)
if (dayl(p) >= prev_dayl(p)) then
ws_flag = 1._r8
else
ws_flag = 0._r8
end if
! update offset_counter and test for the end of the offset period
if (offset_flag(p) == 1.0_r8) then
! decrement counter for offset period
offset_counter(p) = offset_counter(p) - dt
! if this is the end of the offset_period, reset phenology
! flags and indices
if (offset_counter(p) == 0.0_r8) then
! this code block was originally handled by call cn_offset_cleanup(p)
! inlined during vectorization
offset_flag(p) = 0._r8
offset_counter(p) = 0._r8
dormant_flag(p) = 1._r8
days_active(p) = 0._r8
#if (defined CNDV)
pftmayexist(p) = .true.
#endif
! reset the previous timestep litterfall flux memory
prev_leafc_to_litter(p) = 0._r8
prev_frootc_to_litter(p) = 0._r8
end if
end if
! update onset_counter and test for the end of the onset period
if (onset_flag(p) == 1.0_r8) then
! decrement counter for onset period
onset_counter(p) = onset_counter(p) - dt
! if this is the end of the onset period, reset phenology
! flags and indices
if (onset_counter(p) == 0.0_r8) then
! this code block was originally handled by call cn_onset_cleanup(p)
! inlined during vectorization
onset_flag(p) = 0.0_r8
onset_counter(p) = 0.0_r8
! set all transfer growth rates to 0.0
leafc_xfer_to_leafc(p) = 0.0_r8
frootc_xfer_to_frootc(p) = 0.0_r8
leafn_xfer_to_leafn(p) = 0.0_r8
frootn_xfer_to_frootn(p) = 0.0_r8
if (woody(ivt(p)) == 1.0_r8) then
livestemc_xfer_to_livestemc(p) = 0.0_r8
deadstemc_xfer_to_deadstemc(p) = 0.0_r8
livecrootc_xfer_to_livecrootc(p) = 0.0_r8
deadcrootc_xfer_to_deadcrootc(p) = 0.0_r8
livestemn_xfer_to_livestemn(p) = 0.0_r8
deadstemn_xfer_to_deadstemn(p) = 0.0_r8
livecrootn_xfer_to_livecrootn(p) = 0.0_r8
deadcrootn_xfer_to_deadcrootn(p) = 0.0_r8
end if
! set transfer pools to 0.0
leafc_xfer(p) = 0.0_r8
leafn_xfer(p) = 0.0_r8
frootc_xfer(p) = 0.0_r8
frootn_xfer(p) = 0.0_r8
if (woody(ivt(p)) == 1.0_r8) then
livestemc_xfer(p) = 0.0_r8
livestemn_xfer(p) = 0.0_r8
deadstemc_xfer(p) = 0.0_r8
deadstemn_xfer(p) = 0.0_r8
livecrootc_xfer(p) = 0.0_r8
livecrootn_xfer(p) = 0.0_r8
deadcrootc_xfer(p) = 0.0_r8
deadcrootn_xfer(p) = 0.0_r8
end if
end if
end if
! test for switching from dormant period to growth period
if (dormant_flag(p) == 1.0_r8) then
! Test to turn on growing degree-day sum, if off.
! switch on the growing degree day sum on the winter solstice
if (onset_gddflag(p) == 0._r8 .and. ws_flag == 1._r8) then
onset_gddflag(p) = 1._r8
onset_gdd(p) = 0._r8
end if
! Test to turn off growing degree-day sum, if on.
! This test resets the growing degree day sum if it gets past
! the summer solstice without reaching the threshold value.
! In that case, it will take until the next winter solstice
! before the growing degree-day summation starts again.
if (onset_gddflag(p) == 1._r8 .and. ws_flag == 0._r8) then
onset_gddflag(p) = 0._r8
onset_gdd(p) = 0._r8
end if
! if the gdd flag is set, and if the soil is above freezing
! then accumulate growing degree days for onset trigger
soilt = t_soisno(c,3)
if (onset_gddflag(p) == 1.0_r8 .and. soilt > SHR_CONST_TKFRZ) then
onset_gdd(p) = onset_gdd(p) + (soilt-SHR_CONST_TKFRZ)*fracday
end if
! set onset_flag if critical growing degree-day sum is exceeded
if (onset_gdd(p) > crit_onset_gdd) then
onset_flag(p) = 1.0_r8
dormant_flag(p) = 0.0_r8
onset_gddflag(p) = 0.0_r8
onset_gdd(p) = 0.0_r8
onset_counter(p) = ndays_on * 86400.0_r8
! move all the storage pools into transfer pools,
! where they will be transfered to displayed growth over the onset period.
! this code was originally handled with call cn_storage_to_xfer(p)
! inlined during vectorization
! set carbon fluxes for shifting storage pools to transfer pools
leafc_storage_to_xfer(p) = fstor2tran * leafc_storage(p)/dt
frootc_storage_to_xfer(p) = fstor2tran * frootc_storage(p)/dt
if (woody(ivt(p)) == 1.0_r8) then
livestemc_storage_to_xfer(p) = fstor2tran * livestemc_storage(p)/dt
deadstemc_storage_to_xfer(p) = fstor2tran * deadstemc_storage(p)/dt
livecrootc_storage_to_xfer(p) = fstor2tran * livecrootc_storage(p)/dt
deadcrootc_storage_to_xfer(p) = fstor2tran * deadcrootc_storage(p)/dt
gresp_storage_to_xfer(p) = fstor2tran * gresp_storage(p)/dt
end if
! set nitrogen fluxes for shifting storage pools to transfer pools
leafn_storage_to_xfer(p) = fstor2tran * leafn_storage(p)/dt
frootn_storage_to_xfer(p) = fstor2tran * frootn_storage(p)/dt
if (woody(ivt(p)) == 1.0_r8) then
livestemn_storage_to_xfer(p) = fstor2tran * livestemn_storage(p)/dt
deadstemn_storage_to_xfer(p) = fstor2tran * deadstemn_storage(p)/dt
livecrootn_storage_to_xfer(p) = fstor2tran * livecrootn_storage(p)/dt
deadcrootn_storage_to_xfer(p) = fstor2tran * deadcrootn_storage(p)/dt
end if
end if
! test for switching from growth period to offset period
else if (offset_flag(p) == 0.0_r8) then
#if (defined CNDV)
! If days_active > 355, then remove pft in
! CNDVEstablishment at the end of the year.
! days_active > 355 is a symptom of seasonal decid. pfts occurring in
! gridcells where dayl never drops below crit_dayl.
! This results in TLAI>1e4 in a few gridcells.
days_active(p) = days_active(p) + fracday
if (days_active(p) > 355._r8) pftmayexist(p) = .false.
#endif
! only begin to test for offset daylength once past the summer sol
if (ws_flag == 0._r8 .and. dayl(p) < crit_dayl) then
offset_flag(p) = 1._r8
offset_counter(p) = ndays_off * 86400.0_r8
prev_leafc_to_litter(p) = 0._r8
prev_frootc_to_litter(p) = 0._r8
end if
end if
end if ! end if seasonal deciduous
end do ! end of pft loop
end subroutine CNSeasonDecidPhenology
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNStressDecidPhenology
!
! !INTERFACE:
subroutine CNStressDecidPhenology (num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! This routine handles phenology for vegetation types, such as grasses and
! tropical drought deciduous trees, that respond to cold and drought stress
! signals and that can have multiple growing seasons in a given year.
! This routine allows for the possibility that leaves might persist year-round
! in the absence of a suitable stress trigger, by switching to an essentially
! evergreen habit, but maintaining a deciduous leaf longevity, while waiting
! for the next stress trigger. This is in contrast to the seasonal deciduous
! algorithm (for temperate deciduous trees) that forces a single growing season
! per year.
!
! !USES:
! use clm_time_manager, only: get_step_size
use globals, only : dt
use shr_const_mod, only: SHR_CONST_TKFRZ, SHR_CONST_PI
!
! !ARGUMENTS:
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 10/27/03: Created by Peter Thornton
! 01/29/04: Made onset_gdd critical sum a function of temperature, as in
! seasonal deciduous algorithm.
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
integer , pointer :: ivt(:) ! pft vegetation type
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: pgridcell(:) ! pft's gridcell index
real(r8), pointer :: latdeg(:) ! latitude (degree)
real(r8), pointer :: decl(:) ! solar declination (radians)
real(r8), pointer :: leafc_storage(:) ! (kgC/m2) leaf C storage
real(r8), pointer :: frootc_storage(:) ! (kgC/m2) fine root C storage
real(r8), pointer :: livestemc_storage(:) ! (kgC/m2) live stem C storage
real(r8), pointer :: deadstemc_storage(:) ! (kgC/m2) dead stem C storage
real(r8), pointer :: livecrootc_storage(:) ! (kgC/m2) live coarse root C storage
real(r8), pointer :: deadcrootc_storage(:) ! (kgC/m2) dead coarse root C storage
real(r8), pointer :: gresp_storage(:) ! (kgC/m2) growth respiration storage
real(r8), pointer :: leafn_storage(:) ! (kgN/m2) leaf N storage
real(r8), pointer :: frootn_storage(:) ! (kgN/m2) fine root N storage
real(r8), pointer :: livestemn_storage(:) ! (kgN/m2) live stem N storage
real(r8), pointer :: deadstemn_storage(:) ! (kgN/m2) dead stem N storage
real(r8), pointer :: livecrootn_storage(:) ! (kgN/m2) live coarse root N storage
real(r8), pointer :: deadcrootn_storage(:) ! (kgN/m2) dead coarse root N storage
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevgrnd)
real(r8), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa)
real(r8), pointer :: leaf_long(:) ! leaf longevity (yrs)
real(r8), pointer :: stress_decid(:) ! binary flag for stress-deciduous leaf habit (0 or 1)
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
!
! local pointers to implicit in/out scalars
!
real(r8), pointer :: dormant_flag(:) ! dormancy flag
real(r8), pointer :: days_active(:) ! number of days since last dormancy
real(r8), pointer :: onset_flag(:) ! onset flag
real(r8), pointer :: onset_counter(:) ! onset counter (seconds)
real(r8), pointer :: onset_gddflag(:) ! onset flag for growing degree day sum
real(r8), pointer :: onset_fdd(:) ! onset freezing degree days counter
real(r8), pointer :: onset_gdd(:) ! onset growing degree days
real(r8), pointer :: onset_swi(:) ! onset soil water index
real(r8), pointer :: offset_flag(:) ! offset flag
real(r8), pointer :: offset_counter(:) ! offset counter (seconds)
real(r8), pointer :: dayl(:) ! daylength (seconds)
real(r8), pointer :: offset_fdd(:) ! offset freezing degree days counter
real(r8), pointer :: offset_swi(:) ! offset soil water index
real(r8), pointer :: annavg_t2m(:) ! annual average 2m air temperature (K)
real(r8), pointer :: lgsf(:) ! long growing season factor [0-1]
real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s)
real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s)
real(r8), pointer :: prev_leafc_to_litter(:) ! previous timestep leaf C litterfall flux (gC/m2/s)
real(r8), pointer :: prev_frootc_to_litter(:) ! previous timestep froot C litterfall flux (gC/m2/s)
real(r8), pointer :: leafc_xfer_to_leafc(:)
real(r8), pointer :: frootc_xfer_to_frootc(:)
real(r8), pointer :: livestemc_xfer_to_livestemc(:)
real(r8), pointer :: deadstemc_xfer_to_deadstemc(:)
real(r8), pointer :: livecrootc_xfer_to_livecrootc(:)
real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:)
real(r8), pointer :: leafn_xfer_to_leafn(:)
real(r8), pointer :: frootn_xfer_to_frootn(:)
real(r8), pointer :: livestemn_xfer_to_livestemn(:)
real(r8), pointer :: deadstemn_xfer_to_deadstemn(:)
real(r8), pointer :: livecrootn_xfer_to_livecrootn(:)
real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:)
real(r8), pointer :: leafc_xfer(:) ! (kgC/m2) leaf C transfer
real(r8), pointer :: frootc_xfer(:) ! (kgC/m2) fine root C transfer
real(r8), pointer :: livestemc_xfer(:) ! (kgC/m2) live stem C transfer
real(r8), pointer :: deadstemc_xfer(:) ! (kgC/m2) dead stem C transfer
real(r8), pointer :: livecrootc_xfer(:) ! (kgC/m2) live coarse root C transfer
real(r8), pointer :: deadcrootc_xfer(:) ! (kgC/m2) dead coarse root C transfer
real(r8), pointer :: leafn_xfer(:) ! (kgN/m2) leaf N transfer
real(r8), pointer :: frootn_xfer(:) ! (kgN/m2) fine root N transfer
real(r8), pointer :: livestemn_xfer(:) ! (kgN/m2) live stem N transfer
real(r8), pointer :: deadstemn_xfer(:) ! (kgN/m2) dead stem N transfer
real(r8), pointer :: livecrootn_xfer(:) ! (kgN/m2) live coarse root N transfer
real(r8), pointer :: deadcrootn_xfer(:) ! (kgN/m2) dead coarse root N transfer
real(r8), pointer :: leafc_storage_to_xfer(:)
real(r8), pointer :: frootc_storage_to_xfer(:)
real(r8), pointer :: livestemc_storage_to_xfer(:)
real(r8), pointer :: deadstemc_storage_to_xfer(:)
real(r8), pointer :: livecrootc_storage_to_xfer(:)
real(r8), pointer :: deadcrootc_storage_to_xfer(:)
real(r8), pointer :: gresp_storage_to_xfer(:)
real(r8), pointer :: leafn_storage_to_xfer(:)
real(r8), pointer :: frootn_storage_to_xfer(:)
real(r8), pointer :: livestemn_storage_to_xfer(:)
real(r8), pointer :: deadstemn_storage_to_xfer(:)
real(r8), pointer :: livecrootn_storage_to_xfer(:)
real(r8), pointer :: deadcrootn_storage_to_xfer(:)
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp ! lake filter pft index
real(r8):: fracday ! dtime as a fraction of day
! real(r8):: dt ! radiation time step delta t (seconds)
real(r8):: crit_onset_fdd ! critical number of freezing days
real(r8):: crit_onset_gdd ! degree days for onset trigger
real(r8):: crit_offset_fdd ! critical number of freezing degree days
! to trigger offset
real(r8):: crit_onset_swi ! water stress days for offset trigger
real(r8):: crit_offset_swi ! water stress days for offset trigger
real(r8):: soilpsi_on ! water potential for onset trigger (MPa)
real(r8):: soilpsi_off ! water potential for offset trigger (MPa)
real(r8):: ndays_on ! number of days to complete onset
real(r8):: ndays_off ! number of days to complete offset
real(r8):: soilt ! temperature of top soil layer
real(r8):: psi ! water stress of top soil layer
real(r8):: lat !latitude (radians)
real(r8):: temp !temporary variable for daylength calculation
real(r8):: fstor2tran ! fraction of storage to move to transfer
! on each onset
!EOP
!-----------------------------------------------------------------------
! Assign local pointers to derived type arrays (in)
ivt => clm3%g%l%c%p%itype
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
latdeg => clm3%g%latdeg
decl => clm3%g%l%c%cps%decl
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
soilpsi => clm3%g%l%c%cps%soilpsi
t_soisno => clm3%g%l%c%ces%t_soisno
leaf_long => pftcon%leaf_long
woody => pftcon%woody
stress_decid => pftcon%stress_decid
! Assign local pointers to derived type arrays (out)
dormant_flag => clm3%g%l%c%p%pepv%dormant_flag
days_active => clm3%g%l%c%p%pepv%days_active
onset_flag => clm3%g%l%c%p%pepv%onset_flag
onset_counter => clm3%g%l%c%p%pepv%onset_counter
onset_gddflag => clm3%g%l%c%p%pepv%onset_gddflag
onset_fdd => clm3%g%l%c%p%pepv%onset_fdd
onset_gdd => clm3%g%l%c%p%pepv%onset_gdd
onset_swi => clm3%g%l%c%p%pepv%onset_swi
offset_flag => clm3%g%l%c%p%pepv%offset_flag
offset_counter => clm3%g%l%c%p%pepv%offset_counter
dayl => clm3%g%l%c%p%pepv%dayl
offset_fdd => clm3%g%l%c%p%pepv%offset_fdd
offset_swi => clm3%g%l%c%p%pepv%offset_swi
annavg_t2m => clm3%g%l%c%p%pepv%annavg_t2m
prev_leafc_to_litter => clm3%g%l%c%p%pepv%prev_leafc_to_litter
prev_frootc_to_litter => clm3%g%l%c%p%pepv%prev_frootc_to_litter
lgsf => clm3%g%l%c%p%pepv%lgsf
bglfr => clm3%g%l%c%p%pepv%bglfr
bgtr => clm3%g%l%c%p%pepv%bgtr
leafc_xfer_to_leafc => clm3%g%l%c%p%pcf%leafc_xfer_to_leafc
frootc_xfer_to_frootc => clm3%g%l%c%p%pcf%frootc_xfer_to_frootc
livestemc_xfer_to_livestemc => clm3%g%l%c%p%pcf%livestemc_xfer_to_livestemc
deadstemc_xfer_to_deadstemc => clm3%g%l%c%p%pcf%deadstemc_xfer_to_deadstemc
livecrootc_xfer_to_livecrootc => clm3%g%l%c%p%pcf%livecrootc_xfer_to_livecrootc
deadcrootc_xfer_to_deadcrootc => clm3%g%l%c%p%pcf%deadcrootc_xfer_to_deadcrootc
leafn_xfer_to_leafn => clm3%g%l%c%p%pnf%leafn_xfer_to_leafn
frootn_xfer_to_frootn => clm3%g%l%c%p%pnf%frootn_xfer_to_frootn
livestemn_xfer_to_livestemn => clm3%g%l%c%p%pnf%livestemn_xfer_to_livestemn
deadstemn_xfer_to_deadstemn => clm3%g%l%c%p%pnf%deadstemn_xfer_to_deadstemn
livecrootn_xfer_to_livecrootn => clm3%g%l%c%p%pnf%livecrootn_xfer_to_livecrootn
deadcrootn_xfer_to_deadcrootn => clm3%g%l%c%p%pnf%deadcrootn_xfer_to_deadcrootn
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
leafc_storage_to_xfer => clm3%g%l%c%p%pcf%leafc_storage_to_xfer
frootc_storage_to_xfer => clm3%g%l%c%p%pcf%frootc_storage_to_xfer
livestemc_storage_to_xfer => clm3%g%l%c%p%pcf%livestemc_storage_to_xfer
deadstemc_storage_to_xfer => clm3%g%l%c%p%pcf%deadstemc_storage_to_xfer
livecrootc_storage_to_xfer => clm3%g%l%c%p%pcf%livecrootc_storage_to_xfer
deadcrootc_storage_to_xfer => clm3%g%l%c%p%pcf%deadcrootc_storage_to_xfer
gresp_storage_to_xfer => clm3%g%l%c%p%pcf%gresp_storage_to_xfer
leafn_storage_to_xfer => clm3%g%l%c%p%pnf%leafn_storage_to_xfer
frootn_storage_to_xfer => clm3%g%l%c%p%pnf%frootn_storage_to_xfer
livestemn_storage_to_xfer => clm3%g%l%c%p%pnf%livestemn_storage_to_xfer
deadstemn_storage_to_xfer => clm3%g%l%c%p%pnf%deadstemn_storage_to_xfer
livecrootn_storage_to_xfer => clm3%g%l%c%p%pnf%livecrootn_storage_to_xfer
deadcrootn_storage_to_xfer => clm3%g%l%c%p%pnf%deadcrootn_storage_to_xfer
! set time steps
! dt = real( get_step_size(), r8 )
fracday = dt/86400.0_r8
! set some local parameters - these will be moved into
! parameter file after testing
! onset parameters
crit_onset_fdd = 15.0_r8
! critical onset gdd now being calculated as a function of annual
! average 2m temp.
! crit_onset_gdd = 150.0 ! c3 grass value
! crit_onset_gdd = 1000.0 ! c4 grass value
crit_onset_swi = 15.0_r8
soilpsi_on = -2.0_r8
ndays_on = 30.0_r8
! offset parameters
crit_offset_fdd = 15.0_r8
crit_offset_swi = 15.0_r8
soilpsi_off = -2.0_r8
ndays_off = 15.0_r8
! transfer parameters
fstor2tran = 0.5_r8
do fp = 1,num_soilp
p = filter_soilp(fp)
c = pcolumn(p)
if (stress_decid(ivt(p)) == 1._r8) then
soilt = t_soisno(c,3)
psi = soilpsi(c,3)
! use solar declination information stored during Surface Albedo()
! and latitude from gps to calcluate daylength (convert latitude from degrees to radians)
! the constant 13750.9871 is the number of seconds per radian of hour-angle
lat = (SHR_CONST_PI/180._r8)*latdeg(pgridcell(p))
temp = -(sin(lat)*sin(decl(c)))/(cos(lat) * cos(decl(c)))
temp = min(1._r8,max(-1._r8,temp))
dayl(p) = 2.0_r8 * 13750.9871_r8 * acos(temp)
! onset gdd sum from Biome-BGC, v4.1.2
crit_onset_gdd = exp(4.8_r8 + 0.13_r8*(annavg_t2m(p) - SHR_CONST_TKFRZ))
! update offset_counter and test for the end of the offset period
if (offset_flag(p) == 1._r8) then
! decrement counter for offset period
offset_counter(p) = offset_counter(p) - dt
! if this is the end of the offset_period, reset phenology
! flags and indices
if (offset_counter(p) == 0._r8) then
! this code block was originally handled by call cn_offset_cleanup(p)
! inlined during vectorization
offset_flag(p) = 0._r8
offset_counter(p) = 0._r8
dormant_flag(p) = 1._r8
days_active(p) = 0._r8
! reset the previous timestep litterfall flux memory
prev_leafc_to_litter(p) = 0._r8
prev_frootc_to_litter(p) = 0._r8
end if
end if
! update onset_counter and test for the end of the onset period
if (onset_flag(p) == 1.0_r8) then
! decrement counter for onset period
onset_counter(p) = onset_counter(p) - dt
! if this is the end of the onset period, reset phenology
! flags and indices
if (onset_counter(p) == 0.0_r8) then
! this code block was originally handled by call cn_onset_cleanup(p)
! inlined during vectorization
onset_flag(p) = 0._r8
onset_counter(p) = 0._r8
! set all transfer growth rates to 0.0
leafc_xfer_to_leafc(p) = 0._r8
frootc_xfer_to_frootc(p) = 0._r8
leafn_xfer_to_leafn(p) = 0._r8
frootn_xfer_to_frootn(p) = 0._r8
if (woody(ivt(p)) == 1.0_r8) then
livestemc_xfer_to_livestemc(p) = 0._r8
deadstemc_xfer_to_deadstemc(p) = 0._r8
livecrootc_xfer_to_livecrootc(p) = 0._r8
deadcrootc_xfer_to_deadcrootc(p) = 0._r8
livestemn_xfer_to_livestemn(p) = 0._r8
deadstemn_xfer_to_deadstemn(p) = 0._r8
livecrootn_xfer_to_livecrootn(p) = 0._r8
deadcrootn_xfer_to_deadcrootn(p) = 0._r8
end if
! set transfer pools to 0.0
leafc_xfer(p) = 0._r8
leafn_xfer(p) = 0._r8
frootc_xfer(p) = 0._r8
frootn_xfer(p) = 0._r8
if (woody(ivt(p)) == 1.0_r8) then
livestemc_xfer(p) = 0._r8
livestemn_xfer(p) = 0._r8
deadstemc_xfer(p) = 0._r8
deadstemn_xfer(p) = 0._r8
livecrootc_xfer(p) = 0._r8
livecrootn_xfer(p) = 0._r8
deadcrootc_xfer(p) = 0._r8
deadcrootn_xfer(p) = 0._r8
end if
end if
end if
! test for switching from dormant period to growth period
if (dormant_flag(p) == 1._r8) then
! keep track of the number of freezing degree days in this
! dormancy period (only if the freeze flag has not previously been set
! for this dormancy period
if (onset_gddflag(p) == 0._r8 .and. soilt < SHR_CONST_TKFRZ) onset_fdd(p) = onset_fdd(p) + fracday
! if the number of freezing degree days exceeds a critical value,
! then onset will require both wet soils and a critical soil
! temperature sum. If this case is triggered, reset any previously
! accumulated value in onset_swi, so that onset now depends on
! the accumulated soil water index following the freeze trigger
if (onset_fdd(p) > crit_onset_fdd) then
onset_gddflag(p) = 1._r8
onset_fdd(p) = 0._r8
onset_swi(p) = 0._r8
end if
! if the freeze flag is set, and if the soil is above freezing
! then accumulate growing degree days for onset trigger
if (onset_gddflag(p) == 1._r8 .and. soilt > SHR_CONST_TKFRZ) then
onset_gdd(p) = onset_gdd(p) + (soilt-SHR_CONST_TKFRZ)*fracday
end if
! if soils are wet, accumulate soil water index for onset trigger
if (psi >= soilpsi_on) onset_swi(p) = onset_swi(p) + fracday
! if critical soil water index is exceeded, set onset_flag, and
! then test for soil temperature criteria
if (onset_swi(p) > crit_onset_swi) then
onset_flag(p) = 1._r8
! only check soil temperature criteria if freeze flag set since
! beginning of last dormancy. If freeze flag set and growing
! degree day sum (since freeze trigger) is lower than critical
! value, then override the onset_flag set from soil water.
if (onset_gddflag(p) == 1._r8 .and. onset_gdd(p) < crit_onset_gdd) onset_flag(p) = 0._r8
end if
! only allow onset if dayl > 6hrs
if (onset_flag(p) == 1._r8 .and. dayl(p) <= 21600._r8) then
onset_flag(p) = 0._r8
end if
! if this is the beginning of the onset period
! then reset the phenology flags and indices
if (onset_flag(p) == 1._r8) then
dormant_flag(p) = 0._r8
days_active(p) = 0._r8
onset_gddflag(p) = 0._r8
onset_fdd(p) = 0._r8
onset_gdd(p) = 0._r8
onset_swi(p) = 0._r8
onset_counter(p) = ndays_on * 86400._r8
! call subroutine to move all the storage pools into transfer pools,
! where they will be transfered to displayed growth over the onset period.
! this code was originally handled with call cn_storage_to_xfer(p)
! inlined during vectorization
! set carbon fluxes for shifting storage pools to transfer pools
leafc_storage_to_xfer(p) = fstor2tran * leafc_storage(p)/dt
frootc_storage_to_xfer(p) = fstor2tran * frootc_storage(p)/dt
if (woody(ivt(p)) == 1.0_r8) then
livestemc_storage_to_xfer(p) = fstor2tran * livestemc_storage(p)/dt
deadstemc_storage_to_xfer(p) = fstor2tran * deadstemc_storage(p)/dt
livecrootc_storage_to_xfer(p) = fstor2tran * livecrootc_storage(p)/dt
deadcrootc_storage_to_xfer(p) = fstor2tran * deadcrootc_storage(p)/dt
gresp_storage_to_xfer(p) = fstor2tran * gresp_storage(p)/dt
end if
! set nitrogen fluxes for shifting storage pools to transfer pools
leafn_storage_to_xfer(p) = fstor2tran * leafn_storage(p)/dt
frootn_storage_to_xfer(p) = fstor2tran * frootn_storage(p)/dt
if (woody(ivt(p)) == 1.0_r8) then
livestemn_storage_to_xfer(p) = fstor2tran * livestemn_storage(p)/dt
deadstemn_storage_to_xfer(p) = fstor2tran * deadstemn_storage(p)/dt
livecrootn_storage_to_xfer(p) = fstor2tran * livecrootn_storage(p)/dt
deadcrootn_storage_to_xfer(p) = fstor2tran * deadcrootn_storage(p)/dt
end if
end if
! test for switching from growth period to offset period
else if (offset_flag(p) == 0._r8) then
! if soil water potential lower than critical value, accumulate
! as stress in offset soil water index
if (psi <= soilpsi_off) then
offset_swi(p) = offset_swi(p) + fracday
! if the offset soil water index exceeds critical value, and
! if this is not the middle of a previously initiated onset period,
! then set flag to start the offset period and reset index variables
if (offset_swi(p) >= crit_offset_swi .and. onset_flag(p) == 0._r8) offset_flag(p) = 1._r8
! if soil water potential higher than critical value, reduce the
! offset water stress index. By this mechanism, there must be a
! sustained period of water stress to initiate offset.
else if (psi >= soilpsi_on) then
offset_swi(p) = offset_swi(p) - fracday
offset_swi(p) = max(offset_swi(p),0._r8)
end if
! decrease freezing day accumulator for warm soil
if (offset_fdd(p) > 0._r8 .and. soilt > SHR_CONST_TKFRZ) then
offset_fdd(p) = offset_fdd(p) - fracday
offset_fdd(p) = max(0._r8, offset_fdd(p))
end if
! increase freezing day accumulator for cold soil
if (soilt <= SHR_CONST_TKFRZ) then
offset_fdd(p) = offset_fdd(p) + fracday
! if freezing degree day sum is greater than critical value, initiate offset
if (offset_fdd(p) > crit_offset_fdd .and. onset_flag(p) == 0._r8) offset_flag(p) = 1._r8
end if
! force offset if daylength is < 6 hrs
if (dayl(p) <= 21600._r8) then
offset_flag(p) = 1._r8
end if
! if this is the beginning of the offset period
! then reset flags and indices
if (offset_flag(p) == 1._r8) then
offset_fdd(p) = 0._r8
offset_swi(p) = 0._r8
offset_counter(p) = ndays_off * 86400._r8
prev_leafc_to_litter(p) = 0._r8
prev_frootc_to_litter(p) = 0._r8
end if
end if
! keep track of number of days since last dormancy for control on
! fraction of new growth to send to storage for next growing season
if (dormant_flag(p) == 0.0_r8) then
days_active(p) = days_active(p) + fracday
end if
! calculate long growing season factor (lgsf)
! only begin to calculate a lgsf greater than 0.0 once the number
! of days active exceeds 365.
lgsf(p) = max(min((days_active(p)-365._r8)/365._r8, 1._r8),0._r8)
! set background litterfall rate, when not in the phenological offset period
if (offset_flag(p) == 1._r8) then
bglfr(p) = 0._r8
else
! calculate the background litterfall rate (bglfr)
! in units 1/s, based on leaf longevity (yrs) and correction for long growing season
bglfr(p) = (1._r8/(leaf_long(ivt(p))*365._r8*86400._r8))*lgsf(p)
end if
! set background transfer rate when active but not in the phenological onset period
if (onset_flag(p) == 1._r8) then
bgtr(p) = 0._r8
else
! the background transfer rate is calculated as the rate that would result
! in complete turnover of the storage pools in one year at steady state,
! once lgsf has reached 1.0 (after 730 days active).
bgtr(p) = (1._r8/(365._r8*86400._r8))*lgsf(p)
! set carbon fluxes for shifting storage pools to transfer pools
leafc_storage_to_xfer(p) = leafc_storage(p) * bgtr(p)
frootc_storage_to_xfer(p) = frootc_storage(p) * bgtr(p)
if (woody(ivt(p)) == 1.0_r8) then
livestemc_storage_to_xfer(p) = livestemc_storage(p) * bgtr(p)
deadstemc_storage_to_xfer(p) = deadstemc_storage(p) * bgtr(p)
livecrootc_storage_to_xfer(p) = livecrootc_storage(p) * bgtr(p)
deadcrootc_storage_to_xfer(p) = deadcrootc_storage(p) * bgtr(p)
gresp_storage_to_xfer(p) = gresp_storage(p) * bgtr(p)
end if
! set nitrogen fluxes for shifting storage pools to transfer pools
leafn_storage_to_xfer(p) = leafn_storage(p) * bgtr(p)
frootn_storage_to_xfer(p) = frootn_storage(p) * bgtr(p)
if (woody(ivt(p)) == 1.0_r8) then
livestemn_storage_to_xfer(p) = livestemn_storage(p) * bgtr(p)
deadstemn_storage_to_xfer(p) = deadstemn_storage(p) * bgtr(p)
livecrootn_storage_to_xfer(p) = livecrootn_storage(p) * bgtr(p)
deadcrootn_storage_to_xfer(p) = deadcrootn_storage(p) * bgtr(p)
end if
end if
end if ! end if stress deciduous
end do ! end of pft loop
end subroutine CNStressDecidPhenology
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
#if (defined CROP)
!BOP
!
! !IROUTINE: CropPhenology
!
! !INTERFACE:
subroutine CropPhenology(num_pcropp, filter_pcropp) 1,4
! !DESCRIPTION:
! Code from AgroIBIS to determine crop phenology and code from CN to
! handle CN fluxes during the phenological onset & offset periods.
! !USES:
! use clm_time_manager, only : get_curr_date, get_curr_calday, get_step_size
use globals, only: dt,secs,year,month,day,calday
use pftvarcon , only : ncorn, nswheat, nwwheat, nsoybean, gddmin, hybgdd, lfemerg, grnfill, mxmat
! !ARGUMENTS:
integer, intent(in) :: num_pcropp ! number of prog crop pfts in filter
integer, intent(in) :: filter_pcropp(:) ! filter for prognostic crop pfts
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 2/5/08: slevis created according to AgroIBIS subroutines of Kucharik et al.
! 7/14/08: slevis adapted crop cycles to southern hemisphere
! local variables
integer kyr ! current year
integer kmo ! month of year (1, ..., 12)
integer kda ! day of month (1, ..., 31)
integer mcsec ! seconds of day (0, ..., 86400)
integer jday ! julian day of the year
integer fp,p ! pft indices
integer c ! column indices
integer g ! gridcell indices
integer idpp ! number of days past planting
integer pmmin ! earliest month to plant winter wheat
integer pdmin ! earliest day in earliest month to plant
integer pmmax ! latest possible month (month) and
integer pdmax ! latest day in latest month to plant
! real(r8) dt ! radiation time step delta t (seconds)
real(r8) pmintemp ! max 5-day avg min temp for planting winter wheat; else min 10-day avg min (K)
real(r8) ptemp ! min 10-day avg temp for planting (K)
real(r8) crmcorn
! pointers
integer , pointer :: pgridcell(:)! pft's gridcell index
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: ivt(:) ! pft
integer , pointer :: idop(:) ! date of planting
integer , pointer :: harvdate(:) ! harvest date
integer , pointer :: croplive(:) ! planted, not harvested = 1; else 0
integer , pointer :: cropplant(:)! crop may be planted = 0; else = 1
real(r8), pointer :: gddmaturity(:) ! gdd needed to harvest
real(r8), pointer :: huileaf(:) ! heat unit index needed from planting to leaf emergence
real(r8), pointer :: huigrain(:) ! same to reach vegetative maturity
real(r8), pointer :: hui(:) ! =gdd since planting (gddplant)
real(r8), pointer :: leafout(:) ! =gdd from top soil layer temperature
real(r8), pointer :: tlai(:) ! one-sided leaf area index, no burying by snow
real(r8), pointer :: gdd020(:)
real(r8), pointer :: gdd820(:)
real(r8), pointer :: gdd1020(:)
real(r8), pointer :: a5tmin(:)
real(r8), pointer :: a10tmin(:)
real(r8), pointer :: t10(:)
real(r8), pointer :: cumvd(:) ! cumulative vernalization d?ependence?
real(r8), pointer :: hdidx(:) ! cold hardening index?
real(r8), pointer :: vf(:) ! vernalization factor
real(r8), pointer :: t_ref2m_min(:)
real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s)
real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s)
real(r8), pointer :: lgsf(:) ! long growing season factor [0-1]
real(r8), pointer :: onset_flag(:) ! onset flag
real(r8), pointer :: offset_flag(:) ! offset flag
real(r8), pointer :: onset_counter(:) ! onset counter
real(r8), pointer :: offset_counter(:) ! offset counter
real(r8), pointer :: leaf_long(:) ! leaf longevity (yrs)
real(r8), pointer :: leafc_xfer(:)
real(r8), pointer :: leafn_xfer(:)
real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN)
real(r8), pointer :: dwt_seedc_to_leaf(:) !
real(r8), pointer :: dwt_seedn_to_leaf(:) !
real(r8), pointer :: latdeg(:) ! latitude (radians)
pgridcell => clm3%g%l%c%p%gridcell
pcolumn => clm3%g%l%c%p%column
ivt => clm3%g%l%c%p%itype
idop => clm3%g%l%c%p%pps%idop
harvdate => clm3%g%l%c%p%pps%harvdate
croplive => clm3%g%l%c%p%pps%croplive
cropplant => clm3%g%l%c%p%pps%cropplant
gddmaturity => clm3%g%l%c%p%pps%gddmaturity
huileaf => clm3%g%l%c%p%pps%huileaf
huigrain => clm3%g%l%c%p%pps%huigrain
hui => clm3%g%l%c%p%pps%gddplant
leafout => clm3%g%l%c%p%pps%gddtsoi
tlai => clm3%g%l%c%p%pps%tlai
gdd020 => clm3%g%l%c%p%pps%gdd020
gdd820 => clm3%g%l%c%p%pps%gdd820
gdd1020 => clm3%g%l%c%p%pps%gdd1020
a5tmin => clm3%g%l%c%p%pps%a5tmin
a10tmin => clm3%g%l%c%p%pps%a10tmin
t10 => clm3%g%l%c%p%pdgvs%t10
cumvd => clm3%g%l%c%p%pps%cumvd
hdidx => clm3%g%l%c%p%pps%hdidx
vf => clm3%g%l%c%p%pps%vf
t_ref2m_min => clm3%g%l%c%p%pes%t_ref2m_min
bglfr => clm3%g%l%c%p%pepv%bglfr
bgtr => clm3%g%l%c%p%pepv%bgtr
lgsf => clm3%g%l%c%p%pepv%lgsf
onset_flag => clm3%g%l%c%p%pepv%onset_flag
offset_flag => clm3%g%l%c%p%pepv%offset_flag
onset_counter => clm3%g%l%c%p%pepv%onset_counter
offset_counter => clm3%g%l%c%p%pepv%offset_counter
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
leaf_long => pftcon%leaf_long
leafcn => pftcon%leafcn
dwt_seedc_to_leaf => clm3%g%l%c%ccf%dwt_seedc_to_leaf
dwt_seedn_to_leaf => clm3%g%l%c%cnf%dwt_seedn_to_leaf
latdeg => clm3%g%latdeg
! ---------------------------------------
!ylu removed and add
! get time info
! dt = get_step_size()
! jday = get_curr_calday()
! call get_curr_date(kyr, kmo, kda, mcsec)
jday=calday
kyr=year
kmo=month
kda=day
mcsec=secs
!ylu end
! irotation = 4 => harvest >= 1crops/yr; harvest & other vars may need to chg
! for irotation>0 to work; for now assume unchanging crops from yr to yr except
! when moving to a new surface-data file at which point I would start the run
! clean, ie reset everything assuming no memory of the past; this may be a
! problem if we switch surface-data files while certain grid cells are in the
! middle of their growing season. Any relevant issues for the SH? (slevis)
call rotation() ! here? in do-loop as rotation(p)? elsewhere? call 1/yr (slevis)
do fp = 1, num_pcropp
p = filter_pcropp(fp)
c = pcolumn(p)
g = pgridcell(p)
! background litterfall and transfer rates; long growing season factor
bglfr(p) = 0._r8 ! this value changes later in a crop's life cycle
bgtr(p) = 0._r8
lgsf(p) = 0._r8
! ---------------------------------
! from AgroIBIS subroutine planting
! ---------------------------------
! in order to allow a crop to be planted only once each year
! initialize cropplant = 0, but hold it = 1 through the end of the year
! initialize other variables that are calculated for crops
! on an annual basis in cropresidue subroutine
if ((jday == 1 .and. mcsec == 0 .and. latdeg(g) >= 0._r8) .or. & ! NH
(jday == 182 .and. mcsec == 0 .and. latdeg(g) < 0._r8 )) then ! SH
! make sure variables aren't changed at beginning of the year
! for a crop that is currently planted (e.g. winter wheat)
if (croplive(p) == 0) then
cropplant(p) = 0
idop(p) = 999
! keep next for continuous, annual winter wheat type crop;
! if we removed elseif,
! winter wheat grown continuously would amount to a wheat/fallow
! rotation because wheat would only be planted every other year
else if (croplive(p) == 1 .and. ivt(p) == nwwheat) then
cropplant(p) = 0
! else ! not possible to have croplive==1 and ivt==cornORsoy? (slevis)
end if
end if
if (croplive(p) == 0 .and. cropplant(p) == 0) then
! gdd needed for * chosen crop and a likely hybrid (for that region) *
! to reach full physiological maturity
! based on accumulated seasonal average growing degree days from
! April 1 - Sept 30 (inclusive)
! for corn and soybeans in the United States -
! decided upon by what the typical average growing season length is
! and the gdd needed to reach maturity in those regions
! first choice is used for spring wheat and/or soybeans and maize
! slevis: ibis reads xinpdate in io.f from control.crops.nc variable name 'plantdate'
! According to Chris Kucharik, the dataset of
! xinpdate was generated from a previous model run at 0.5 deg resolution
! winter wheat : use gdd0 as a limit to plant winter wheat
if (ivt(p) == nwwheat) then
! minimum temperature required for crop planting and vegetative growth
! from EPIC model parameterizations
! the planting range in the US for maize is typically from April 10 - May 10
! the most active planting date in US for soybean is typically May 15 - June 20
! spring wheat planting dates are typically early April through mid-May
! in line with maize
! winter wheat is from Sept. 1 through early Nov., and is typically planted
! within 10-14 days of the first likely frost event.
! typically winter wheat is planted when ave min temperature gets
! to about 40 F and is planted no later than November
! slevis: added distinction between NH and SH
if (latdeg(g) >= 0._r8) then
pmmin = 9
pmmax = 11
else
pmmin = 3
pmmax = 5
end if
pdmin = 1
pdmax = 30
pmintemp = tfrz + 5._r8
! add check to only plant winter wheat after other crops (soybean, maize)
! have been harvested
! *** remember order of planting is crucial - in terms of which crops you want
! to be grown in what order ***
! in this case, corn or soybeans are assumed to be planted before
! wheat would be in any particular year that both pfts are allowed
! to grow in the same grid cell (e.g., double-cropping)
! slevis: harvdate below needs cropplant(p)==0 above to be cropplant(p,ivt(p))==0
! where ivt(p) has rotated to winter wheat because
! cropplant == 1 through the end of the year for a harvested crop.
! Also harvdate(p) should be harvdate(p,ivt(p)) and should be
! updated on Jan 1st instead of at harvest (slevis)
if (a5tmin(p) <= pmintemp .and. &
kmo >= pmmin .and. &
kda >= pdmin .and.(&
irotation == 0 ).and. &
gdd020(p) >= gddmin(ivt(p))) then
cumvd(p) = 0._r8
hdidx(p) = 0._r8
vf(p) = 0._r8
croplive(p) = 1
cropplant(p) = 1
idop(p) = jday
harvdate(p) = 999
gddmaturity(p) = hybgdd(ivt(p))
leafc_xfer(p) = 1._r8 ! initial seed at planting to appear
leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset
dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) + leafc_xfer(p)/dt
dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) + leafn_xfer(p)/dt
! latest possible date to plant winter wheat and after all other crops were harvested for that year
! slevis: same comments concerning cropplant & harvdate
! slevis: this is not how I would have written this if-elseif statement
! to plant winter wheat between Sep 1st and Nov 30th. Chris
! explains that the else if ensures winter wheat planting by
! Nov 30th if the a5tmin limit is not achieved. I'm probably stuck
! on the kmo>= and kda>= which suggest to me any date after Nov 29th.
! I think they could have been kmo== and kda== and worked the same.
! It may also reduce confusion to separate parts of the if statement.
! Eg, harvdate, irotation, and gdd020 do not change as the kmo and kda
! statements switch from false to true and are common to the if part
! of the statement.
else if (kmo >= pmmax .and. &
kda >= pdmax .and.(&
irotation == 0 ).and. &
gdd020(p) >= gddmin(ivt(p))) then
cumvd(p) = 0._r8
hdidx(p) = 0._r8
vf(p) = 0._r8
croplive(p) = 1
cropplant(p) = 1
idop(p) = jday
harvdate(p) = 999
gddmaturity(p) = hybgdd(ivt(p))
leafc_xfer(p) = 1._r8 ! initial seed at planting to appear
leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset
dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) + leafc_xfer(p)/dt
dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) + leafn_xfer(p)/dt
else
gddmaturity(p) = 0._r8
end if
else ! not winter wheat... slevis: added distinction between NH and SH
if (ivt(p) == nsoybean) then
if (latdeg(g) >= 0._r8) then
pmmin = 5
pmmax = 6
else
pmmin = 11
pmmax = 12
end if
pmintemp = tfrz + 6._r8
ptemp = tfrz + 13._r8
else if (ivt(p) == ncorn) then
if (latdeg(g) >= 0._r8) then
pmmin = 4
pmmax = 6
else
pmmin = 10
pmmax = 12
end if
pmintemp = tfrz + 6._r8
ptemp = tfrz + 10._r8
else if (ivt(p) == nswheat) then
if (latdeg(g) >= 0._r8) then
pmmin = 4
pmmax = 6
else
pmmin = 10
pmmax = 12
end if
pmintemp = tfrz - 1._r8
ptemp = tfrz + 7._r8
end if
pdmin = 1
pdmax = 15
! slevis: the jday if statement confused me in a similar way to the one before.
! The idea is that jday will equal idop sooner or later in the year
! while the gdd part is either true or false for the year.
! Replace the jday if statement with the more complete but commented out one from AgroIBIS
if (t10(p) > ptemp .and. a10tmin(p) > pmintemp .and. &
kmo >= pmmin .and. kda >= pdmin .and. &
kmo <= pmmax .and. gdd820(p) >= gddmin(ivt(p))) then
! impose limit on growing season length needed
! for crop maturity - for cold weather constraints
croplive(p) = 1
cropplant(p) = 1
idop(p) = jday
harvdate(p) = 999
! go a specified amount of time before/after
! climatological date
if (ivt(p)==nsoybean) gddmaturity(p)=min(gdd1020(p),hybgdd(ivt(p)))
if (ivt(p)==ncorn) then
gddmaturity(p)=max(950._r8, min(gdd820(p)*0.85_r8, hybgdd(ivt(p))))
gddmaturity(p)=max(950._r8, min(gddmaturity(p)+150._r8,1850._r8))
end if
if (ivt(p)==nswheat) gddmaturity(p)=min(gdd020(p),hybgdd(ivt(p)))
leafc_xfer(p) = 1._r8 ! initial seed at planting to appear
leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset
dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) + leafc_xfer(p)/dt
dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) + leafn_xfer(p)/dt
else if (kmo == pmmax .and. kda == pdmax .and. gdd820(p) > 0._r8) then
croplive(p) = 1
cropplant(p) = 1
idop(p) = jday
harvdate(p) = 999
if (ivt(p)==nsoybean) gddmaturity(p)=min(gdd1020(p),hybgdd(ivt(p)))
if (ivt(p)==ncorn) gddmaturity(p)=max(950._r8, min(gdd820(p)*0.85_r8, hybgdd(ivt(p))))
if (ivt(p)==nswheat) gddmaturity(p)=min(gdd020(p),hybgdd(ivt(p)))
leafc_xfer(p) = 1._r8 ! initial seed at planting to appear
leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p)) ! with onset
dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) + leafc_xfer(p)/dt
dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) + leafn_xfer(p)/dt
else
gddmaturity(p) = 0._r8
end if
end if ! crop pft distinction
! crop phenology (gdd thresholds) controlled by gdd needed for
! maturity (physiological) which is based on the average gdd
! accumulation and hybrids in United States from April 1 - Sept 30
! calculate threshold from phase 1 to phase 2:
! threshold for attaining leaf emergence (based on fraction of
! gdd(i) -- climatological average)
! Hayhoe and Dwyer, 1990, Can. J. Soil Sci 70:493-497
! Carlson and Gage, 1989, Agric. For. Met., 45: 313-324
! J.T. Ritchie, 1991: Modeling Plant and Soil systems
huileaf(p) = lfemerg(ivt(p)) * gddmaturity(p) ! 3-7% in wheat
! calculate threshhold from phase 2 to phase 3:
! from leaf emergence to beginning of grain-fill period
! this hypothetically occurs at the end of tassling, not the beginning
! tassel initiation typically begins at 0.5-0.55 * gddmaturity
! calculate linear relationship between huigrain fraction and relative
! maturity rating for maize
if (ivt(p) == ncorn) then
crmcorn = max(73._r8, min(135._r8, (gddmaturity(p)+ 53.683_r8)/13.882_r8))
huigrain(p) = -0.002_r8 * (crmcorn - 73._r8) + grnfill(ivt(p))
huigrain(p) = min(max(huigrain(p), grnfill(ivt(p))-0.1_r8), grnfill(ivt(p)))
huigrain(p) = huigrain(p) * gddmaturity(p) ! Cabelguenne et
else
huigrain(p) = grnfill(ivt(p)) * gddmaturity(p) ! al. 1999
end if
end if ! crop not live nor planted
! ----------------------------------
! from AgroIBIS subroutine phenocrop
! ----------------------------------
! all of the phenology changes are based on the total number of gdd needed
! to change to the next phase - based on fractions of the total gdd typical
! for that region based on the April 1 - Sept 30 window of development
! crop phenology (gdd thresholds) controlled by gdd needed for
! maturity (physiological) which is based on the average gdd
! accumulation and hybrids in United States from April 1 - Sept 30
! Phase 1: Planting to leaf emergence (now in CNAllocation)
! Phase 2: Leaf emergence to beginning of grain fill (general LAI accumulation)
! Phase 3: Grain fill to physiological maturity and harvest (LAI decline)
! Harvest: if gdd past grain fill initiation exceeds limit
! or number of days past planting reaches a maximum, the crop has
! reached physiological maturity and plant is harvested;
! crop could be live or dead at this stage - these limits
! could lead to reaching physiological maturity or determining
! a harvest date for a crop killed by an early frost (see next comments)
! --- --- ---
! keeping comments without the code (slevis):
! if minimum temperature, t_ref2m_min <= freeze kill threshold, tkill
! for 3 consecutive days and lai is above a minimum,
! plant will be damaged/killed. This function is more for spring freeze events
! or for early fall freeze events
! spring wheat is affected by this, winter wheat kill function
! is determined in crops.f - is a more elaborate function of
! cold hardening of the plant
! currently simulates too many grid cells killed by freezing temperatures
! removed on March 12 2002 - C. Kucharik
! until it can be a bit more refined, or used at a smaller scale.
! we really have no way of validating this routine
! too difficult to implement on 0.5 degree scale grid cells
! --- --- ---
onset_flag(p) = 0._r8 ! CN terminology to trigger certain
offset_flag(p) = 0._r8 ! carbon and nitrogen transfers
if (croplive(p) == 1) then
! call vernalization if winter wheat planted, living, and the
! vernalization factor is not 1;
! vf affects the calculation of gddtsoi & gddplant
if (t_ref2m_min(p) < 1.e30_r8 .and. vf(p) /= 1._r8 .and. ivt(p) == nwwheat) then
call vernalization(p)
end if
! days past planting may determine harvest
if (jday >= idop(p)) then
idpp = jday - idop(p)
else
idpp = 365+jday - idop(p)
end if
! onset_counter initialized to zero when croplive == 0
! offset_counter relevant only at time step of harvest
onset_counter(p) = onset_counter(p) - dt
! enter phase 2 onset for one time step:
! transfer seed carbon to leaf emergence
if (leafout(p) >= huileaf(p) .and. hui(p) < huigrain(p) .and. idpp < mxmat(ivt(p))) then
if (abs(onset_counter(p)) > 1.e-6_r8) then
onset_flag(p) = 1._r8
onset_counter(p) = dt
else
onset_counter(p) = dt ! ensure no re-entry to onset of phase2
end if
! enter harvest for one time step:
! - transfer live biomass to litter and to crop yield
! - send xsmrpool to the atmosphere
! if onset and harvest needed to last longer than one timestep
! the onset_counter would change from dt and you'd need to make
! changes to the offset subroutine below
else if (hui(p) >= gddmaturity(p) .or. idpp >= mxmat(ivt(p))) then
if (harvdate(p) == 999) harvdate(p) = jday
croplive(p) = 0 ! no re-entry in greater if-block
if (tlai(p) > 0._r8) then ! plant had emerged before harvest
offset_flag(p) = 1._r8
offset_counter(p) = dt
else ! plant never emerged from the ground
dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf(c) - leafc_xfer(p)/dt
dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf(c) - leafn_xfer(p)/dt
leafc_xfer(p) = 0._r8 ! revert planting transfers
leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p))
end if
! enter phase 3 while previous criteria fail and next is true;
! in terms of order, phase 3 occurs before harvest, but when
! harvest *can* occur, we want it to have first priority.
! AgroIBIS uses a complex formula for lai decline.
! Use CN's simple formula at least as a place holder (slevis)
else if (hui(p) >= huigrain(p)) then
bglfr(p) = 1._r8/(leaf_long(ivt(p))*365._r8*86400._r8)
end if
else ! crop not live
onset_counter(p) = 0._r8
leafc_xfer(p) = 0._r8
leafn_xfer(p) = leafc_xfer(p) / leafcn(ivt(p))
end if ! croplive is 1 or 0
end do ! prognostic crops loop
end subroutine CropPhenology
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: rotation
!
! !INTERFACE:
subroutine rotation() ! uncomment when ready (slevis) 1
! subroutine used to plant different crop types in different years
! to simulate typical crop rotations in the United States
! could be modified in future if rotations would include natural
! vegetation types such as grasslands or biofuel (switchgrass) crops
!
! currently three main types of rotations are used
! if irotation ==
! 2: maize/soybean rotation (alternating)
! 3: maize/soybean/spring wheat
! 4: soybean/winter wheat/maize
!
! note: by doing continuous winter wheat, land is fallow
! only from harvest (june-july) through planting (Sept-Nov).
!USES:
! use clm_time_manager, only : get_curr_date
! local variables
! real(r8) xfrac
! integer kyr ! year
! integer kmo ! month (1, ..., 12)
! integer kda ! day of month (1, ..., 31)
! integer mcsec ! current seconds of current date (0, ..., 86400)
! integer iyrrot
! integer idiv
! integer p
! integer irotation
! pointers
! integer , pointer :: ivt(:) !plant functional type (value from 0:numpft)
! ivt => clm3%g%l%c%p%itype
! begin grid
! in this case, irotation also is the number of crops in a specified rotation
! slevis: except when irotation = 4
!
! assumes that natural vegetation existence arrays are set to 0.0
! in climate.f (existence)
! look at the fraction remainder to determine which crop should
! be planted
! if (irotation == 1) idiv = 3
! if (irotation == 2) idiv = 2
! if (irotation == 3) idiv = 3
! if (irotation == 4) idiv = 3
! In orig code, if not restart, iyrrot=1950. Why? Fert data starts at 1945.
! Else iyrrot=irstyear, but why not = base year?
! With iyrrot=irstyear I think xfrac will reset at every restart.
! In any case, we need to get irstyear to calc xfrac. (slevis)
! write(11,*) 'irstyear =', irstyear
! call shr_sys_flush(11)
! iyrrot = irstyear
! call get_curr_date(kyr, kmo, kda, mcsec)
! xfrac = mod ((kyr - iyrrot), idiv)
! do p = begp, endp ! replace two lines with crop filter
! if (crop(ivt(p)) == 1.) then
! 2:
! two-crop rotation (standard soybean/corn)
! alternate between even / odd years
! if (irotation == 2) then
! if (xfrac == 0.0) then
! ivt(p) = ncorn
! else
! ivt(p) = nsoybean
! end if
! 3:
! rotation with 3 crops (corn, soybean, spring wheat)
! else if (irotation == 3) then
! if (xfrac == 0.0) then
! ivt(p) = nsoybean
! else if (xfrac == 1.0) then
! ivt(p) = ncorn
! else
! ivt(p) = nswheat
! end if
! 4:
! 3 crop rotation with winter wheat and soybean planted in same year
! winter wheat harvested in year 2
! maize grown in year 3
! else if (irotation == 4) then
! soybean planted/harvested
! winter wheat planted
! if (xfrac == 0.0) then
! ivt(p) = nsoybean ! NB: ivt(p) (+ other vars?) must change at
!! ivt(p) = nwwheat ! harvest of the first crop; slevis
! FOR NOW irotation=4 NOT USED
! winter wheat harvested in year 2
! else if (xfrac == 1.0) then
! ivt(p) = nwwheat
! maize planted/harvested in year 3
! else
! ivt(p) = ncorn
! end if
! end if
! end if
! end do
end subroutine rotation
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: vernalization
!
! !INTERFACE:
subroutine vernalization(p) 1
! * * * only call for winter wheat * * *
!
! subroutine calculates vernalization and photoperiod effects on
! gdd accumulation in winter wheat varieties. Thermal time accumulation
! is reduced in 1st period until plant is fully vernalized. During this
! time of emergence to spikelet formation, photoperiod can also have a
! drastic effect on plant development.
! local variables
real(r8) p1d, p1v
real(r8) tcrown
real(r8) vd, vd1, vd2
real(r8) tkil, tbase
real(r8) hti
integer c,g
integer, intent(in) :: p
! pointers
integer , pointer :: pcolumn(:) ! pft's column index
integer , pointer :: croplive(:)
real(r8), pointer :: hdidx(:)
real(r8), pointer :: cumvd(:)
real(r8), pointer :: vf(:)
real(r8), pointer :: gddmaturity(:) ! gdd needed to harvest
real(r8), pointer :: huigrain(:) ! heat unit index needed to reach vegetative maturity
real(r8), pointer :: tlai(:) ! one-sided leaf area index, no burying by snow
real(r8), pointer :: t_ref2m(:)
real(r8), pointer :: t_ref2m_min(:)
real(r8), pointer :: t_ref2m_max(:)
real(r8), pointer :: snowdp(:)
pcolumn => clm3%g%l%c%p%column
croplive => clm3%g%l%c%p%pps%croplive
hdidx => clm3%g%l%c%p%pps%hdidx
cumvd => clm3%g%l%c%p%pps%cumvd
vf => clm3%g%l%c%p%pps%vf
gddmaturity => clm3%g%l%c%p%pps%gddmaturity
huigrain => clm3%g%l%c%p%pps%huigrain
tlai => clm3%g%l%c%p%pps%tlai
t_ref2m => clm3%g%l%c%p%pes%t_ref2m
t_ref2m_min => clm3%g%l%c%p%pes%t_ref2m_min
t_ref2m_max => clm3%g%l%c%p%pes%t_ref2m_max
snowdp => clm3%g%l%c%cps%snowdp
! photoperiod factor calculation
! genetic constant - can be modified
p1d = 0.004_r8 ! average for genotypes from Ritchey, 1991.
! Modeling plant & soil systems: Wheat phasic developmt
p1v = 0.003_r8 ! average for genotypes from Ritchey, 1991.
c = pcolumn(p)
! for all equations - temperatures must be in degrees (C)
! calculate temperature of crown of crop (e.g., 3 cm soil temperature)
! snow depth in centimeters
if (t_ref2m(p) < tfrz) then !slevis: t_ref2m inst of td=daily avg (K)
tcrown = 2._r8 + (t_ref2m(p) - tfrz) * (0.4_r8 + 0.0018_r8 * &
(min(snowdp(c)*100._r8, 15._r8) - 15._r8)**2)
else !slevis: snowdp inst of adsnod=daily average (m)
tcrown = t_ref2m(p) - tfrz
end if
! vernalization factor calculation
! if vf(p) = 1. then plant is fully vernalized - and thermal time
! accumulation in phase 1 will be unaffected
! refers to gddtsoi & gddplant, defined in the accumulation routines (slevis)
! reset vf, cumvd, and hdidx to 0 at planting of crop (slevis)
if (t_ref2m_max(p) > tfrz) then
if (t_ref2m_min(p) <= tfrz+15._r8) then
vd1 = 1.4_r8 - 0.0778_r8 * tcrown
vd2 = 0.5_r8 + 13.44_r8 / ((t_ref2m_max(p)-t_ref2m_min(p)+3._r8)**2) * tcrown
vd = max(0._r8, min(1._r8, vd1, vd2))
cumvd(p) = cumvd(p) + vd
end if
if (cumvd(p) < 10._r8 .and. t_ref2m_max(p) > tfrz+30._r8) then
cumvd(p) = cumvd(p) - 0.5_r8 * (t_ref2m_max(p) - tfrz - 30._r8)
end if
cumvd(p) = max(0._r8, cumvd(p)) ! must be > 0
vf(p) = 1._r8 - p1v * (50._r8 - cumvd(p))
vf(p) = max(0._r8, min(vf(p), 1._r8)) ! must be between 0 - 1
end if
! calculate cold hardening of plant
! determines for winter wheat varieties whether the plant has completed
! a period of cold hardening to protect it from freezing temperatures. If
! not, then exposure could result in death or killing of plants.
! there are two distinct phases of hardening
tbase = 0._r8
hti = 1._r8
if (t_ref2m_min(p) <= tfrz-3._r8 .or. hdidx(p) /= 0._r8) then
if (hdidx(p) >= hti) then ! done with phase 1
hdidx(p) = hdidx(p) + 0.083_r8
hdidx(p) = min(hdidx(p), hti*2._r8)
end if
if (t_ref2m_max(p) >= tbase + tfrz + 10._r8) then
hdidx(p) = hdidx(p) - 0.02_r8 * (t_ref2m_max(p)-tbase-tfrz-10._r8)
if (hdidx(p) > hti) hdidx(p) = hdidx(p) - 0.02_r8 * (t_ref2m_max(p)-tbase-tfrz-10._r8)
hdidx(p) = max(0._r8, hdidx(p))
end if
else if (tcrown >= tbase-1._r8) then
if (tcrown <= tbase+8._r8) then
hdidx(p) = hdidx(p) + 0.1_r8 - (tcrown-tbase+3.5_r8)**2 / 506._r8
if (hdidx(p) >= hti .and. tcrown <= tbase + 0._r8) then
hdidx(p) = hdidx(p) + 0.083_r8
hdidx(p) = min(hdidx(p), hti*2._r8)
end if
end if
if (t_ref2m_max(p) >= tbase + tfrz + 10._r8) then
hdidx(p) = hdidx(p) - 0.02_r8 * (t_ref2m_max(p)-tbase-tfrz-10._r8)
if (hdidx(p) > hti) hdidx(p) = hdidx(p) - 0.02_r8 * (t_ref2m_max(p)-tbase-tfrz-10._r8)
hdidx(p) = max(0._r8, hdidx(p))
end if
end if
! calculate what the wheat killing temperature
! there is a linear inverse relationship between
! hardening of the plant and the killing temperature or
! threshold that the plant can withstand
! when plant is fully-hardened (hdidx = 2), the killing threshold is -18 C
! will have to develop some type of relationship that reduces LAI and
! biomass pools in response to cold damaged crop
if (t_ref2m_min(p) <= tfrz - 6._r8) then
tkil = (tbase - 6._r8) - 6._r8 * hdidx(p)
if (tkil >= tcrown) then
if ((0.95_r8 - 0.02_r8 * (tcrown - tkil)**2) >= 0.02_r8) then
write (6,*) 'crop damaged by cold temperatures at p,c =', p,c
else if (tlai(p) > 0._r8) then ! slevis: kill if past phase1
gddmaturity(p) = 0._r8 ! by forcing through
huigrain(p) = 0._r8 ! harvest
write (6,*) '95% of crop killed by cold temperatures at p,c =', p,c
end if
end if
end if
end subroutine vernalization
#endif
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNOnsetGrowth
!
! !INTERFACE:
subroutine CNOnsetGrowth (num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! Determines the flux of stored C and N from transfer pools to display
! pools during the phenological onset period.
!
! !USES:
!ylu removed
! use clm_time_manager, only: get_step_size
use globals, only: dt
#ifdef CROP
use pftvarcon , only: npcropmin
#endif
!
! !ARGUMENTS:
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 10/27/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: onset_flag(:) ! onset flag
real(r8), pointer :: onset_counter(:) ! onset days counter
real(r8), pointer :: leafc_xfer(:) ! (kgC/m2) leaf C transfer
real(r8), pointer :: frootc_xfer(:) ! (kgC/m2) fine root C transfer
real(r8), pointer :: livestemc_xfer(:) ! (kgC/m2) live stem C transfer
real(r8), pointer :: deadstemc_xfer(:) ! (kgC/m2) dead stem C transfer
real(r8), pointer :: livecrootc_xfer(:) ! (kgC/m2) live coarse root C transfer
real(r8), pointer :: deadcrootc_xfer(:) ! (kgC/m2) dead coarse root C transfer
real(r8), pointer :: leafn_xfer(:) ! (kgN/m2) leaf N transfer
real(r8), pointer :: frootn_xfer(:) ! (kgN/m2) fine root N transfer
real(r8), pointer :: livestemn_xfer(:) ! (kgN/m2) live stem N transfer
real(r8), pointer :: deadstemn_xfer(:) ! (kgN/m2) dead stem N transfer
real(r8), pointer :: livecrootn_xfer(:) ! (kgN/m2) live coarse root N transfer
real(r8), pointer :: deadcrootn_xfer(:) ! (kgN/m2) dead coarse root N transfer
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
real(r8), pointer :: bgtr(:) ! background transfer growth rate (1/s)
!
! local pointers to implicit in/out scalars
!
real(r8), pointer :: leafc_xfer_to_leafc(:)
real(r8), pointer :: frootc_xfer_to_frootc(:)
real(r8), pointer :: livestemc_xfer_to_livestemc(:)
real(r8), pointer :: deadstemc_xfer_to_deadstemc(:)
real(r8), pointer :: livecrootc_xfer_to_livecrootc(:)
real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:)
real(r8), pointer :: leafn_xfer_to_leafn(:)
real(r8), pointer :: frootn_xfer_to_frootn(:)
real(r8), pointer :: livestemn_xfer_to_livestemn(:)
#if (defined CROP)
real(r8), pointer :: grainn_xfer_to_grainn(:)
real(r8), pointer :: grainn_xfer(:)
#endif
real(r8), pointer :: deadstemn_xfer_to_deadstemn(:)
real(r8), pointer :: livecrootn_xfer_to_livecrootn(:)
real(r8), pointer :: deadcrootn_xfer_to_deadcrootn(:)
!
! local pointers to implicit out scalars
!
! !OTHER LOCAL VARIABLES:
integer :: p ! indices
integer :: fp ! lake filter pft index
! real(r8):: dt ! radiation time step delta t (seconds)
real(r8):: t1 ! temporary variable
!EOP
!-----------------------------------------------------------------------
! assign local pointers to derived type arrays (in)
ivt => clm3%g%l%c%p%itype
onset_flag => clm3%g%l%c%p%pepv%onset_flag
onset_counter => clm3%g%l%c%p%pepv%onset_counter
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
bgtr => clm3%g%l%c%p%pepv%bgtr
woody => pftcon%woody
! assign local pointers to derived type arrays (out)
leafc_xfer_to_leafc => clm3%g%l%c%p%pcf%leafc_xfer_to_leafc
frootc_xfer_to_frootc => clm3%g%l%c%p%pcf%frootc_xfer_to_frootc
livestemc_xfer_to_livestemc => clm3%g%l%c%p%pcf%livestemc_xfer_to_livestemc
deadstemc_xfer_to_deadstemc => clm3%g%l%c%p%pcf%deadstemc_xfer_to_deadstemc
livecrootc_xfer_to_livecrootc => clm3%g%l%c%p%pcf%livecrootc_xfer_to_livecrootc
deadcrootc_xfer_to_deadcrootc => clm3%g%l%c%p%pcf%deadcrootc_xfer_to_deadcrootc
leafn_xfer_to_leafn => clm3%g%l%c%p%pnf%leafn_xfer_to_leafn
frootn_xfer_to_frootn => clm3%g%l%c%p%pnf%frootn_xfer_to_frootn
livestemn_xfer_to_livestemn => clm3%g%l%c%p%pnf%livestemn_xfer_to_livestemn
deadstemn_xfer_to_deadstemn => clm3%g%l%c%p%pnf%deadstemn_xfer_to_deadstemn
livecrootn_xfer_to_livecrootn => clm3%g%l%c%p%pnf%livecrootn_xfer_to_livecrootn
deadcrootn_xfer_to_deadcrootn => clm3%g%l%c%p%pnf%deadcrootn_xfer_to_deadcrootn
#if (defined CROP)
grainn_xfer_to_grainn => clm3%g%l%c%p%pnf%grainn_xfer_to_grainn
grainn_xfer => clm3%g%l%c%p%pns%grainn_xfer
#endif
! set time steps
! dt = real( get_step_size(), r8 )
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! only calculate these fluxes during onset period
if (onset_flag(p) == 1._r8) then
! The transfer rate is a linearly decreasing function of time,
! going to zero on the last timestep of the onset period
if (onset_counter(p) == dt) then
t1 = 1.0_r8 / dt
else
t1 = 2.0_r8 / (onset_counter(p))
end if
leafc_xfer_to_leafc(p) = t1 * leafc_xfer(p)
frootc_xfer_to_frootc(p) = t1 * frootc_xfer(p)
leafn_xfer_to_leafn(p) = t1 * leafn_xfer(p)
frootn_xfer_to_frootn(p) = t1 * frootn_xfer(p)
if (woody(ivt(p)) == 1.0_r8) then
livestemc_xfer_to_livestemc(p) = t1 * livestemc_xfer(p)
deadstemc_xfer_to_deadstemc(p) = t1 * deadstemc_xfer(p)
livecrootc_xfer_to_livecrootc(p) = t1 * livecrootc_xfer(p)
deadcrootc_xfer_to_deadcrootc(p) = t1 * deadcrootc_xfer(p)
livestemn_xfer_to_livestemn(p) = t1 * livestemn_xfer(p)
deadstemn_xfer_to_deadstemn(p) = t1 * deadstemn_xfer(p)
livecrootn_xfer_to_livecrootn(p) = t1 * livecrootn_xfer(p)
deadcrootn_xfer_to_deadcrootn(p) = t1 * deadcrootn_xfer(p)
end if
!ylu add calculation on grainn_xfer_to_grainn,need to check with Sam
#if (defined CROP)
if (ivt(p) >= npcropmin) then
grainn_xfer_to_grainn(p) = t1 * grainn_xfer(p)
end if
#endif
end if ! end if onset period
! calculate the background rate of transfer growth (used for stress
! deciduous algorithm). In this case, all of the mass in the transfer
! pools should be moved to displayed growth in each timestep.
if (bgtr(p) > 0._r8) then
leafc_xfer_to_leafc(p) = leafc_xfer(p) / dt
frootc_xfer_to_frootc(p) = frootc_xfer(p) / dt
leafn_xfer_to_leafn(p) = leafn_xfer(p) / dt
frootn_xfer_to_frootn(p) = frootn_xfer(p) / dt
if (woody(ivt(p)) == 1.0_r8) then
livestemc_xfer_to_livestemc(p) = livestemc_xfer(p) / dt
deadstemc_xfer_to_deadstemc(p) = deadstemc_xfer(p) / dt
livecrootc_xfer_to_livecrootc(p) = livecrootc_xfer(p) / dt
deadcrootc_xfer_to_deadcrootc(p) = deadcrootc_xfer(p) / dt
livestemn_xfer_to_livestemn(p) = livestemn_xfer(p) / dt
deadstemn_xfer_to_deadstemn(p) = deadstemn_xfer(p) / dt
livecrootn_xfer_to_livecrootn(p) = livecrootn_xfer(p) / dt
deadcrootn_xfer_to_deadcrootn(p) = deadcrootn_xfer(p) / dt
end if
!ylu add calculation on grainn_xfer_to_grainn,need to check with Sam
#if (defined CROP)
if (ivt(p) >= npcropmin) then
grainn_xfer_to_grainn(p) = grainn_xfer(p) / dt
end if
#endif
end if ! end if bgtr
end do ! end pft loop
end subroutine CNOnsetGrowth
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNOffsetLitterfall
!
! !INTERFACE:
subroutine CNOffsetLitterfall (num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! Determines the flux of C and N from displayed pools to litter
! pools during the phenological offset period.
!
! !USES:
!ylu removed
! use clm_time_manager, only: get_step_size
use globals, only: dt
#ifdef CROP
use pftvarcon , only: npcropmin
#endif
!
! !ARGUMENTS:
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 10/27/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: offset_flag(:) ! offset flag
real(r8), pointer :: offset_counter(:) ! offset days counter
real(r8), pointer :: leafc(:) ! (kgC/m2) leaf C
real(r8), pointer :: frootc(:) ! (kgC/m2) fine root C
real(r8), pointer :: cpool_to_leafc(:)
real(r8), pointer :: cpool_to_frootc(:)
#if (defined CROP)
! integer , pointer :: pcolumn(:) ! pft's column index
real(r8), pointer :: grainc(:) ! (kgC/m2) grain C
real(r8), pointer :: livestemc(:) ! (kgC/m2) livestem C
real(r8), pointer :: cpool_to_grainc(:)
real(r8), pointer :: cpool_to_livestemc(:)
real(r8), pointer :: livewdcn(:) ! live wood C:N (gC/gN)
real(r8), pointer :: graincn(:) ! grain C:N (gC/gN)
#endif
real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN)
real(r8), pointer :: lflitcn(:) ! leaf litter C:N (gC/gN)
real(r8), pointer :: frootcn(:) ! fine root C:N (gC/gN)
!
! local pointers to implicit in/out scalars
!
real(r8), pointer :: prev_leafc_to_litter(:) ! previous timestep leaf C litterfall flux (gC/m2/s)
real(r8), pointer :: prev_frootc_to_litter(:) ! previous timestep froot C litterfall flux (gC/m2/s)
real(r8), pointer :: leafc_to_litter(:)
real(r8), pointer :: frootc_to_litter(:)
real(r8), pointer :: leafn_to_litter(:)
real(r8), pointer :: leafn_to_retransn(:)
real(r8), pointer :: frootn_to_litter(:)
#if (defined CROP)
real(r8), pointer :: livestemc_to_litter(:)
real(r8), pointer :: grainc_to_food(:)
real(r8), pointer :: livestemn_to_litter(:)
real(r8), pointer :: grainn_to_food(:)
#endif
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: p, c ! indices
integer :: fp ! lake filter pft index
! real(r8):: dt ! radiation time step delta t (seconds)
real(r8):: t1 ! temporary variable
!EOP
!-----------------------------------------------------------------------
! assign local pointers to derived type arrays (in)
ivt => clm3%g%l%c%p%itype
offset_flag => clm3%g%l%c%p%pepv%offset_flag
offset_counter => clm3%g%l%c%p%pepv%offset_counter
leafc => clm3%g%l%c%p%pcs%leafc
frootc => clm3%g%l%c%p%pcs%frootc
#if (defined CROP)
grainc => clm3%g%l%c%p%pcs%grainc
livestemc => clm3%g%l%c%p%pcs%livestemc
cpool_to_grainc => clm3%g%l%c%p%pcf%cpool_to_grainc
cpool_to_livestemc => clm3%g%l%c%p%pcf%cpool_to_livestemc
#endif
cpool_to_leafc => clm3%g%l%c%p%pcf%cpool_to_leafc
cpool_to_frootc => clm3%g%l%c%p%pcf%cpool_to_frootc
leafcn => pftcon%leafcn
lflitcn => pftcon%lflitcn
frootcn => pftcon%frootcn
#if (defined CROP)
livewdcn => pftcon%livewdcn
graincn => pftcon%graincn
#endif
! assign local pointers to derived type arrays (out)
prev_leafc_to_litter => clm3%g%l%c%p%pepv%prev_leafc_to_litter
prev_frootc_to_litter => clm3%g%l%c%p%pepv%prev_frootc_to_litter
leafc_to_litter => clm3%g%l%c%p%pcf%leafc_to_litter
frootc_to_litter => clm3%g%l%c%p%pcf%frootc_to_litter
#if (defined CROP)
livestemc_to_litter => clm3%g%l%c%p%pcf%livestemc_to_litter
grainc_to_food => clm3%g%l%c%p%pcf%grainc_to_food
livestemn_to_litter => clm3%g%l%c%p%pnf%livestemn_to_litter
grainn_to_food => clm3%g%l%c%p%pnf%grainn_to_food
#endif
leafn_to_litter => clm3%g%l%c%p%pnf%leafn_to_litter
leafn_to_retransn => clm3%g%l%c%p%pnf%leafn_to_retransn
frootn_to_litter => clm3%g%l%c%p%pnf%frootn_to_litter
! set time steps
! dt = real( get_step_size(), r8 )
! The litterfall transfer rate starts at 0.0 and increases linearly
! over time, with displayed growth going to 0.0 on the last day of litterfall
do fp = 1,num_soilp
p = filter_soilp(fp)
! only calculate fluxes during offset period
if (offset_flag(p) == 1._r8) then
if (offset_counter(p) == dt) then
t1 = 1.0_r8 / dt
leafc_to_litter(p) = t1 * leafc(p) + cpool_to_leafc(p)
frootc_to_litter(p) = t1 * frootc(p) + cpool_to_frootc(p)
#if (defined CROP)
! this assumes that offset_counter == dt for crops
! if this were ever changed, we'd need to add code to the "else"
if (ivt(p) >= npcropmin) then
grainc_to_food(p) = t1 * grainc(p) + cpool_to_grainc(p)
livestemc_to_litter(p) = t1 * livestemc(p) + cpool_to_livestemc(p)
end if
#endif
else
t1 = dt * 2.0_r8 / (offset_counter(p) * offset_counter(p))
leafc_to_litter(p) = prev_leafc_to_litter(p) + t1*(leafc(p) - prev_leafc_to_litter(p)*offset_counter(p))
frootc_to_litter(p) = prev_frootc_to_litter(p) + t1*(frootc(p) - prev_frootc_to_litter(p)*offset_counter(p))
end if
! calculate the leaf N litterfall and retranslocation
leafn_to_litter(p) = leafc_to_litter(p) / lflitcn(ivt(p))
leafn_to_retransn(p) = (leafc_to_litter(p) / leafcn(ivt(p))) - leafn_to_litter(p)
! calculate fine root N litterfall (no retranslocation of fine root N)
frootn_to_litter(p) = frootc_to_litter(p) / frootcn(ivt(p))
#if (defined CROP)
if (ivt(p) >= npcropmin) then
livestemn_to_litter(p) = livestemc_to_litter(p) / livewdcn(ivt(p))
grainn_to_food(p) = grainc_to_food(p) / graincn(ivt(p))
end if
#endif
! save the current litterfall fluxes
prev_leafc_to_litter(p) = leafc_to_litter(p)
prev_frootc_to_litter(p) = frootc_to_litter(p)
end if ! end if offset period
end do ! end pft loop
end subroutine CNOffsetLitterfall
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNBackgroundLitterfall
!
! !INTERFACE:
subroutine CNBackgroundLitterfall (num_soilp, filter_soilp) 1,1
!
! !DESCRIPTION:
! Determines the flux of C and N from displayed pools to litter
! pools as the result of background litter fall.
!
! !USES:
!ylu removed
! use clm_time_manager, only: get_step_size
use globals, only: dt
!
! !ARGUMENTS:
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 10/2/03: Created by Peter Thornton
! 10/24/03, Peter Thornton: migrated to vector data structures
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
! pft level
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s)
real(r8), pointer :: leafc(:) ! (kgC/m2) leaf C
real(r8), pointer :: frootc(:) ! (kgC/m2) fine root C
! ecophysiological constants
real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN)
real(r8), pointer :: lflitcn(:) ! leaf litter C:N (gC/gN)
real(r8), pointer :: frootcn(:) ! fine root C:N (gC/gN)
!
! local pointers to implicit in/out scalars
!
real(r8), pointer :: leafc_to_litter(:)
real(r8), pointer :: frootc_to_litter(:)
real(r8), pointer :: leafn_to_litter(:)
real(r8), pointer :: leafn_to_retransn(:)
real(r8), pointer :: frootn_to_litter(:)
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: p ! indices
integer :: fp ! lake filter pft index
! real(r8):: dt ! decomp timestep (seconds)
!EOP
!-----------------------------------------------------------------------
! assign local pointers to derived type arrays (in)
ivt => clm3%g%l%c%p%itype
bglfr => clm3%g%l%c%p%pepv%bglfr
leafc => clm3%g%l%c%p%pcs%leafc
frootc => clm3%g%l%c%p%pcs%frootc
leafcn => pftcon%leafcn
lflitcn => pftcon%lflitcn
frootcn => pftcon%frootcn
! assign local pointers to derived type arrays (out)
leafc_to_litter => clm3%g%l%c%p%pcf%leafc_to_litter
frootc_to_litter => clm3%g%l%c%p%pcf%frootc_to_litter
leafn_to_litter => clm3%g%l%c%p%pnf%leafn_to_litter
leafn_to_retransn => clm3%g%l%c%p%pnf%leafn_to_retransn
frootn_to_litter => clm3%g%l%c%p%pnf%frootn_to_litter
! set time steps
! dt = real( get_step_size(), r8 )
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! only calculate these fluxes if the background litterfall rate is non-zero
if (bglfr(p) > 0._r8) then
! units for bglfr are already 1/s
leafc_to_litter(p) = bglfr(p) * leafc(p)
frootc_to_litter(p) = bglfr(p) * frootc(p)
! calculate the leaf N litterfall and retranslocation
leafn_to_litter(p) = leafc_to_litter(p) / lflitcn(ivt(p))
leafn_to_retransn(p) = (leafc_to_litter(p) / leafcn(ivt(p))) - leafn_to_litter(p)
! calculate fine root N litterfall (no retranslocation of fine root N)
frootn_to_litter(p) = frootc_to_litter(p) / frootcn(ivt(p))
end if
end do
end subroutine CNBackgroundLitterfall
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNLivewoodTurnover
!
! !INTERFACE:
subroutine CNLivewoodTurnover (num_soilp, filter_soilp) 1,1
!
! !DESCRIPTION:
! Determines the flux of C and N from live wood to
! dead wood pools, for stem and coarse root.
!
! !USES:
!ylu removed
! use clm_time_manager, only: get_step_size
use globals, only: dt
!
! !ARGUMENTS:
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 12/5/03: created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
! pft level
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
! ecophysiological constants
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
real(r8), pointer :: livewdcn(:) ! live wood (phloem and ray parenchyma) C:N (gC/gN)
real(r8), pointer :: deadwdcn(:) ! dead wood (xylem and heartwood) C:N (gC/gN)
!
! local pointers to implicit in/out scalars
!
real(r8), pointer :: livestemc_to_deadstemc(:)
real(r8), pointer :: livecrootc_to_deadcrootc(:)
real(r8), pointer :: livestemn_to_deadstemn(:)
real(r8), pointer :: livestemn_to_retransn(:)
real(r8), pointer :: livecrootn_to_deadcrootn(:)
real(r8), pointer :: livecrootn_to_retransn(:)
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: p ! indices
integer :: fp ! lake filter pft index
! real(r8):: dt ! decomp timestep (seconds)
real(r8):: lwtop ! live wood turnover proportion (annual fraction)
real(r8):: ctovr ! temporary variable for carbon turnover
real(r8):: ntovr ! temporary variable for nitrogen turnover
!EOP
!-----------------------------------------------------------------------
! assign local pointers to derived type arrays (in)
ivt => clm3%g%l%c%p%itype
livestemc => clm3%g%l%c%p%pcs%livestemc
livecrootc => clm3%g%l%c%p%pcs%livecrootc
livestemn => clm3%g%l%c%p%pns%livestemn
livecrootn => clm3%g%l%c%p%pns%livecrootn
woody => pftcon%woody
livewdcn => pftcon%livewdcn
deadwdcn => pftcon%deadwdcn
! assign local pointers to derived type arrays (out)
livestemc_to_deadstemc => clm3%g%l%c%p%pcf%livestemc_to_deadstemc
livecrootc_to_deadcrootc => clm3%g%l%c%p%pcf%livecrootc_to_deadcrootc
livestemn_to_deadstemn => clm3%g%l%c%p%pnf%livestemn_to_deadstemn
livestemn_to_retransn => clm3%g%l%c%p%pnf%livestemn_to_retransn
livecrootn_to_deadcrootn => clm3%g%l%c%p%pnf%livecrootn_to_deadcrootn
livecrootn_to_retransn => clm3%g%l%c%p%pnf%livecrootn_to_retransn
! set time steps
! dt = real( get_step_size(), r8 )
! set the global parameter for livewood turnover rate
! define as an annual fraction (0.7), and convert to fraction per second
lwtop = 0.7_r8 / 31536000.0_r8
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! only calculate these fluxes for woody types
if (woody(ivt(p)) > 0._r8) then
! live stem to dead stem turnover
ctovr = livestemc(p) * lwtop
ntovr = ctovr / livewdcn(ivt(p))
livestemc_to_deadstemc(p) = ctovr
livestemn_to_deadstemn(p) = ctovr / deadwdcn(ivt(p))
livestemn_to_retransn(p) = ntovr - livestemn_to_deadstemn(p)
! live coarse root to dead coarse root turnover
ctovr = livecrootc(p) * lwtop
ntovr = ctovr / livewdcn(ivt(p))
livecrootc_to_deadcrootc(p) = ctovr
livecrootn_to_deadcrootn(p) = ctovr / deadwdcn(ivt(p))
livecrootn_to_retransn(p) = ntovr - livecrootn_to_deadcrootn(p)
end if
end do
end subroutine CNLivewoodTurnover
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNLitterToColumn
!
! !INTERFACE:
subroutine CNLitterToColumn (num_soilc, filter_soilc) 1,2
!
! !DESCRIPTION:
! called at the end of cn_phenology to gather all pft-level litterfall fluxes
! to the column level and assign them to the three litter pools
!
! !USES:
use clm_varpar, only : max_pft_per_col
#ifdef CROP
use pftvarcon , only : npcropmin
#endif
!
! !ARGUMENTS:
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
!
! !CALLED FROM:
! subroutine CNPhenology
!
! !REVISION HISTORY:
! 9/8/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
integer , pointer :: ivt(:) ! pft vegetation type
real(r8), pointer :: wtcol(:) ! weight (relative to column) for this pft (0-1)
real(r8), pointer :: pwtgcell(:) ! weight of pft relative to corresponding gridcell
real(r8), pointer :: leafc_to_litter(:)
real(r8), pointer :: frootc_to_litter(:)
#if (defined CROP)
real(r8), pointer :: livestemc_to_litter(:)
real(r8), pointer :: grainc_to_food(:)
real(r8), pointer :: livestemn_to_litter(:)
real(r8), pointer :: grainn_to_food(:)
#endif
real(r8), pointer :: leafn_to_litter(:)
real(r8), pointer :: frootn_to_litter(:)
real(r8), pointer :: lf_flab(:) ! leaf litter labile fraction
real(r8), pointer :: lf_fcel(:) ! leaf litter cellulose fraction
real(r8), pointer :: lf_flig(:) ! leaf litter lignin fraction
real(r8), pointer :: fr_flab(:) ! fine root litter labile fraction
real(r8), pointer :: fr_fcel(:) ! fine root litter cellulose fraction
real(r8), pointer :: fr_flig(:) ! fine root litter lignin fraction
integer , pointer :: npfts(:) ! number of pfts for each column
integer , pointer :: pfti(:) ! beginning pft index for each column
!
! local pointers to implicit in/out scalars
!
real(r8), pointer :: leafc_to_litr1c(:)
real(r8), pointer :: leafc_to_litr2c(:)
real(r8), pointer :: leafc_to_litr3c(:)
real(r8), pointer :: frootc_to_litr1c(:)
real(r8), pointer :: frootc_to_litr2c(:)
real(r8), pointer :: frootc_to_litr3c(:)
#if (defined CROP)
real(r8), pointer :: livestemc_to_litr1c(:)
real(r8), pointer :: livestemc_to_litr2c(:)
real(r8), pointer :: livestemc_to_litr3c(:)
real(r8), pointer :: livestemn_to_litr1n(:)
real(r8), pointer :: livestemn_to_litr2n(:)
real(r8), pointer :: livestemn_to_litr3n(:)
real(r8), pointer :: grainc_to_litr1c(:)
real(r8), pointer :: grainc_to_litr2c(:)
real(r8), pointer :: grainc_to_litr3c(:)
real(r8), pointer :: grainn_to_litr1n(:)
real(r8), pointer :: grainn_to_litr2n(:)
real(r8), pointer :: grainn_to_litr3n(:)
#endif
real(r8), pointer :: leafn_to_litr1n(:)
real(r8), pointer :: leafn_to_litr2n(:)
real(r8), pointer :: leafn_to_litr3n(:)
real(r8), pointer :: frootn_to_litr1n(:)
real(r8), pointer :: frootn_to_litr2n(:)
real(r8), pointer :: frootn_to_litr3n(:)
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: fc,c,pi,p
!EOP
!-----------------------------------------------------------------------
! assign local pointers to derived type arrays (in)
ivt => clm3%g%l%c%p%itype
wtcol => clm3%g%l%c%p%wtcol
pwtgcell => clm3%g%l%c%p%wtgcell
leafc_to_litter => clm3%g%l%c%p%pcf%leafc_to_litter
frootc_to_litter => clm3%g%l%c%p%pcf%frootc_to_litter
#if (defined CROP)
livestemc_to_litter => clm3%g%l%c%p%pcf%livestemc_to_litter
grainc_to_food => clm3%g%l%c%p%pcf%grainc_to_food
livestemn_to_litter => clm3%g%l%c%p%pnf%livestemn_to_litter
grainn_to_food => clm3%g%l%c%p%pnf%grainn_to_food
#endif
leafn_to_litter => clm3%g%l%c%p%pnf%leafn_to_litter
frootn_to_litter => clm3%g%l%c%p%pnf%frootn_to_litter
npfts => clm3%g%l%c%npfts
pfti => clm3%g%l%c%pfti
lf_flab => pftcon%lf_flab
lf_fcel => pftcon%lf_fcel
lf_flig => pftcon%lf_flig
fr_flab => pftcon%fr_flab
fr_fcel => pftcon%fr_fcel
fr_flig => pftcon%fr_flig
! assign local pointers to derived type arrays (out)
leafc_to_litr1c => clm3%g%l%c%ccf%leafc_to_litr1c
leafc_to_litr2c => clm3%g%l%c%ccf%leafc_to_litr2c
leafc_to_litr3c => clm3%g%l%c%ccf%leafc_to_litr3c
frootc_to_litr1c => clm3%g%l%c%ccf%frootc_to_litr1c
frootc_to_litr2c => clm3%g%l%c%ccf%frootc_to_litr2c
frootc_to_litr3c => clm3%g%l%c%ccf%frootc_to_litr3c
#if (defined CROP)
grainc_to_litr1c => clm3%g%l%c%ccf%grainc_to_litr1c
grainc_to_litr2c => clm3%g%l%c%ccf%grainc_to_litr2c
grainc_to_litr3c => clm3%g%l%c%ccf%grainc_to_litr3c
livestemc_to_litr1c => clm3%g%l%c%ccf%livestemc_to_litr1c
livestemc_to_litr2c => clm3%g%l%c%ccf%livestemc_to_litr2c
livestemc_to_litr3c => clm3%g%l%c%ccf%livestemc_to_litr3c
livestemn_to_litr1n => clm3%g%l%c%cnf%livestemn_to_litr1n
livestemn_to_litr2n => clm3%g%l%c%cnf%livestemn_to_litr2n
livestemn_to_litr3n => clm3%g%l%c%cnf%livestemn_to_litr3n
grainn_to_litr1n => clm3%g%l%c%cnf%grainn_to_litr1n
grainn_to_litr2n => clm3%g%l%c%cnf%grainn_to_litr2n
grainn_to_litr3n => clm3%g%l%c%cnf%grainn_to_litr3n
#endif
leafn_to_litr1n => clm3%g%l%c%cnf%leafn_to_litr1n
leafn_to_litr2n => clm3%g%l%c%cnf%leafn_to_litr2n
leafn_to_litr3n => clm3%g%l%c%cnf%leafn_to_litr3n
frootn_to_litr1n => clm3%g%l%c%cnf%frootn_to_litr1n
frootn_to_litr2n => clm3%g%l%c%cnf%frootn_to_litr2n
frootn_to_litr3n => clm3%g%l%c%cnf%frootn_to_litr3n
do pi = 1,max_pft_per_col
do fc = 1,num_soilc
c = filter_soilc(fc)
if ( pi <= npfts(c) ) then
p = pfti(c) + pi - 1
if (pwtgcell(p)>0._r8) then
! leaf litter carbon fluxes
leafc_to_litr1c(c) = leafc_to_litr1c(c) + leafc_to_litter(p) * lf_flab(ivt(p)) * wtcol(p)
leafc_to_litr2c(c) = leafc_to_litr2c(c) + leafc_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p)
leafc_to_litr3c(c) = leafc_to_litr3c(c) + leafc_to_litter(p) * lf_flig(ivt(p)) * wtcol(p)
! leaf litter nitrogen fluxes
leafn_to_litr1n(c) = leafn_to_litr1n(c) + leafn_to_litter(p) * lf_flab(ivt(p)) * wtcol(p)
leafn_to_litr2n(c) = leafn_to_litr2n(c) + leafn_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p)
leafn_to_litr3n(c) = leafn_to_litr3n(c) + leafn_to_litter(p) * lf_flig(ivt(p)) * wtcol(p)
! fine root litter carbon fluxes
frootc_to_litr1c(c) = frootc_to_litr1c(c) + frootc_to_litter(p) * fr_flab(ivt(p)) * wtcol(p)
frootc_to_litr2c(c) = frootc_to_litr2c(c) + frootc_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p)
frootc_to_litr3c(c) = frootc_to_litr3c(c) + frootc_to_litter(p) * fr_flig(ivt(p)) * wtcol(p)
! fine root litter nitrogen fluxes
frootn_to_litr1n(c) = frootn_to_litr1n(c) + frootn_to_litter(p) * fr_flab(ivt(p)) * wtcol(p)
frootn_to_litr2n(c) = frootn_to_litr2n(c) + frootn_to_litter(p) * fr_fcel(ivt(p)) * wtcol(p)
frootn_to_litr3n(c) = frootn_to_litr3n(c) + frootn_to_litter(p) * fr_flig(ivt(p)) * wtcol(p)
#if (defined CROP)
! agroibis puts crop stem litter together with leaf litter
! so I've used the leaf lf_f* parameters instead of making
! new ones for now (slevis)
! also for simplicity I've put "food" into the litter pools
if (ivt(p) >= npcropmin) then ! add livestemc to litter
! stem litter carbon fluxes
livestemc_to_litr1c(c) = livestemc_to_litr1c(c) + livestemc_to_litter(p) * lf_flab(ivt(p)) * wtcol(p)
livestemc_to_litr2c(c) = livestemc_to_litr2c(c) + livestemc_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p)
livestemc_to_litr3c(c) = livestemc_to_litr3c(c) + livestemc_to_litter(p) * lf_flig(ivt(p)) * wtcol(p)
! stem litter nitrogen fluxes
livestemn_to_litr1n(c) = livestemn_to_litr1n(c) + livestemn_to_litter(p) * lf_flab(ivt(p)) * wtcol(p)
livestemn_to_litr2n(c) = livestemn_to_litr2n(c) + livestemn_to_litter(p) * lf_fcel(ivt(p)) * wtcol(p)
livestemn_to_litr3n(c) = livestemn_to_litr3n(c) + livestemn_to_litter(p) * lf_flig(ivt(p)) * wtcol(p)
! grain litter carbon fluxes
grainc_to_litr1c(c) = grainc_to_litr1c(c) + grainc_to_food(p) * lf_flab(ivt(p)) * wtcol(p)
grainc_to_litr2c(c) = grainc_to_litr2c(c) + grainc_to_food(p) * lf_fcel(ivt(p)) * wtcol(p)
grainc_to_litr3c(c) = grainc_to_litr3c(c) + grainc_to_food(p) * lf_flig(ivt(p)) * wtcol(p)
! grain litter nitrogen fluxes
grainn_to_litr1n(c) = grainn_to_litr1n(c) + grainn_to_food(p) * lf_flab(ivt(p)) * wtcol(p)
grainn_to_litr2n(c) = grainn_to_litr2n(c) + grainn_to_food(p) * lf_fcel(ivt(p)) * wtcol(p)
grainn_to_litr3n(c) = grainn_to_litr3n(c) + grainn_to_food(p) * lf_flig(ivt(p)) * wtcol(p)
end if
#endif
end if
end if
end do
end do
end subroutine CNLitterToColumn
!-----------------------------------------------------------------------
#endif
end module CNPhenologyMod
module CNPrecisionControlMod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNPrecisionControlMod
!
! !DESCRIPTION:
! controls on very low values in critical state variables
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public:: CNPrecisionControl
!
! !REVISION HISTORY:
! 4/23/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNPrecisionControl
!
! !INTERFACE:
subroutine CNPrecisionControl(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,2
!
! !DESCRIPTION:
! On the radiation time step, force leaf and deadstem c and n to 0 if
! they get too small.
!
! !USES:
use clmtype
! use abortutils, only: endrun
! use clm_varctl, only: iulog
use module_cam_support, only: endrun
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 8/1/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
real(r8), pointer :: col_ctrunc(:) ! (gC/m2) column-level sink for C truncation
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: soil1c(:) ! (gC/m2) soil organic matter C (fast pool)
real(r8), pointer :: soil2c(:) ! (gC/m2) soil organic matter C (medium pool)
real(r8), pointer :: soil3c(:) ! (gC/m2) soil organic matter C (slow pool)
real(r8), pointer :: soil4c(:) ! (gC/m2) soil organic matter C (slowest pool)
#if (defined C13)
real(r8), pointer :: c13_col_ctrunc(:) ! (gC/m2) column-level sink for C truncation
real(r8), pointer :: c13_cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: c13_litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: c13_litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: c13_litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: c13_soil1c(:) ! (gC/m2) soil organic matter C (fast pool)
real(r8), pointer :: c13_soil2c(:) ! (gC/m2) soil organic matter C (medium pool)
real(r8), pointer :: c13_soil3c(:) ! (gC/m2) soil organic matter C (slow pool)
real(r8), pointer :: c13_soil4c(:) ! (gC/m2) soil organic matter C (slowest pool)
#endif
real(r8), pointer :: col_ntrunc(:) ! (gN/m2) column-level sink for N truncation
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: litr1n(:) ! (gN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (gN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (gN/m2) litter lignin N
real(r8), pointer :: soil1n(:) ! (gN/m2) soil organic matter N (fast pool)
real(r8), pointer :: soil2n(:) ! (gN/m2) soil organic matter N (medium pool)
real(r8), pointer :: soil3n(:) ! (gN/m2) soil orgainc matter N (slow pool)
real(r8), pointer :: soil4n(:) ! (gN/m2) soil orgainc matter N (slowest pool)
real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation
#if (defined CROP)
real(r8), pointer :: xsmrpool(:) ! (gC/m2) execss maint resp C pool
real(r8), pointer :: grainc(:) ! (gC/m2) grain C
real(r8), pointer :: grainc_storage(:) ! (gC/m2) grain C storage
real(r8), pointer :: grainc_xfer(:) ! (gC/m2) grain C transfer
#if (defined C13)
real(r8), pointer :: c13_xsmrpool(:) ! (gC/m2) execss maint resp C pool
real(r8), pointer :: c13_grainc(:) ! (gC/m2) grain C
real(r8), pointer :: c13_grainc_storage(:) ! (gC/m2) grain C storage
real(r8), pointer :: c13_grainc_xfer(:) ! (gC/m2) grain C transfer
#endif
#endif
#if (defined C13)
real(r8), pointer :: c13_cpool(:) ! (gC/m2) temporary photosynthate C pool
real(r8), pointer :: c13_deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: c13_deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: c13_deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: c13_deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: c13_deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: c13_deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: c13_frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: c13_frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: c13_frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: c13_gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: c13_gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: c13_leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: c13_leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: c13_leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: c13_livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: c13_livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: c13_livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: c13_livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: c13_livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: c13_livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: c13_pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation
#endif
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
#if (defined CROP)
real(r8), pointer :: grainn(:) ! (gC/m2) grain N
real(r8), pointer :: grainn_storage(:) ! (gC/m2) grain N storage
real(r8), pointer :: grainn_xfer(:) ! (gC/m2) grain N transfer
#endif
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool
real(r8), pointer :: pft_ntrunc(:) ! (gN/m2) pft-level sink for N truncation
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
!
! local pointers to implicit in/out scalars
!
! local pointers to implicit out scalars
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
real(r8):: pc,pn ! truncation terms for pft-level corrections
real(r8):: cc,cn ! truncation terms for column-level corrections
#if (defined C13)
real(r8):: pc13 ! truncation terms for pft-level corrections
real(r8):: cc13 ! truncation terms for column-level corrections
#endif
real(r8):: ccrit ! critical carbon state value for truncation
real(r8):: ncrit ! critical nitrogen state value for truncation
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the column level
col_ctrunc => clm3%g%l%c%ccs%col_ctrunc
cwdc => clm3%g%l%c%ccs%cwdc
litr1c => clm3%g%l%c%ccs%litr1c
litr2c => clm3%g%l%c%ccs%litr2c
litr3c => clm3%g%l%c%ccs%litr3c
soil1c => clm3%g%l%c%ccs%soil1c
soil2c => clm3%g%l%c%ccs%soil2c
soil3c => clm3%g%l%c%ccs%soil3c
soil4c => clm3%g%l%c%ccs%soil4c
#if (defined C13)
c13_col_ctrunc => clm3%g%l%c%cc13s%col_ctrunc
c13_cwdc => clm3%g%l%c%cc13s%cwdc
c13_litr1c => clm3%g%l%c%cc13s%litr1c
c13_litr2c => clm3%g%l%c%cc13s%litr2c
c13_litr3c => clm3%g%l%c%cc13s%litr3c
c13_soil1c => clm3%g%l%c%cc13s%soil1c
c13_soil2c => clm3%g%l%c%cc13s%soil2c
c13_soil3c => clm3%g%l%c%cc13s%soil3c
c13_soil4c => clm3%g%l%c%cc13s%soil4c
#endif
col_ntrunc => clm3%g%l%c%cns%col_ntrunc
cwdn => clm3%g%l%c%cns%cwdn
litr1n => clm3%g%l%c%cns%litr1n
litr2n => clm3%g%l%c%cns%litr2n
litr3n => clm3%g%l%c%cns%litr3n
soil1n => clm3%g%l%c%cns%soil1n
soil2n => clm3%g%l%c%cns%soil2n
soil3n => clm3%g%l%c%cns%soil3n
soil4n => clm3%g%l%c%cns%soil4n
! assign local pointers at the pft level
cpool => clm3%g%l%c%p%pcs%cpool
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
deadstemc => clm3%g%l%c%p%pcs%deadstemc
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
frootc => clm3%g%l%c%p%pcs%frootc
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
leafc => clm3%g%l%c%p%pcs%leafc
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
livecrootc => clm3%g%l%c%p%pcs%livecrootc
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
livestemc => clm3%g%l%c%p%pcs%livestemc
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
pft_ctrunc => clm3%g%l%c%p%pcs%pft_ctrunc
#if (defined CROP)
xsmrpool => clm3%g%l%c%p%pcs%xsmrpool
grainc => clm3%g%l%c%p%pcs%grainc
grainc_storage => clm3%g%l%c%p%pcs%grainc_storage
grainc_xfer => clm3%g%l%c%p%pcs%grainc_xfer
#if (defined C13)
c13_xsmrpool => clm3%g%l%c%p%pc13s%xsmrpool
c13_grainc => clm3%g%l%c%p%pc13s%grainc
c13_grainc_storage => clm3%g%l%c%p%pc13s%grainc_storage
c13_grainc_xfer => clm3%g%l%c%p%pc13s%grainc_xfer
#endif
#endif
#if (defined C13)
c13_cpool => clm3%g%l%c%p%pc13s%cpool
c13_deadcrootc => clm3%g%l%c%p%pc13s%deadcrootc
c13_deadcrootc_storage => clm3%g%l%c%p%pc13s%deadcrootc_storage
c13_deadcrootc_xfer => clm3%g%l%c%p%pc13s%deadcrootc_xfer
c13_deadstemc => clm3%g%l%c%p%pc13s%deadstemc
c13_deadstemc_storage => clm3%g%l%c%p%pc13s%deadstemc_storage
c13_deadstemc_xfer => clm3%g%l%c%p%pc13s%deadstemc_xfer
c13_frootc => clm3%g%l%c%p%pc13s%frootc
c13_frootc_storage => clm3%g%l%c%p%pc13s%frootc_storage
c13_frootc_xfer => clm3%g%l%c%p%pc13s%frootc_xfer
c13_gresp_storage => clm3%g%l%c%p%pc13s%gresp_storage
c13_gresp_xfer => clm3%g%l%c%p%pc13s%gresp_xfer
c13_leafc => clm3%g%l%c%p%pc13s%leafc
c13_leafc_storage => clm3%g%l%c%p%pc13s%leafc_storage
c13_leafc_xfer => clm3%g%l%c%p%pc13s%leafc_xfer
c13_livecrootc => clm3%g%l%c%p%pc13s%livecrootc
c13_livecrootc_storage => clm3%g%l%c%p%pc13s%livecrootc_storage
c13_livecrootc_xfer => clm3%g%l%c%p%pc13s%livecrootc_xfer
c13_livestemc => clm3%g%l%c%p%pc13s%livestemc
c13_livestemc_storage => clm3%g%l%c%p%pc13s%livestemc_storage
c13_livestemc_xfer => clm3%g%l%c%p%pc13s%livestemc_xfer
c13_pft_ctrunc => clm3%g%l%c%p%pc13s%pft_ctrunc
#endif
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
deadstemn => clm3%g%l%c%p%pns%deadstemn
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
frootn => clm3%g%l%c%p%pns%frootn
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
leafn => clm3%g%l%c%p%pns%leafn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
livecrootn => clm3%g%l%c%p%pns%livecrootn
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
#if (defined CROP)
grainn => clm3%g%l%c%p%pns%grainn
grainn_storage => clm3%g%l%c%p%pns%grainn_storage
grainn_xfer => clm3%g%l%c%p%pns%grainn_xfer
#endif
livestemn => clm3%g%l%c%p%pns%livestemn
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
npool => clm3%g%l%c%p%pns%npool
pft_ntrunc => clm3%g%l%c%p%pns%pft_ntrunc
retransn => clm3%g%l%c%p%pns%retransn
! set the critical carbon state value for truncation (gC/m2)
ccrit = 1.e-8_r8
! set the critical nitrogen state value for truncation (gN/m2)
ncrit = 1.e-8_r8
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! initialize the pft-level C and N truncation terms
pc = 0._r8
#if (defined C13)
pc13 = 0._r8
#endif
pn = 0._r8
! do tests on state variables for precision control
! for linked C-N state variables, perform precision test on
! the C component, but truncate C, C13, and N components
write(6,*) '******************************************'
write(6,*) 'CHECK cn variables in CNPrecisionControl'
write(6,*) '******************************************'
write(6,*) 'leafc(',p,')=',leafc(p)
write(6,*) 'leafn(',p,')=',leafn(p)
write(6,*) 'leafc_storage(',p,')=',leafc_storage(p)
write(6,*) 'leafn_storage(',p,')=',leafn_storage(p)
write(6,*) 'leafc_xfer(',p,')=',leafc_xfer(p)
write(6,*) 'leafn_xfer(',p,')=',leafn_xfer(p)
write(6,*) 'frootc(',p,')=',frootc(p)
write(6,*) 'frootc_storage(',p,')=',frootc_storage(p)
write(6,*) 'frootn(',p,')=',frootn(p)
write(6,*) 'frootn_storage(',p,')=',frootn_storage(p)
write(6,*) 'frootc_xfer(',p,')=',frootc_xfer(p)
write(6,*) 'frootn_xfer(',p,')=',frootn_xfer(p)
write(6,*) 'grainc(',p,')=',grainc(p)
write(6,*) 'grainc_storage(',p,')=',grainc_storage(p)
write(6,*) 'grainc_xfer(',p,')=',grainc_xfer(p)
write(6,*) 'grainn(',p,')=',grainn(p)
write(6,*) 'grainn_storage(',p,')=',grainn_storage(p)
write(6,*) 'grainn_xfer(',p,')=',grainn_xfer(p)
write(6,*) 'livestemc(',p,')=',livestemc(p)
write(6,*) 'livestemc_storage(',p,')=',livestemc_storage(p)
write(6,*) 'livestemc_xfer(',p,')=',livestemc_xfer(p)
write(6,*) 'livestemn(',p,')=',livestemn(p)
write(6,*) 'livestemn_storage(',p,')=',livestemn_storage(p)
write(6,*) 'livestemn_xfer(',p,')=',livestemn_xfer(p)
write(6,*) 'deadstemc(',p,')=',deadstemc(p)
write(6,*) 'deadstemc_storage(',p,')=',deadstemc_storage(p)
write(6,*) 'deadstemc_xfer(',p,')=',deadstemc_xfer(p)
write(6,*) 'deadstemn(',p,')=',deadstemn(p)
write(6,*) 'deadstemn_storage(',p,')=',deadstemn_storage(p)
write(6,*) 'deadstemn_xfer(',p,')=',deadstemn_xfer(p)
write(6,*) 'livecrootc(',p,')=',livecrootc(p)
write(6,*) 'livecrootc_storage(',p,')=',livecrootc_storage(p)
write(6,*) 'livecrootc_xfer(',p,')=',livecrootc_xfer(p)
write(6,*) 'livecrootn(',p,')=',livecrootn(p)
write(6,*) 'livecrootn_storage(',p,')=',livecrootn_storage(p)
write(6,*) 'livecrootn_xfer(',p,')=',livecrootn_xfer(p)
write(6,*) 'deadcrootc(',p,')=',deadcrootc(p)
write(6,*) 'deadcrootc_storage(',p,')=',deadcrootc_storage(p)
write(6,*) 'deadcrootc_xfer(',p,')=',deadcrootc_xfer(p)
write(6,*) 'deadcrootn(',p,')=',deadcrootn(p)
write(6,*) 'deadcrootn_storage(',p,')=',deadcrootn_storage(p)
write(6,*) 'deadcrootn_xfer(',p,')=',deadcrootn_xfer(p)
write(6,*) 'gresp_storage(',p,')=',gresp_storage(p)
write(6,*) 'gresp_xfer(',p,')=',gresp_xfer(p)
write(6,*) 'cpool(',p,')=',cpool(p)
write(6,*) 'npool(',p,')=',npool(p)
write(6,*) 'xsmrpool(',p,')=',xsmrpool(p)
write(6,*) 'retransn(',p,')=',retransn(p)
write(6,*) '******************************************'
! leaf C and N
if (abs(leafc(p)) < ccrit) then
pc = pc + leafc(p)
leafc(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_leafc(p)
c13_leafc(p) = 0._r8
#endif
pn = pn + leafn(p)
leafn(p) = 0._r8
end if
! leaf storage C and N
if (abs(leafc_storage(p)) < ccrit) then
pc = pc + leafc_storage(p)
leafc_storage(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_leafc_storage(p)
c13_leafc_storage(p) = 0._r8
#endif
pn = pn + leafn_storage(p)
leafn_storage(p) = 0._r8
end if
! leaf transfer C and N
if (abs(leafc_xfer(p)) < ccrit) then
pc = pc + leafc_xfer(p)
leafc_xfer(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_leafc_xfer(p)
c13_leafc_xfer(p) = 0._r8
#endif
pn = pn + leafn_xfer(p)
leafn_xfer(p) = 0._r8
end if
! froot C and N
if (abs(frootc(p)) < ccrit) then
pc = pc + frootc(p)
frootc(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_frootc(p)
c13_frootc(p) = 0._r8
#endif
pn = pn + frootn(p)
frootn(p) = 0._r8
end if
! froot storage C and N
if (abs(frootc_storage(p)) < ccrit) then
pc = pc + frootc_storage(p)
frootc_storage(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_frootc_storage(p)
c13_frootc_storage(p) = 0._r8
#endif
pn = pn + frootn_storage(p)
frootn_storage(p) = 0._r8
end if
! froot transfer C and N
if (abs(frootc_xfer(p)) < ccrit) then
pc = pc + frootc_xfer(p)
frootc_xfer(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_frootc_xfer(p)
c13_frootc_xfer(p) = 0._r8
#endif
pn = pn + frootn_xfer(p)
frootn_xfer(p) = 0._r8
end if
#if (defined CROP)
! grain C and N
if (abs(grainc(p)) < ccrit) then
pc = pc + grainc(p)
grainc(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_grainc(p)
c13_grainc(p) = 0._r8
#endif
pn = pn + grainn(p)
grainn(p) = 0._r8
end if
! grain storage C and N
if (abs(grainc_storage(p)) < ccrit) then
pc = pc + grainc_storage(p)
grainc_storage(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_grainc_storage(p)
c13_grainc_storage(p) = 0._r8
#endif
pn = pn + grainn_storage(p)
grainn_storage(p) = 0._r8
end if
! grain transfer C and N
if (abs(grainc_xfer(p)) < ccrit) then
pc = pc + grainc_xfer(p)
grainc_xfer(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_grainc_xfer(p)
c13_grainc_xfer(p) = 0._r8
#endif
pn = pn + grainn_xfer(p)
grainn_xfer(p) = 0._r8
end if
#endif
! livestem C and N
if (abs(livestemc(p)) < ccrit) then
pc = pc + livestemc(p)
livestemc(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_livestemc(p)
c13_livestemc(p) = 0._r8
#endif
pn = pn + livestemn(p)
livestemn(p) = 0._r8
end if
! livestem storage C and N
if (abs(livestemc_storage(p)) < ccrit) then
pc = pc + livestemc_storage(p)
livestemc_storage(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_livestemc_storage(p)
c13_livestemc_storage(p) = 0._r8
#endif
pn = pn + livestemn_storage(p)
livestemn_storage(p) = 0._r8
end if
! livestem transfer C and N
if (abs(livestemc_xfer(p)) < ccrit) then
pc = pc + livestemc_xfer(p)
livestemc_xfer(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_livestemc_xfer(p)
c13_livestemc_xfer(p) = 0._r8
#endif
pn = pn + livestemn_xfer(p)
livestemn_xfer(p) = 0._r8
end if
! deadstem C and N
if (abs(deadstemc(p)) < ccrit) then
pc = pc + deadstemc(p)
deadstemc(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_deadstemc(p)
c13_deadstemc(p) = 0._r8
#endif
pn = pn + deadstemn(p)
deadstemn(p) = 0._r8
end if
! deadstem storage C and N
if (abs(deadstemc_storage(p)) < ccrit) then
pc = pc + deadstemc_storage(p)
deadstemc_storage(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_deadstemc_storage(p)
c13_deadstemc_storage(p) = 0._r8
#endif
pn = pn + deadstemn_storage(p)
deadstemn_storage(p) = 0._r8
end if
! deadstem transfer C and N
if (abs(deadstemc_xfer(p)) < ccrit) then
pc = pc + deadstemc_xfer(p)
deadstemc_xfer(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_deadstemc_xfer(p)
c13_deadstemc_xfer(p) = 0._r8
#endif
pn = pn + deadstemn_xfer(p)
deadstemn_xfer(p) = 0._r8
end if
! livecroot C and N
if (abs(livecrootc(p)) < ccrit) then
pc = pc + livecrootc(p)
livecrootc(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_livecrootc(p)
c13_livecrootc(p) = 0._r8
#endif
pn = pn + livecrootn(p)
livecrootn(p) = 0._r8
end if
! livecroot storage C and N
if (abs(livecrootc_storage(p)) < ccrit) then
pc = pc + livecrootc_storage(p)
livecrootc_storage(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_livecrootc_storage(p)
c13_livecrootc_storage(p) = 0._r8
#endif
pn = pn + livecrootn_storage(p)
livecrootn_storage(p) = 0._r8
end if
! livecroot transfer C and N
if (abs(livecrootc_xfer(p)) < ccrit) then
pc = pc + livecrootc_xfer(p)
livecrootc_xfer(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_livecrootc_xfer(p)
c13_livecrootc_xfer(p) = 0._r8
#endif
pn = pn + livecrootn_xfer(p)
livecrootn_xfer(p) = 0._r8
end if
! deadcroot C and N
if (abs(deadcrootc(p)) < ccrit) then
pc = pc + deadcrootc(p)
deadcrootc(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_deadcrootc(p)
c13_deadcrootc(p) = 0._r8
#endif
pn = pn + deadcrootn(p)
deadcrootn(p) = 0._r8
end if
! deadcroot storage C and N
if (abs(deadcrootc_storage(p)) < ccrit) then
pc = pc + deadcrootc_storage(p)
deadcrootc_storage(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_deadcrootc_storage(p)
c13_deadcrootc_storage(p) = 0._r8
#endif
pn = pn + deadcrootn_storage(p)
deadcrootn_storage(p) = 0._r8
end if
! deadcroot transfer C and N
if (abs(deadcrootc_xfer(p)) < ccrit) then
pc = pc + deadcrootc_xfer(p)
deadcrootc_xfer(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_deadcrootc_xfer(p)
c13_deadcrootc_xfer(p) = 0._r8
#endif
pn = pn + deadcrootn_xfer(p)
deadcrootn_xfer(p) = 0._r8
end if
! gresp_storage (C only)
if (abs(gresp_storage(p)) < ccrit) then
pc = pc + gresp_storage(p)
gresp_storage(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_gresp_storage(p)
c13_gresp_storage(p) = 0._r8
#endif
end if
! gresp_xfer (C only)
if (abs(gresp_xfer(p)) < ccrit) then
pc = pc + gresp_xfer(p)
gresp_xfer(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_gresp_xfer(p)
c13_gresp_xfer(p) = 0._r8
#endif
end if
! cpool (C only)
if (abs(cpool(p)) < ccrit) then
pc = pc + cpool(p)
cpool(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_cpool(p)
c13_cpool(p) = 0._r8
#endif
end if
#if (defined CROP)
! xsmrpool (C only)
if (abs(xsmrpool(p)) < ccrit) then
pc = pc + xsmrpool(p)
xsmrpool(p) = 0._r8
#if (defined C13)
pc13 = pc13 + c13_xsmrpool(p)
c13_xsmrpool(p) = 0._r8
#endif
end if
#endif
! retransn (N only)
if (abs(retransn(p)) < ncrit) then
pn = pn + retransn(p)
retransn(p) = 0._r8
end if
! npool (N only)
if (abs(npool(p)) < ncrit) then
pn = pn + npool(p)
npool(p) = 0._r8
end if
write(6,*) 'before pft_ctrunc(',p,')=',pft_ctrunc(p)
pft_ctrunc(p) = pft_ctrunc(p) + pc
write(6,*) 'in CNPrecisionControl,check pft_ctrunc'
write(6,*) 'pc=',pc
write(6,*) 'after pft_ctrunc(',p,')=',pft_ctrunc(p)
#if (defined C13)
c13_pft_ctrunc(p) = c13_pft_ctrunc(p) + pc13
#endif
pft_ntrunc(p) = pft_ntrunc(p) + pn
end do ! end of pft loop
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! initialize the column-level C and N truncation terms
cc = 0._r8
#if (defined C13)
cc13 = 0._r8
#endif
cn = 0._r8
! do tests on state variables for precision control
! for linked C-N state variables, perform precision test on
! the C component, but truncate both C and N components
! coarse woody debris C and N
if (abs(cwdc(c)) < ccrit) then
cc = cc + cwdc(c)
cwdc(c) = 0._r8
#if (defined C13)
cc13 = cc13 + c13_cwdc(c)
c13_cwdc(c) = 0._r8
#endif
cn = cn + cwdn(c)
cwdn(c) = 0._r8
end if
! litr1 C and N
if (abs(litr1c(c)) < ccrit) then
cc = cc + litr1c(c)
litr1c(c) = 0._r8
#if (defined C13)
cc13 = cc13 + c13_litr1c(c)
c13_litr1c(c) = 0._r8
#endif
cn = cn + litr1n(c)
litr1n(c) = 0._r8
end if
! litr2 C and N
if (abs(litr2c(c)) < ccrit) then
cc = cc + litr2c(c)
litr2c(c) = 0._r8
#if (defined C13)
cc13 = cc13 + c13_litr2c(c)
c13_litr2c(c) = 0._r8
#endif
cn = cn + litr2n(c)
litr2n(c) = 0._r8
end if
! litr3 C and N
if (abs(litr3c(c)) < ccrit) then
cc = cc + litr3c(c)
litr3c(c) = 0._r8
#if (defined C13)
cc13 = cc13 + c13_litr3c(c)
c13_litr3c(c) = 0._r8
#endif
cn = cn + litr3n(c)
litr3n(c) = 0._r8
end if
! soil1 C and N
if (abs(soil1c(c)) < ccrit) then
cc = cc + soil1c(c)
soil1c(c) = 0._r8
#if (defined C13)
cc13 = cc13 + c13_soil1c(c)
c13_soil1c(c) = 0._r8
#endif
cn = cn + soil1n(c)
soil1n(c) = 0._r8
end if
! soil2 C and N
if (abs(soil2c(c)) < ccrit) then
cc = cc + soil2c(c)
soil2c(c) = 0._r8
#if (defined C13)
cc13 = cc13 + c13_soil2c(c)
c13_soil2c(c) = 0._r8
#endif
cn = cn + soil2n(c)
soil2n(c) = 0._r8
end if
! soil3 C and N
if (abs(soil3c(c)) < ccrit) then
cc = cc + soil3c(c)
soil3c(c) = 0._r8
#if (defined C13)
cc13 = cc13 + c13_soil3c(c)
c13_soil3c(c) = 0._r8
#endif
cn = cn + soil3n(c)
soil3n(c) = 0._r8
end if
! soil4 C and N
if (abs(soil4c(c)) < ccrit) then
cc = cc + soil4c(c)
soil4c(c) = 0._r8
#if (defined C13)
cc13 = cc13 + c13_soil4c(c)
c13_soil4c(c) = 0._r8
#endif
cn = cn + soil4n(c)
soil4n(c) = 0._r8
end if
! not doing precision control on soil mineral N, since it will
! be getting the N truncation flux anyway.
col_ctrunc(c) = col_ctrunc(c) + cc
#if (defined C13)
c13_col_ctrunc(c) = c13_col_ctrunc(c) + cc13
#endif
col_ntrunc(c) = col_ntrunc(c) + cn
end do ! end of column loop
end subroutine CNPrecisionControl
!-----------------------------------------------------------------------
#endif
end module CNPrecisionControlMod
module CNSummaryMod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNSummaryMod
!
! !DESCRIPTION:
! Module for carbon and nitrogen summary calculations
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: CSummary
public :: NSummary
!
! !REVISION HISTORY:
! 4/23/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CSummary
!
! !INTERFACE:
subroutine CSummary(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,13
!
! !DESCRIPTION:
! On the radiation time step, perform pft and column-level carbon
! summary calculations
!
! !USES:
use clmtype
!ylu changed
! use pft2colMod, only: p2c
use subgridAveMod, only : p2c
!ylu remove
! use clm_varctl, only: iulog
! use shr_sys_mod, only: shr_sys_flush
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 12/9/03: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
real(r8), pointer :: col_fire_closs(:) ! (gC/m2/s) total column-level fire C loss
real(r8), pointer :: er(:) ! (gC/m2/s) total ecosystem respiration, autotrophic + heterotrophic
real(r8), pointer :: hr(:) ! (gC/m2/s) total heterotrophic respiration
real(r8), pointer :: litfire(:) ! (gC/m2/s) litter fire losses
real(r8), pointer :: lithr(:) ! (gC/m2/s) litter heterotrophic respiration
real(r8), pointer :: litr1_hr(:)
real(r8), pointer :: litr2_hr(:)
real(r8), pointer :: litr3_hr(:)
real(r8), pointer :: m_cwdc_to_fire(:)
real(r8), pointer :: m_litr1c_to_fire(:)
real(r8), pointer :: m_litr2c_to_fire(:)
real(r8), pointer :: m_litr3c_to_fire(:)
real(r8), pointer :: nee(:) ! (gC/m2/s) net ecosystem exchange of carbon, includes fire, land-use, harvest, and hrv_xsmrpool flux, positive for source
real(r8), pointer :: nep(:) ! (gC/m2/s) net ecosystem production, excludes fire, land-use, and harvest flux, positive for sink
real(r8), pointer :: nbp(:) ! (gC/m2/s) net biome production, includes fire, land-use, and harvest flux, positive for sink
real(r8), pointer :: col_ar(:) ! (gC/m2/s) autotrophic respiration (MR + GR)
real(r8), pointer :: col_gpp(:) ! GPP flux before downregulation (gC/m2/s)
real(r8), pointer :: col_npp(:) ! (gC/m2/s) net primary production
real(r8), pointer :: col_pft_fire_closs(:) ! (gC/m2/s) total pft-level fire C loss
real(r8), pointer :: col_litfall(:) ! (gC/m2/s) total pft-level litterfall C loss
real(r8), pointer :: col_rr(:) ! (gC/m2/s) root respiration (fine root MR + total root GR)
real(r8), pointer :: col_vegfire(:) ! (gC/m2/s) pft-level fire loss (obsolete, mark for removal)
real(r8), pointer :: col_wood_harvestc(:)
real(r8), pointer :: soil1_hr(:)
real(r8), pointer :: soil2_hr(:)
real(r8), pointer :: soil3_hr(:)
real(r8), pointer :: soil4_hr(:)
real(r8), pointer :: somfire(:) ! (gC/m2/s) soil organic matter fire losses
real(r8), pointer :: somhr(:) ! (gC/m2/s) soil organic matter heterotrophic respiration
real(r8), pointer :: sr(:) ! (gC/m2/s) total soil respiration (HR + root resp)
real(r8), pointer :: totfire(:) ! (gC/m2/s) total ecosystem fire losses
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: col_totpftc(:) ! (gC/m2) total pft-level carbon, including cpool
real(r8), pointer :: col_totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool
real(r8), pointer :: soil1c(:) ! (gC/m2) soil organic matter C (fast pool)
real(r8), pointer :: soil2c(:) ! (gC/m2) soil organic matter C (medium pool)
real(r8), pointer :: soil3c(:) ! (gC/m2) soil organic matter C (slow pool)
real(r8), pointer :: soil4c(:) ! (gC/m2) soil organic matter C (slowest pool)
real(r8), pointer :: col_ctrunc(:) ! (gC/m2) column-level sink for C truncation
real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool
real(r8), pointer :: totecosysc(:) ! (gC/m2) total ecosystem carbon, incl veg but excl cpool
real(r8), pointer :: totlitc(:) ! (gC/m2) total litter carbon
real(r8), pointer :: totsomc(:) ! (gC/m2) total soil organic matter carbon
real(r8), pointer :: agnpp(:) ! (gC/m2/s) aboveground NPP
real(r8), pointer :: ar(:) ! (gC/m2/s) autotrophic respiration (MR + GR)
real(r8), pointer :: bgnpp(:) ! (gC/m2/s) belowground NPP
#if (defined CROP)
real(r8), pointer :: xsmrpool_to_atm(:)
real(r8), pointer :: cpool_grain_gr(:)
real(r8), pointer :: cpool_grain_storage_gr(:)
real(r8), pointer :: cpool_to_grainc(:)
real(r8), pointer :: grainc_xfer_to_grainc(:)
real(r8), pointer :: transfer_grain_gr(:)
real(r8), pointer :: grainc_to_food(:)
real(r8), pointer :: livestemc_to_litter(:)
real(r8), pointer :: grainc(:) ! (gC/m2) grain C
real(r8), pointer :: grainc_storage(:) ! (gC/m2) grain C storage
real(r8), pointer :: grainc_xfer(:) ! (gC/m2) grain C transfer
#endif
real(r8), pointer :: cpool_deadcroot_gr(:)
real(r8), pointer :: cpool_deadcroot_storage_gr(:)
real(r8), pointer :: cpool_deadstem_gr(:)
real(r8), pointer :: cpool_deadstem_storage_gr(:)
real(r8), pointer :: cpool_froot_gr(:)
real(r8), pointer :: cpool_froot_storage_gr(:)
real(r8), pointer :: cpool_leaf_gr(:)
real(r8), pointer :: cpool_leaf_storage_gr(:)
real(r8), pointer :: cpool_livecroot_gr(:)
real(r8), pointer :: cpool_livecroot_storage_gr(:)
real(r8), pointer :: cpool_livestem_gr(:)
real(r8), pointer :: cpool_livestem_storage_gr(:)
real(r8), pointer :: cpool_to_deadcrootc(:)
real(r8), pointer :: cpool_to_deadstemc(:)
real(r8), pointer :: cpool_to_frootc(:)
real(r8), pointer :: cpool_to_leafc(:)
real(r8), pointer :: cpool_to_livecrootc(:)
real(r8), pointer :: cpool_to_livestemc(:)
real(r8), pointer :: current_gr(:) ! (gC/m2/s) growth resp for new growth displayed in this timestep
real(r8), pointer :: deadcrootc_xfer_to_deadcrootc(:)
real(r8), pointer :: deadstemc_xfer_to_deadstemc(:)
real(r8), pointer :: frootc_to_litter(:)
real(r8), pointer :: frootc_xfer_to_frootc(:)
real(r8), pointer :: froot_mr(:)
real(r8), pointer :: gpp(:) !GPP flux before downregulation (gC/m2/s)
real(r8), pointer :: gr(:) ! (gC/m2/s) total growth respiration
real(r8), pointer :: leafc_to_litter(:)
real(r8), pointer :: leafc_xfer_to_leafc(:)
real(r8), pointer :: leaf_mr(:)
real(r8), pointer :: litfall(:) ! (gC/m2/s) litterfall (leaves and fine roots)
real(r8), pointer :: livecrootc_xfer_to_livecrootc(:)
real(r8), pointer :: livecroot_mr(:)
real(r8), pointer :: livestemc_xfer_to_livestemc(:)
real(r8), pointer :: livestem_mr(:)
real(r8), pointer :: m_deadcrootc_storage_to_fire(:)
real(r8), pointer :: m_deadcrootc_storage_to_litter(:)
real(r8), pointer :: m_deadcrootc_to_fire(:)
real(r8), pointer :: m_deadcrootc_to_litter(:)
real(r8), pointer :: m_deadcrootc_to_litter_fire(:)
real(r8), pointer :: m_deadcrootc_xfer_to_fire(:)
real(r8), pointer :: m_deadcrootc_xfer_to_litter(:)
real(r8), pointer :: m_deadstemc_storage_to_fire(:)
real(r8), pointer :: m_deadstemc_storage_to_litter(:)
real(r8), pointer :: m_deadstemc_to_fire(:)
real(r8), pointer :: m_deadstemc_to_litter(:)
real(r8), pointer :: m_deadstemc_to_litter_fire(:)
real(r8), pointer :: m_deadstemc_xfer_to_fire(:)
real(r8), pointer :: m_deadstemc_xfer_to_litter(:)
real(r8), pointer :: m_frootc_storage_to_fire(:)
real(r8), pointer :: m_frootc_storage_to_litter(:)
real(r8), pointer :: m_frootc_to_fire(:)
real(r8), pointer :: m_frootc_to_litter(:)
real(r8), pointer :: m_frootc_xfer_to_fire(:)
real(r8), pointer :: m_frootc_xfer_to_litter(:)
real(r8), pointer :: m_gresp_storage_to_fire(:)
real(r8), pointer :: m_gresp_storage_to_litter(:)
real(r8), pointer :: m_gresp_xfer_to_fire(:)
real(r8), pointer :: m_gresp_xfer_to_litter(:)
real(r8), pointer :: m_leafc_storage_to_fire(:)
real(r8), pointer :: m_leafc_storage_to_litter(:)
real(r8), pointer :: m_leafc_to_fire(:)
real(r8), pointer :: m_leafc_to_litter(:)
real(r8), pointer :: m_leafc_xfer_to_fire(:)
real(r8), pointer :: m_leafc_xfer_to_litter(:)
real(r8), pointer :: m_livecrootc_storage_to_fire(:)
real(r8), pointer :: m_livecrootc_storage_to_litter(:)
real(r8), pointer :: m_livecrootc_to_fire(:)
real(r8), pointer :: m_livecrootc_to_litter(:)
real(r8), pointer :: m_livecrootc_xfer_to_fire(:)
real(r8), pointer :: m_livecrootc_xfer_to_litter(:)
real(r8), pointer :: m_livestemc_storage_to_fire(:)
real(r8), pointer :: m_livestemc_storage_to_litter(:)
real(r8), pointer :: m_livestemc_to_fire(:)
real(r8), pointer :: m_livestemc_to_litter(:)
real(r8), pointer :: m_livestemc_xfer_to_fire(:)
real(r8), pointer :: m_livestemc_xfer_to_litter(:)
real(r8), pointer :: hrv_leafc_to_litter(:)
real(r8), pointer :: hrv_leafc_storage_to_litter(:)
real(r8), pointer :: hrv_leafc_xfer_to_litter(:)
real(r8), pointer :: hrv_frootc_to_litter(:)
real(r8), pointer :: hrv_frootc_storage_to_litter(:)
real(r8), pointer :: hrv_frootc_xfer_to_litter(:)
real(r8), pointer :: hrv_livestemc_to_litter(:)
real(r8), pointer :: hrv_livestemc_storage_to_litter(:)
real(r8), pointer :: hrv_livestemc_xfer_to_litter(:)
real(r8), pointer :: hrv_deadstemc_to_prod10c(:)
real(r8), pointer :: hrv_deadstemc_to_prod100c(:)
real(r8), pointer :: hrv_deadstemc_storage_to_litter(:)
real(r8), pointer :: hrv_deadstemc_xfer_to_litter(:)
real(r8), pointer :: hrv_livecrootc_to_litter(:)
real(r8), pointer :: hrv_livecrootc_storage_to_litter(:)
real(r8), pointer :: hrv_livecrootc_xfer_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_storage_to_litter(:)
real(r8), pointer :: hrv_deadcrootc_xfer_to_litter(:)
real(r8), pointer :: hrv_gresp_storage_to_litter(:)
real(r8), pointer :: hrv_gresp_xfer_to_litter(:)
real(r8), pointer :: hrv_xsmrpool_to_atm(:)
real(r8), pointer :: col_hrv_xsmrpool_to_atm(:)
real(r8), pointer :: mr(:) ! (gC/m2/s) maintenance respiration
real(r8), pointer :: npp(:) ! (gC/m2/s) net primary production
real(r8), pointer :: pft_fire_closs(:) ! (gC/m2/s) total pft-level fire C loss
real(r8), pointer :: psnshade_to_cpool(:)
real(r8), pointer :: psnsun_to_cpool(:)
real(r8), pointer :: rr(:) ! (gC/m2/s) root respiration (fine root MR + total root GR)
real(r8), pointer :: storage_gr(:) ! (gC/m2/s) growth resp for growth sent to storage for later display
real(r8), pointer :: transfer_deadcroot_gr(:)
real(r8), pointer :: transfer_deadstem_gr(:)
real(r8), pointer :: transfer_froot_gr(:)
real(r8), pointer :: transfer_gr(:) ! (gC/m2/s) growth resp for transfer growth displayed in this timestep
real(r8), pointer :: transfer_leaf_gr(:)
real(r8), pointer :: transfer_livecroot_gr(:)
real(r8), pointer :: transfer_livestem_gr(:)
real(r8), pointer :: wood_harvestc(:) ! (gC/m2/s) pft-level wood harvest (to product pools)
real(r8), pointer :: vegfire(:) ! (gC/m2/s) pft-level fire loss (obsolete, mark for removal)
real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool
real(r8), pointer :: xsmrpool(:) ! (gC/m2) temporary photosynthate C pool
real(r8), pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: dispvegc(:) ! (gC/m2) displayed veg carbon, excluding storage and cpool
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: storvegc(:) ! (gC/m2) stored vegetation carbon, excluding cpool
real(r8), pointer :: totpftc(:) ! (gC/m2) total pft-level carbon, including cpool
real(r8), pointer :: totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool
real(r8), pointer :: tempsum_npp(:) ! temporary annual sum of NPP (gC/m2/yr)
#if (defined CNDV)
real(r8), pointer :: tempsum_litfall(:) !temporary annual sum of litfall (gC/m2/yr)
#endif
! for landcover change
real(r8), pointer :: landuseflux(:) ! (gC/m2/s) dwt_closs+product_closs
real(r8), pointer :: landuptake(:) ! (gC/m2/s) nee-landuseflux
real(r8), pointer :: dwt_closs(:) ! (gC/m2/s) total carbon loss from land cover conversion
real(r8), pointer :: dwt_conv_cflux(:) ! (gC/m2/s) conversion C flux (immediate loss to atm)
real(r8), pointer :: prod10c_loss(:) ! (gC/m2/s) loss from 10-yr wood product pool
real(r8), pointer :: prod100c_loss(:) ! (gC/m2/s) loss from 100-yr wood product pool
real(r8), pointer :: product_closs(:) ! (gC/m2/s) total wood product carbon loss
real(r8), pointer :: seedc(:) ! (gC/m2) column-level pool for seeding new PFTs
real(r8), pointer :: prod10c(:) ! (gC/m2) wood product C pool, 10-year lifespan
real(r8), pointer :: prod100c(:) ! (gC/m2) wood product C pool, 100-year lifespan
real(r8), pointer :: totprodc(:) ! (gC/m2) total wood product C
#if (defined CLAMP)
! CLAMP
real(r8), pointer :: frootc_alloc(:) ! fine root C allocation (gC/m2/s)
real(r8), pointer :: frootc_loss(:) ! fine root C loss (gC/m2/s)
real(r8), pointer :: leafc_alloc(:) ! leaf C allocation (gC/m2/s)
real(r8), pointer :: leafc_loss(:) ! leaf C loss (gC/m2/s)
real(r8), pointer :: woodc(:) ! wood C (gC/m2)
real(r8), pointer :: woodc_alloc(:) ! wood C allocation (gC/m2/s)
real(r8), pointer :: woodc_loss(:) ! wood C loss (gC/m2/s)
real(r8), pointer :: cwdc_hr(:) ! coarse woody debris C heterotrophic respiration (gC/m2/s)
real(r8), pointer :: cwdc_loss(:) ! coarse woody debris C loss (gC/m2/s)
real(r8), pointer :: litterc_loss(:) ! litter C loss (gC/m2/s)
real(r8), pointer :: litr1c_to_soil1c(:) ! litter1 C loss to soil1 (gC/m2/s)
real(r8), pointer :: litr2c_to_soil2c(:) ! litter2 C loss to soil2 (gC/m2/s)
real(r8), pointer :: litr3c_to_soil3c(:) ! litter3 C loss to soil3 (gC/m2/s)
! Added for CLAMP
real(r8), pointer :: cwdc_to_litr2c(:) ! cwdc C to soil2 (gC/m2/s)
real(r8), pointer :: cwdc_to_litr3c(:) ! cwdc C to soil3 (gC/m2/s)
#endif
!
!
! local pointers to implicit in/out scalars
!
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
!EOP
!-----------------------------------------------------------------------
! assign local pointers
col_fire_closs => clm3%g%l%c%ccf%col_fire_closs
er => clm3%g%l%c%ccf%er
hr => clm3%g%l%c%ccf%hr
litfire => clm3%g%l%c%ccf%litfire
lithr => clm3%g%l%c%ccf%lithr
litr1_hr => clm3%g%l%c%ccf%litr1_hr
litr2_hr => clm3%g%l%c%ccf%litr2_hr
litr3_hr => clm3%g%l%c%ccf%litr3_hr
m_cwdc_to_fire => clm3%g%l%c%ccf%m_cwdc_to_fire
m_litr1c_to_fire => clm3%g%l%c%ccf%m_litr1c_to_fire
m_litr2c_to_fire => clm3%g%l%c%ccf%m_litr2c_to_fire
m_litr3c_to_fire => clm3%g%l%c%ccf%m_litr3c_to_fire
#if (defined CLAMP)
! Added for CLAMP
cwdc_to_litr2c => clm3%g%l%c%ccf%cwdc_to_litr2c
cwdc_to_litr3c => clm3%g%l%c%ccf%cwdc_to_litr3c
! CLAMP
litr1c_to_soil1c => clm3%g%l%c%ccf%litr1c_to_soil1c
litr2c_to_soil2c => clm3%g%l%c%ccf%litr2c_to_soil2c
litr3c_to_soil3c => clm3%g%l%c%ccf%litr3c_to_soil3c
#endif
nee => clm3%g%l%c%ccf%nee
nep => clm3%g%l%c%ccf%nep
nbp => clm3%g%l%c%ccf%nbp
col_ar => clm3%g%l%c%ccf%pcf_a%ar
col_gpp => clm3%g%l%c%ccf%pcf_a%gpp
col_npp => clm3%g%l%c%ccf%pcf_a%npp
col_pft_fire_closs => clm3%g%l%c%ccf%pcf_a%pft_fire_closs
col_litfall => clm3%g%l%c%ccf%pcf_a%litfall
col_rr => clm3%g%l%c%ccf%pcf_a%rr
col_vegfire => clm3%g%l%c%ccf%pcf_a%vegfire
col_wood_harvestc => clm3%g%l%c%ccf%pcf_a%wood_harvestc
soil1_hr => clm3%g%l%c%ccf%soil1_hr
soil2_hr => clm3%g%l%c%ccf%soil2_hr
soil3_hr => clm3%g%l%c%ccf%soil3_hr
soil4_hr => clm3%g%l%c%ccf%soil4_hr
somfire => clm3%g%l%c%ccf%somfire
somhr => clm3%g%l%c%ccf%somhr
sr => clm3%g%l%c%ccf%sr
totfire => clm3%g%l%c%ccf%totfire
#if (defined CLAMP)
cwdc_hr => clm3%g%l%c%ccf%cwdc_hr
cwdc_loss => clm3%g%l%c%ccf%cwdc_loss
litterc_loss => clm3%g%l%c%ccf%litterc_loss
#endif
! dynamic landcover pointers
dwt_closs => clm3%g%l%c%ccf%dwt_closs
landuseflux => clm3%g%l%c%ccf%landuseflux
landuptake => clm3%g%l%c%ccf%landuptake
dwt_conv_cflux => clm3%g%l%c%ccf%dwt_conv_cflux
seedc => clm3%g%l%c%ccs%seedc
! wood product pointers
prod10c_loss => clm3%g%l%c%ccf%prod10c_loss
prod100c_loss => clm3%g%l%c%ccf%prod100c_loss
product_closs => clm3%g%l%c%ccf%product_closs
prod10c => clm3%g%l%c%ccs%prod10c
prod100c => clm3%g%l%c%ccs%prod100c
totprodc => clm3%g%l%c%ccs%totprodc
cwdc => clm3%g%l%c%ccs%cwdc
litr1c => clm3%g%l%c%ccs%litr1c
litr2c => clm3%g%l%c%ccs%litr2c
litr3c => clm3%g%l%c%ccs%litr3c
col_totpftc => clm3%g%l%c%ccs%pcs_a%totpftc
col_totvegc => clm3%g%l%c%ccs%pcs_a%totvegc
soil1c => clm3%g%l%c%ccs%soil1c
soil2c => clm3%g%l%c%ccs%soil2c
soil3c => clm3%g%l%c%ccs%soil3c
soil4c => clm3%g%l%c%ccs%soil4c
col_ctrunc => clm3%g%l%c%ccs%col_ctrunc
totcolc => clm3%g%l%c%ccs%totcolc
totecosysc => clm3%g%l%c%ccs%totecosysc
totlitc => clm3%g%l%c%ccs%totlitc
totsomc => clm3%g%l%c%ccs%totsomc
agnpp => clm3%g%l%c%p%pcf%agnpp
ar => clm3%g%l%c%p%pcf%ar
bgnpp => clm3%g%l%c%p%pcf%bgnpp
#if (defined CROP)
xsmrpool_to_atm => clm3%g%l%c%p%pcf%xsmrpool_to_atm
cpool_grain_gr => clm3%g%l%c%p%pcf%cpool_grain_gr
cpool_grain_storage_gr => clm3%g%l%c%p%pcf%cpool_grain_storage_gr
cpool_to_grainc => clm3%g%l%c%p%pcf%cpool_to_grainc
grainc_xfer_to_grainc => clm3%g%l%c%p%pcf%grainc_xfer_to_grainc
transfer_grain_gr => clm3%g%l%c%p%pcf%transfer_grain_gr
grainc_to_food => clm3%g%l%c%p%pcf%grainc_to_food
livestemc_to_litter => clm3%g%l%c%p%pcf%livestemc_to_litter
grainc => clm3%g%l%c%p%pcs%grainc
grainc_storage => clm3%g%l%c%p%pcs%grainc_storage
grainc_xfer => clm3%g%l%c%p%pcs%grainc_xfer
#endif
cpool_deadcroot_gr => clm3%g%l%c%p%pcf%cpool_deadcroot_gr
cpool_deadcroot_storage_gr => clm3%g%l%c%p%pcf%cpool_deadcroot_storage_gr
cpool_deadstem_gr => clm3%g%l%c%p%pcf%cpool_deadstem_gr
cpool_deadstem_storage_gr => clm3%g%l%c%p%pcf%cpool_deadstem_storage_gr
cpool_froot_gr => clm3%g%l%c%p%pcf%cpool_froot_gr
cpool_froot_storage_gr => clm3%g%l%c%p%pcf%cpool_froot_storage_gr
cpool_leaf_gr => clm3%g%l%c%p%pcf%cpool_leaf_gr
cpool_leaf_storage_gr => clm3%g%l%c%p%pcf%cpool_leaf_storage_gr
cpool_livecroot_gr => clm3%g%l%c%p%pcf%cpool_livecroot_gr
cpool_livecroot_storage_gr => clm3%g%l%c%p%pcf%cpool_livecroot_storage_gr
cpool_livestem_gr => clm3%g%l%c%p%pcf%cpool_livestem_gr
cpool_livestem_storage_gr => clm3%g%l%c%p%pcf%cpool_livestem_storage_gr
cpool_to_deadcrootc => clm3%g%l%c%p%pcf%cpool_to_deadcrootc
cpool_to_deadstemc => clm3%g%l%c%p%pcf%cpool_to_deadstemc
cpool_to_frootc => clm3%g%l%c%p%pcf%cpool_to_frootc
cpool_to_leafc => clm3%g%l%c%p%pcf%cpool_to_leafc
cpool_to_livecrootc => clm3%g%l%c%p%pcf%cpool_to_livecrootc
cpool_to_livestemc => clm3%g%l%c%p%pcf%cpool_to_livestemc
current_gr => clm3%g%l%c%p%pcf%current_gr
deadcrootc_xfer_to_deadcrootc => clm3%g%l%c%p%pcf%deadcrootc_xfer_to_deadcrootc
deadstemc_xfer_to_deadstemc => clm3%g%l%c%p%pcf%deadstemc_xfer_to_deadstemc
frootc_to_litter => clm3%g%l%c%p%pcf%frootc_to_litter
frootc_xfer_to_frootc => clm3%g%l%c%p%pcf%frootc_xfer_to_frootc
froot_mr => clm3%g%l%c%p%pcf%froot_mr
gpp => clm3%g%l%c%p%pcf%gpp
gr => clm3%g%l%c%p%pcf%gr
leafc_to_litter => clm3%g%l%c%p%pcf%leafc_to_litter
leafc_xfer_to_leafc => clm3%g%l%c%p%pcf%leafc_xfer_to_leafc
leaf_mr => clm3%g%l%c%p%pcf%leaf_mr
litfall => clm3%g%l%c%p%pcf%litfall
livecrootc_xfer_to_livecrootc => clm3%g%l%c%p%pcf%livecrootc_xfer_to_livecrootc
livecroot_mr => clm3%g%l%c%p%pcf%livecroot_mr
livestemc_xfer_to_livestemc => clm3%g%l%c%p%pcf%livestemc_xfer_to_livestemc
livestem_mr => clm3%g%l%c%p%pcf%livestem_mr
m_deadcrootc_storage_to_fire => clm3%g%l%c%p%pcf%m_deadcrootc_storage_to_fire
m_deadcrootc_storage_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_storage_to_litter
m_deadcrootc_to_fire => clm3%g%l%c%p%pcf%m_deadcrootc_to_fire
m_deadcrootc_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_to_litter
m_deadcrootc_to_litter_fire => clm3%g%l%c%p%pcf%m_deadcrootc_to_litter_fire
m_deadcrootc_xfer_to_fire => clm3%g%l%c%p%pcf%m_deadcrootc_xfer_to_fire
m_deadcrootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_deadcrootc_xfer_to_litter
m_deadstemc_storage_to_fire => clm3%g%l%c%p%pcf%m_deadstemc_storage_to_fire
m_deadstemc_storage_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_storage_to_litter
m_deadstemc_to_fire => clm3%g%l%c%p%pcf%m_deadstemc_to_fire
m_deadstemc_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_to_litter
m_deadstemc_to_litter_fire => clm3%g%l%c%p%pcf%m_deadstemc_to_litter_fire
m_deadstemc_xfer_to_fire => clm3%g%l%c%p%pcf%m_deadstemc_xfer_to_fire
m_deadstemc_xfer_to_litter => clm3%g%l%c%p%pcf%m_deadstemc_xfer_to_litter
m_frootc_storage_to_fire => clm3%g%l%c%p%pcf%m_frootc_storage_to_fire
m_frootc_storage_to_litter => clm3%g%l%c%p%pcf%m_frootc_storage_to_litter
m_frootc_to_fire => clm3%g%l%c%p%pcf%m_frootc_to_fire
m_frootc_to_litter => clm3%g%l%c%p%pcf%m_frootc_to_litter
m_frootc_xfer_to_fire => clm3%g%l%c%p%pcf%m_frootc_xfer_to_fire
m_frootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_frootc_xfer_to_litter
m_gresp_storage_to_fire => clm3%g%l%c%p%pcf%m_gresp_storage_to_fire
m_gresp_storage_to_litter => clm3%g%l%c%p%pcf%m_gresp_storage_to_litter
m_gresp_xfer_to_fire => clm3%g%l%c%p%pcf%m_gresp_xfer_to_fire
m_gresp_xfer_to_litter => clm3%g%l%c%p%pcf%m_gresp_xfer_to_litter
m_leafc_storage_to_fire => clm3%g%l%c%p%pcf%m_leafc_storage_to_fire
m_leafc_storage_to_litter => clm3%g%l%c%p%pcf%m_leafc_storage_to_litter
m_leafc_to_fire => clm3%g%l%c%p%pcf%m_leafc_to_fire
m_leafc_to_litter => clm3%g%l%c%p%pcf%m_leafc_to_litter
m_leafc_xfer_to_fire => clm3%g%l%c%p%pcf%m_leafc_xfer_to_fire
m_leafc_xfer_to_litter => clm3%g%l%c%p%pcf%m_leafc_xfer_to_litter
m_livecrootc_storage_to_fire => clm3%g%l%c%p%pcf%m_livecrootc_storage_to_fire
m_livecrootc_storage_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_storage_to_litter
m_livecrootc_to_fire => clm3%g%l%c%p%pcf%m_livecrootc_to_fire
m_livecrootc_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_to_litter
m_livecrootc_xfer_to_fire => clm3%g%l%c%p%pcf%m_livecrootc_xfer_to_fire
m_livecrootc_xfer_to_litter => clm3%g%l%c%p%pcf%m_livecrootc_xfer_to_litter
m_livestemc_storage_to_fire => clm3%g%l%c%p%pcf%m_livestemc_storage_to_fire
m_livestemc_storage_to_litter => clm3%g%l%c%p%pcf%m_livestemc_storage_to_litter
m_livestemc_to_fire => clm3%g%l%c%p%pcf%m_livestemc_to_fire
m_livestemc_to_litter => clm3%g%l%c%p%pcf%m_livestemc_to_litter
m_livestemc_xfer_to_fire => clm3%g%l%c%p%pcf%m_livestemc_xfer_to_fire
m_livestemc_xfer_to_litter => clm3%g%l%c%p%pcf%m_livestemc_xfer_to_litter
hrv_leafc_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_to_litter
hrv_leafc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_storage_to_litter
hrv_leafc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_leafc_xfer_to_litter
hrv_frootc_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_to_litter
hrv_frootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_storage_to_litter
hrv_frootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_frootc_xfer_to_litter
hrv_livestemc_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_to_litter
hrv_livestemc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_storage_to_litter
hrv_livestemc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_livestemc_xfer_to_litter
hrv_deadstemc_to_prod10c => clm3%g%l%c%p%pcf%hrv_deadstemc_to_prod10c
hrv_deadstemc_to_prod100c => clm3%g%l%c%p%pcf%hrv_deadstemc_to_prod100c
hrv_deadstemc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_deadstemc_storage_to_litter
hrv_deadstemc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_deadstemc_xfer_to_litter
hrv_livecrootc_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_to_litter
hrv_livecrootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_storage_to_litter
hrv_livecrootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_livecrootc_xfer_to_litter
hrv_deadcrootc_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_to_litter
hrv_deadcrootc_storage_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_storage_to_litter
hrv_deadcrootc_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_deadcrootc_xfer_to_litter
hrv_gresp_storage_to_litter => clm3%g%l%c%p%pcf%hrv_gresp_storage_to_litter
hrv_gresp_xfer_to_litter => clm3%g%l%c%p%pcf%hrv_gresp_xfer_to_litter
hrv_xsmrpool_to_atm => clm3%g%l%c%p%pcf%hrv_xsmrpool_to_atm
col_hrv_xsmrpool_to_atm => clm3%g%l%c%ccf%pcf_a%hrv_xsmrpool_to_atm
mr => clm3%g%l%c%p%pcf%mr
npp => clm3%g%l%c%p%pcf%npp
pft_fire_closs => clm3%g%l%c%p%pcf%pft_fire_closs
psnshade_to_cpool => clm3%g%l%c%p%pcf%psnshade_to_cpool
psnsun_to_cpool => clm3%g%l%c%p%pcf%psnsun_to_cpool
rr => clm3%g%l%c%p%pcf%rr
storage_gr => clm3%g%l%c%p%pcf%storage_gr
transfer_deadcroot_gr => clm3%g%l%c%p%pcf%transfer_deadcroot_gr
transfer_deadstem_gr => clm3%g%l%c%p%pcf%transfer_deadstem_gr
transfer_froot_gr => clm3%g%l%c%p%pcf%transfer_froot_gr
transfer_gr => clm3%g%l%c%p%pcf%transfer_gr
transfer_leaf_gr => clm3%g%l%c%p%pcf%transfer_leaf_gr
transfer_livecroot_gr => clm3%g%l%c%p%pcf%transfer_livecroot_gr
transfer_livestem_gr => clm3%g%l%c%p%pcf%transfer_livestem_gr
vegfire => clm3%g%l%c%p%pcf%vegfire
wood_harvestc => clm3%g%l%c%p%pcf%wood_harvestc
#if (defined CLAMP)
!CLAMP
frootc_alloc => clm3%g%l%c%p%pcf%frootc_alloc
frootc_loss => clm3%g%l%c%p%pcf%frootc_loss
leafc_alloc => clm3%g%l%c%p%pcf%leafc_alloc
leafc_loss => clm3%g%l%c%p%pcf%leafc_loss
woodc_alloc => clm3%g%l%c%p%pcf%woodc_alloc
woodc_loss => clm3%g%l%c%p%pcf%woodc_loss
#endif
cpool => clm3%g%l%c%p%pcs%cpool
xsmrpool => clm3%g%l%c%p%pcs%xsmrpool
pft_ctrunc => clm3%g%l%c%p%pcs%pft_ctrunc
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
deadstemc => clm3%g%l%c%p%pcs%deadstemc
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
dispvegc => clm3%g%l%c%p%pcs%dispvegc
frootc => clm3%g%l%c%p%pcs%frootc
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
leafc => clm3%g%l%c%p%pcs%leafc
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
livecrootc => clm3%g%l%c%p%pcs%livecrootc
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
livestemc => clm3%g%l%c%p%pcs%livestemc
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
storvegc => clm3%g%l%c%p%pcs%storvegc
totpftc => clm3%g%l%c%p%pcs%totpftc
totvegc => clm3%g%l%c%p%pcs%totvegc
#if (defined CLAMP)
woodc => clm3%g%l%c%p%pcs%woodc
#endif
tempsum_npp => clm3%g%l%c%p%pepv%tempsum_npp
#if (defined CNDV)
tempsum_litfall => clm3%g%l%c%p%pepv%tempsum_litfall
#endif
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! calculate pft-level summary carbon fluxes and states
! gross primary production (GPP)
gpp(p) = &
psnsun_to_cpool(p) + &
psnshade_to_cpool(p)
write(6,*) 'check gpp'
write(6,*) 'gpp(',p,')=',gpp(p)
write(6,*) 'psnsun_to_cpool(',p,')=',psnsun_to_cpool(p)
write(6,*) 'psnshade_to_cpool(',p,')=',psnshade_to_cpool(p)
! maintenance respiration (MR)
mr(p) = &
leaf_mr(p) + &
froot_mr(p) + &
livestem_mr(p) + &
livecroot_mr(p)
write(6,*) 'check mr'
write(6,*) 'mr(',p,')=',mr(p)
write(6,*) 'leaf_mr(',p,')=',leaf_mr(p)
write(6,*) 'froot_mr(',p,')=',froot_mr(p)
write(6,*) 'livecroot_mr(',p,')=',livecroot_mr(p)
! growth respiration (GR)
! current GR is respired this time step for new growth displayed in this timestep
current_gr(p) = &
cpool_leaf_gr(p) + &
cpool_froot_gr(p) + &
cpool_livestem_gr(p) + &
#if (defined CROP)
cpool_grain_gr(p) + &
#endif
cpool_deadstem_gr(p) + &
cpool_livecroot_gr(p) + &
cpool_deadcroot_gr(p)
! transfer GR is respired this time step for transfer growth displayed in this timestep
transfer_gr(p) = &
transfer_leaf_gr(p) + &
transfer_froot_gr(p) + &
transfer_livestem_gr(p) + &
#if (defined CROP)
transfer_grain_gr(p) + &
#endif
transfer_deadstem_gr(p) + &
transfer_livecroot_gr(p) + &
transfer_deadcroot_gr(p)
! storage GR is respired this time step for growth sent to storage for later display
storage_gr(p) = &
cpool_leaf_storage_gr(p) + &
cpool_froot_storage_gr(p) + &
cpool_livestem_storage_gr(p) + &
#if (defined CROP)
cpool_grain_storage_gr(p) + &
#endif
cpool_deadstem_storage_gr(p) + &
cpool_livecroot_storage_gr(p) + &
cpool_deadcroot_storage_gr(p)
! GR is the sum of current + transfer + storage GR
gr(p) = &
current_gr(p) + &
transfer_gr(p) + &
storage_gr(p)
! autotrophic respiration (AR)
#if (defined CROP)
ar(p) = mr(p) + gr(p) + xsmrpool_to_atm(p) ! xsmr... is -ve (slevis)
write(6,*) 'to check ar'
write(6,*) 'ar(',p,')=',ar(p)
write(6,*) 'CSummary,mr(',p,')=',mr(p)
write(6,*) 'CSummary,gr(',p,')=',gr(p)
write(6,*) 'CSummary,xsmrpool_to_atm(',p,')=', xsmrpool_to_atm(p)
#else
ar(p) = mr(p) + gr(p)
#endif
! root respiration (RR)
rr(p) = &
froot_mr(p) + &
cpool_froot_gr(p) + &
cpool_livecroot_gr(p) + &
cpool_deadcroot_gr(p) + &
transfer_froot_gr(p) + &
transfer_livecroot_gr(p) + &
transfer_deadcroot_gr(p) + &
cpool_froot_storage_gr(p) + &
cpool_livecroot_storage_gr(p) + &
cpool_deadcroot_storage_gr(p)
! net primary production (NPP)
npp(p) = gpp(p) - ar(p)
! update the annual NPP accumulator, for use in allocation code
tempsum_npp(p) = tempsum_npp(p) + npp(p)
! aboveground NPP: leaf, live stem, dead stem (AGNPP)
! This is supposed to correspond as closely as possible to
! field measurements of AGNPP, so it ignores the storage pools
! and only treats the fluxes into displayed pools.
agnpp(p) = &
cpool_to_leafc(p) + &
leafc_xfer_to_leafc(p) + &
cpool_to_livestemc(p) + &
livestemc_xfer_to_livestemc(p) + &
#if (defined CROP)
cpool_to_grainc(p) + &
grainc_xfer_to_grainc(p) + &
#endif
cpool_to_deadstemc(p) + &
deadstemc_xfer_to_deadstemc(p)
! belowground NPP: fine root, live coarse root, dead coarse root (BGNPP)
! This is supposed to correspond as closely as possible to
! field measurements of BGNPP, so it ignores the storage pools
! and only treats the fluxes into displayed pools.
bgnpp(p) = &
cpool_to_frootc(p) + &
frootc_xfer_to_frootc(p) + &
cpool_to_livecrootc(p) + &
livecrootc_xfer_to_livecrootc(p) + &
cpool_to_deadcrootc(p) + &
deadcrootc_xfer_to_deadcrootc(p)
! litterfall (LITFALL)
litfall(p) = &
leafc_to_litter(p) + &
frootc_to_litter(p) + &
#if (defined CROP)
livestemc_to_litter(p) + &
grainc_to_food(p) + &
#endif
m_leafc_to_litter(p) + &
m_leafc_storage_to_litter(p) + &
m_leafc_xfer_to_litter(p) + &
m_frootc_to_litter(p) + &
m_frootc_storage_to_litter(p) + &
m_frootc_xfer_to_litter(p) + &
m_livestemc_to_litter(p) + &
m_livestemc_storage_to_litter(p) + &
m_livestemc_xfer_to_litter(p) + &
m_deadstemc_to_litter(p) + &
m_deadstemc_storage_to_litter(p) + &
m_deadstemc_xfer_to_litter(p) + &
m_livecrootc_to_litter(p) + &
m_livecrootc_storage_to_litter(p) + &
m_livecrootc_xfer_to_litter(p) + &
m_deadcrootc_to_litter(p) + &
m_deadcrootc_storage_to_litter(p) + &
m_deadcrootc_xfer_to_litter(p) + &
m_gresp_storage_to_litter(p) + &
m_gresp_xfer_to_litter(p) + &
m_deadstemc_to_litter_fire(p) + &
m_deadcrootc_to_litter_fire(p) + &
hrv_leafc_to_litter(p) + &
hrv_leafc_storage_to_litter(p) + &
hrv_leafc_xfer_to_litter(p) + &
hrv_frootc_to_litter(p) + &
hrv_frootc_storage_to_litter(p) + &
hrv_frootc_xfer_to_litter(p) + &
hrv_livestemc_to_litter(p) + &
hrv_livestemc_storage_to_litter(p) + &
hrv_livestemc_xfer_to_litter(p) + &
hrv_deadstemc_storage_to_litter(p) + &
hrv_deadstemc_xfer_to_litter(p) + &
hrv_livecrootc_to_litter(p) + &
hrv_livecrootc_storage_to_litter(p)+ &
hrv_livecrootc_xfer_to_litter(p) + &
hrv_deadcrootc_to_litter(p) + &
hrv_deadcrootc_storage_to_litter(p)+ &
hrv_deadcrootc_xfer_to_litter(p) + &
hrv_gresp_storage_to_litter(p) + &
hrv_gresp_xfer_to_litter(p)
#if (defined CNDV)
! update the annual litfall accumulator, for use in mortality code
tempsum_litfall(p) = tempsum_litfall(p) + leafc_to_litter(p) + frootc_to_litter(p)
#endif
! pft-level fire losses (VEGFIRE)
vegfire(p) = 0._r8
! pft-level wood harvest
wood_harvestc(p) = &
hrv_deadstemc_to_prod10c(p) + &
hrv_deadstemc_to_prod100c(p)
! pft-level carbon losses to fire
pft_fire_closs(p) = &
m_leafc_to_fire(p) + &
m_leafc_storage_to_fire(p) + &
m_leafc_xfer_to_fire(p) + &
m_frootc_to_fire(p) + &
m_frootc_storage_to_fire(p) + &
m_frootc_xfer_to_fire(p) + &
m_livestemc_to_fire(p) + &
m_livestemc_storage_to_fire(p) + &
m_livestemc_xfer_to_fire(p) + &
m_deadstemc_to_fire(p) + &
m_deadstemc_storage_to_fire(p) + &
m_deadstemc_xfer_to_fire(p) + &
m_livecrootc_to_fire(p) + &
m_livecrootc_storage_to_fire(p) + &
m_livecrootc_xfer_to_fire(p) + &
m_deadcrootc_to_fire(p) + &
m_deadcrootc_storage_to_fire(p) + &
m_deadcrootc_xfer_to_fire(p) + &
m_gresp_storage_to_fire(p) + &
m_gresp_xfer_to_fire(p)
! displayed vegetation carbon, excluding storage and cpool (DISPVEGC)
dispvegc(p) = &
leafc(p) + &
frootc(p) + &
livestemc(p) + &
#if (defined CROP)
grainc(p) + &
#endif
deadstemc(p) + &
livecrootc(p) + &
deadcrootc(p)
! stored vegetation carbon, excluding cpool (STORVEGC)
storvegc(p) = &
cpool(p) + &
leafc_storage(p) + &
frootc_storage(p) + &
livestemc_storage(p) + &
deadstemc_storage(p) + &
livecrootc_storage(p) + &
deadcrootc_storage(p) + &
#if (defined CROP)
grainc_storage(p) + &
grainc_xfer(p) + &
#endif
leafc_xfer(p) + &
frootc_xfer(p) + &
livestemc_xfer(p) + &
deadstemc_xfer(p) + &
livecrootc_xfer(p) + &
deadcrootc_xfer(p) + &
gresp_storage(p) + &
gresp_xfer(p)
! total vegetation carbon, excluding cpool (TOTVEGC)
totvegc(p) = dispvegc(p) + storvegc(p)
! total pft-level carbon, including xsmrpool, ctrunc
totpftc(p) = totvegc(p) + xsmrpool(p) + pft_ctrunc(p)
write(6,*) 'check totpftc'
write(6,*) 'CSummary,totvegc(',p,')=',totvegc(p)
write(6,*) 'CSummary,xsmrpool(',p,')=',xsmrpool(p)
write(6,*) 'CSummary,pft_ctrunc(',p,')=',pft_ctrunc(p)
#if (defined CLAMP)
! new summary variables for CLAMP
! (FROOTC_ALLOC) - fine root C allocation
frootc_alloc(p) = &
frootc_xfer_to_frootc(p) + &
cpool_to_frootc(p)
! (FROOTC_LOSS) - fine root C loss
frootc_loss(p) = &
m_frootc_to_litter(p) + &
m_frootc_to_fire(p) + &
hrv_frootc_to_litter(p) + &
frootc_to_litter(p)
! (LEAFC_ALLOC) - leaf C allocation
leafc_alloc(p) = &
leafc_xfer_to_leafc(p) + &
cpool_to_leafc(p)
! (LEAFC_LOSS) - leaf C loss
leafc_loss(p) = &
m_leafc_to_litter(p) + &
m_leafc_to_fire(p) + &
hrv_leafc_to_litter(p) + &
leafc_to_litter(p)
! (WOODC) - wood C
woodc(p) = &
deadstemc(p) + &
livestemc(p) + &
deadcrootc(p) + &
livecrootc(p)
! (WOODC_ALLOC) - wood C allocation
woodc_alloc(p) = &
livestemc_xfer_to_livestemc(p) + &
deadstemc_xfer_to_deadstemc(p) + &
livecrootc_xfer_to_livecrootc(p) + &
deadcrootc_xfer_to_deadcrootc(p) + &
cpool_to_livestemc(p) + &
cpool_to_deadstemc(p) + &
cpool_to_livecrootc(p) + &
cpool_to_deadcrootc(p)
! (WOODC_LOSS) - wood C loss
woodc_loss(p) = &
m_livestemc_to_litter(p) + &
m_deadstemc_to_litter(p) + &
m_livecrootc_to_litter(p) + &
m_deadcrootc_to_litter(p) + &
m_livestemc_to_fire(p) + &
m_deadstemc_to_fire(p) + &
m_livecrootc_to_fire(p) + &
m_deadcrootc_to_fire(p) + &
hrv_livestemc_to_litter(p) + &
hrv_livestemc_storage_to_litter(p) + &
hrv_livestemc_xfer_to_litter(p) + &
hrv_deadstemc_to_prod10c(p) + &
hrv_deadstemc_to_prod100c(p) + &
hrv_deadstemc_storage_to_litter(p) + &
hrv_deadstemc_xfer_to_litter(p) + &
hrv_livecrootc_to_litter(p) + &
hrv_livecrootc_storage_to_litter(p)+ &
hrv_livecrootc_xfer_to_litter(p) + &
hrv_deadcrootc_to_litter(p) + &
hrv_deadcrootc_storage_to_litter(p)+ &
hrv_deadcrootc_xfer_to_litter(p)
#endif
write(6,*) 'CSummary, gpp(',p,')=',gpp(p)
write(6,*) 'CSummary, ar(',p,')=',ar(p)
write(6,*) 'CSummary, rr(',p,')=',rr(p)
write(6,*) 'CSummary, npp(',p,')=',npp(p)
write(6,*) 'CSummary, vegfire(',p,')=',vegfire(p)
write(6,*) 'CSummary, wood_harvestc(',p,')=',wood_harvestc(p)
write(6,*) 'CSummary, totvegc(',p,')=',totvegc(p)
write(6,*) 'CSummary, totpftc(',p,')=',totpftc(p)
write(6,*) 'CSummary, pft_fire_closs(',p,')=',pft_fire_closs(p)
write(6,*) 'CSummary, litfall(',p,')=',litfall(p)
write(6,*) 'CSummary, hrv_xsmrpool_to_atm(',p,')=',hrv_xsmrpool_to_atm(p)
end do ! end of pfts loop
! use p2c routine to get selected column-average pft-level fluxes and states
call p2c(num_soilc, filter_soilc, gpp, col_gpp)
call p2c(num_soilc, filter_soilc, ar, col_ar)
call p2c(num_soilc, filter_soilc, rr, col_rr)
call p2c(num_soilc, filter_soilc, npp, col_npp)
call p2c(num_soilc, filter_soilc, vegfire, col_vegfire)
call p2c(num_soilc, filter_soilc, wood_harvestc, col_wood_harvestc)
call p2c(num_soilc, filter_soilc, totvegc, col_totvegc)
call p2c(num_soilc, filter_soilc, totpftc, col_totpftc)
call p2c(num_soilc, filter_soilc, pft_fire_closs, col_pft_fire_closs)
call p2c(num_soilc, filter_soilc, litfall, col_litfall)
call p2c(num_soilc, filter_soilc, hrv_xsmrpool_to_atm, col_hrv_xsmrpool_to_atm)
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! litter heterotrophic respiration (LITHR)
lithr(c) = &
litr1_hr(c) + &
litr2_hr(c) + &
litr3_hr(c)
! soil organic matter heterotrophic respiration (SOMHR)
somhr(c) = &
soil1_hr(c) + &
soil2_hr(c) + &
soil3_hr(c) + &
soil4_hr(c)
! total heterotrophic respiration (HR)
hr(c) = lithr(c) + somhr(c)
! total soil respiration, heterotrophic + root respiration (SR)
sr(c) = col_rr(c) + hr(c)
! total ecosystem respiration, autotrophic + heterotrophic (ER)
er(c) = col_ar(c) + hr(c)
! litter fire losses (LITFIRE)
litfire(c) = 0._r8
! total wood product loss
product_closs(c) = &
prod10c_loss(c) + &
prod100c_loss(c)
! soil organic matter fire losses (SOMFIRE)
somfire(c) = 0._r8
! total ecosystem fire losses (TOTFIRE)
totfire(c) = &
litfire(c) + &
somfire(c) + &
col_vegfire(c)
! column-level carbon losses to fire, including pft losses
col_fire_closs(c) = &
m_litr1c_to_fire(c) + &
m_litr2c_to_fire(c) + &
m_litr3c_to_fire(c) + &
m_cwdc_to_fire(c) + &
col_pft_fire_closs(c)
! column-level carbon losses due to landcover change
dwt_closs(c) = &
dwt_conv_cflux(c)
! net ecosystem production, excludes fire flux, landcover change, and loss from wood products, positive for sink (NEP)
nep(c) = col_gpp(c) - er(c)
! net biome production of carbon, includes depletion from: fire flux, landcover change flux, and loss
! from wood products pools, positive for sink (NBP)
nbp(c) = nep(c) - col_fire_closs(c) - dwt_closs(c) - product_closs(c)
! net ecosystem exchange of carbon, includes fire flux, landcover change flux, loss
! from wood products pools, and hrv_xsmrpool flux, positive for source (NEE)
nee(c) = -nep(c) + col_fire_closs(c) + dwt_closs(c) + product_closs(c) + col_hrv_xsmrpool_to_atm(c)
! land use flux and land uptake
landuseflux(c) = dwt_closs(c) + product_closs(c)
landuptake(c) = nee(c) - landuseflux(c)
! total litter carbon (TOTLITC)
totlitc(c) = &
litr1c(c) + &
litr2c(c) + &
litr3c(c)
! total soil organic matter carbon (TOTSOMC)
totsomc(c) = &
soil1c(c) + &
soil2c(c) + &
soil3c(c) + &
soil4c(c)
! total wood product carbon
totprodc(c) = &
prod10c(c) + &
prod100c(c)
! total ecosystem carbon, including veg but excluding cpool (TOTECOSYSC)
totecosysc(c) = &
cwdc(c) + &
totlitc(c) + &
totsomc(c) + &
totprodc(c) + &
col_totvegc(c)
! total column carbon, including veg and cpool (TOTCOLC)
! adding col_ctrunc, seedc
totcolc(c) = &
col_totpftc(c) + &
cwdc(c) + &
totlitc(c) + &
totsomc(c) + &
totprodc(c) + &
seedc(c) + &
col_ctrunc(c)
#if (defined CLAMP)
! new summary variables for CLAMP
! (CWDC_HR) - coarse woody debris heterotrophic respiration
cwdc_hr(c) = 0._r8
! (CWDC_LOSS) - coarse woody debris C loss
cwdc_loss(c) = &
m_cwdc_to_fire(c) + &
cwdc_to_litr2c(c) + &
cwdc_to_litr3c(c)
! (LITTERC_LOSS) - litter C loss
litterc_loss(c) = &
lithr(c) + &
m_litr1c_to_fire(c) + &
m_litr2c_to_fire(c) + &
m_litr3c_to_fire(c) + &
litr1c_to_soil1c(c) + &
litr2c_to_soil2c(c) + &
litr3c_to_soil3c(c)
#endif
end do ! end of columns loop
end subroutine CSummary
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: NSummary
!
! !INTERFACE:
subroutine NSummary(num_soilc, filter_soilc, num_soilp, filter_soilp) 1,6
!
! !DESCRIPTION:
! On the radiation time step, perform pft and column-level nitrogen
! summary calculations
!
! !USES:
use clmtype
!ylu changed
! use pft2colMod, only: p2c
use subgridAveMod, only : p2c
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(:) ! filter for soil pfts
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 6/28/04: Created by Peter Thornton
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
real(r8), pointer :: col_fire_nloss(:) ! (gN/m2/s) total column-level fire N loss
real(r8), pointer :: col_wood_harvestn(:)
real(r8), pointer :: denit(:)
real(r8), pointer :: m_cwdn_to_fire(:)
real(r8), pointer :: m_litr1n_to_fire(:)
real(r8), pointer :: m_litr2n_to_fire(:)
real(r8), pointer :: m_litr3n_to_fire(:)
real(r8), pointer :: col_pft_fire_nloss(:) ! (gN/m2/s) total pft-level fire C loss
real(r8), pointer :: sminn_to_denit_excess(:)
real(r8), pointer :: sminn_to_denit_l1s1(:)
real(r8), pointer :: sminn_to_denit_l2s2(:)
real(r8), pointer :: sminn_to_denit_l3s3(:)
real(r8), pointer :: sminn_to_denit_s1s2(:)
real(r8), pointer :: sminn_to_denit_s2s3(:)
real(r8), pointer :: sminn_to_denit_s3s4(:)
real(r8), pointer :: sminn_to_denit_s4(:)
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: litr1n(:) ! (gN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (gN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (gN/m2) litter lignin N
real(r8), pointer :: col_totpftn(:) ! (gN/m2) total pft-level nitrogen
real(r8), pointer :: col_totvegn(:) ! (gN/m2) total vegetation nitrogen
real(r8), pointer :: sminn(:) ! (gN/m2) soil mineral N
real(r8), pointer :: soil1n(:) ! (gN/m2) soil organic matter N (fast pool)
real(r8), pointer :: soil2n(:) ! (gN/m2) soil organic matter N (medium pool)
real(r8), pointer :: soil3n(:) ! (gN/m2) soil orgainc matter N (slow pool)
real(r8), pointer :: soil4n(:) ! (gN/m2) soil orgainc matter N (slowest pool)
real(r8), pointer :: col_ntrunc(:) ! (gN/m2) column-level sink for N truncation
real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg
real(r8), pointer :: totecosysn(:) ! (gN/m2) total ecosystem nitrogen, incl veg
real(r8), pointer :: totlitn(:) ! (gN/m2) total litter nitrogen
real(r8), pointer :: totsomn(:) ! (gN/m2) total soil organic matter nitrogen
real(r8), pointer :: m_deadcrootn_storage_to_fire(:)
real(r8), pointer :: m_deadcrootn_to_fire(:)
real(r8), pointer :: m_deadcrootn_xfer_to_fire(:)
real(r8), pointer :: m_deadstemn_storage_to_fire(:)
real(r8), pointer :: m_deadstemn_to_fire(:)
real(r8), pointer :: m_deadstemn_xfer_to_fire(:)
real(r8), pointer :: m_frootn_storage_to_fire(:)
real(r8), pointer :: m_frootn_to_fire(:)
real(r8), pointer :: m_frootn_xfer_to_fire(:)
real(r8), pointer :: m_leafn_storage_to_fire(:)
real(r8), pointer :: m_leafn_to_fire(:)
real(r8), pointer :: m_leafn_xfer_to_fire(:)
real(r8), pointer :: m_livecrootn_storage_to_fire(:)
real(r8), pointer :: m_livecrootn_to_fire(:)
real(r8), pointer :: m_livecrootn_xfer_to_fire(:)
real(r8), pointer :: m_livestemn_storage_to_fire(:)
real(r8), pointer :: m_livestemn_to_fire(:)
real(r8), pointer :: m_livestemn_xfer_to_fire(:)
real(r8), pointer :: m_retransn_to_fire(:)
real(r8), pointer :: hrv_deadstemn_to_prod10n(:)
real(r8), pointer :: hrv_deadstemn_to_prod100n(:)
real(r8), pointer :: ndeploy(:)
real(r8), pointer :: pft_fire_nloss(:) ! (gN/m2/s) total pft-level fire C loss
real(r8), pointer :: retransn_to_npool(:)
real(r8), pointer :: sminn_to_npool(:)
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: dispvegn(:) ! (gN/m2) displayed veg nitrogen, excluding storage
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
#if (defined CROP)
real(r8), pointer :: grainn(:) ! (gN/m2) grain N
real(r8), pointer :: grainn_storage(:) ! (gN/m2) grain N storage
real(r8), pointer :: grainn_xfer(:) ! (gN/m2) grain N transfer
#endif
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool
real(r8), pointer :: pft_ntrunc(:) ! (gN/m2) pft-level sink for N truncation
real(r8), pointer :: storvegn(:) ! (gN/m2) stored vegetation nitrogen
real(r8), pointer :: totpftn(:) ! (gN/m2) total pft-level nitrogen
real(r8), pointer :: totvegn(:) ! (gN/m2) total vegetation nitrogen
! for landcover change
real(r8), pointer :: wood_harvestn(:) ! total N losses to wood product pools (gN/m2/s)
real(r8), pointer :: dwt_nloss(:) ! (gN/m2/s) total nitrogen loss from product pools and conversion
real(r8), pointer :: dwt_conv_nflux(:) ! (gN/m2/s) conversion N flux (immediate loss to atm)
real(r8), pointer :: seedn(:) ! (gN/m2) column-level pool for seeding new PFTs
real(r8), pointer :: prod10n_loss(:) ! (gN/m2/s) loss from 10-yr wood product pool
real(r8), pointer :: prod100n_loss(:) ! (gN/m2/s) loss from 100-yr wood product pool
real(r8), pointer :: product_nloss(:) ! (gN/m2/s) total wood product nitrogen loss
real(r8), pointer :: prod10n(:) ! (gN/m2) wood product N pool, 10-year lifespan
real(r8), pointer :: prod100n(:) ! (gN/m2) wood product N pool, 100-year lifespan
real(r8), pointer :: totprodn(:) ! (gN/m2) total wood product N
!
! local pointers to implicit in/out scalars
!
! local pointers to implicit out scalars
!
! !OTHER LOCAL VARIABLES:
integer :: c,p ! indices
integer :: fp,fc ! lake filter indices
!EOP
!-----------------------------------------------------------------------
! assign local pointers
col_fire_nloss => clm3%g%l%c%cnf%col_fire_nloss
denit => clm3%g%l%c%cnf%denit
m_cwdn_to_fire => clm3%g%l%c%cnf%m_cwdn_to_fire
m_litr1n_to_fire => clm3%g%l%c%cnf%m_litr1n_to_fire
m_litr2n_to_fire => clm3%g%l%c%cnf%m_litr2n_to_fire
m_litr3n_to_fire => clm3%g%l%c%cnf%m_litr3n_to_fire
col_pft_fire_nloss => clm3%g%l%c%cnf%pnf_a%pft_fire_nloss
sminn_to_denit_excess => clm3%g%l%c%cnf%sminn_to_denit_excess
sminn_to_denit_l1s1 => clm3%g%l%c%cnf%sminn_to_denit_l1s1
sminn_to_denit_l2s2 => clm3%g%l%c%cnf%sminn_to_denit_l2s2
sminn_to_denit_l3s3 => clm3%g%l%c%cnf%sminn_to_denit_l3s3
sminn_to_denit_s1s2 => clm3%g%l%c%cnf%sminn_to_denit_s1s2
sminn_to_denit_s2s3 => clm3%g%l%c%cnf%sminn_to_denit_s2s3
sminn_to_denit_s3s4 => clm3%g%l%c%cnf%sminn_to_denit_s3s4
sminn_to_denit_s4 => clm3%g%l%c%cnf%sminn_to_denit_s4
cwdn => clm3%g%l%c%cns%cwdn
litr1n => clm3%g%l%c%cns%litr1n
litr2n => clm3%g%l%c%cns%litr2n
litr3n => clm3%g%l%c%cns%litr3n
col_totpftn => clm3%g%l%c%cns%pns_a%totpftn
col_totvegn => clm3%g%l%c%cns%pns_a%totvegn
sminn => clm3%g%l%c%cns%sminn
col_ntrunc => clm3%g%l%c%cns%col_ntrunc
soil1n => clm3%g%l%c%cns%soil1n
soil2n => clm3%g%l%c%cns%soil2n
soil3n => clm3%g%l%c%cns%soil3n
soil4n => clm3%g%l%c%cns%soil4n
totcoln => clm3%g%l%c%cns%totcoln
totecosysn => clm3%g%l%c%cns%totecosysn
totlitn => clm3%g%l%c%cns%totlitn
totsomn => clm3%g%l%c%cns%totsomn
m_deadcrootn_storage_to_fire => clm3%g%l%c%p%pnf%m_deadcrootn_storage_to_fire
m_deadcrootn_to_fire => clm3%g%l%c%p%pnf%m_deadcrootn_to_fire
m_deadcrootn_xfer_to_fire => clm3%g%l%c%p%pnf%m_deadcrootn_xfer_to_fire
m_deadstemn_storage_to_fire => clm3%g%l%c%p%pnf%m_deadstemn_storage_to_fire
m_deadstemn_to_fire => clm3%g%l%c%p%pnf%m_deadstemn_to_fire
m_deadstemn_xfer_to_fire => clm3%g%l%c%p%pnf%m_deadstemn_xfer_to_fire
m_frootn_storage_to_fire => clm3%g%l%c%p%pnf%m_frootn_storage_to_fire
m_frootn_to_fire => clm3%g%l%c%p%pnf%m_frootn_to_fire
m_frootn_xfer_to_fire => clm3%g%l%c%p%pnf%m_frootn_xfer_to_fire
m_leafn_storage_to_fire => clm3%g%l%c%p%pnf%m_leafn_storage_to_fire
m_leafn_to_fire => clm3%g%l%c%p%pnf%m_leafn_to_fire
m_leafn_xfer_to_fire => clm3%g%l%c%p%pnf%m_leafn_xfer_to_fire
m_livecrootn_storage_to_fire => clm3%g%l%c%p%pnf%m_livecrootn_storage_to_fire
m_livecrootn_to_fire => clm3%g%l%c%p%pnf%m_livecrootn_to_fire
m_livecrootn_xfer_to_fire => clm3%g%l%c%p%pnf%m_livecrootn_xfer_to_fire
m_livestemn_storage_to_fire => clm3%g%l%c%p%pnf%m_livestemn_storage_to_fire
m_livestemn_to_fire => clm3%g%l%c%p%pnf%m_livestemn_to_fire
m_livestemn_xfer_to_fire => clm3%g%l%c%p%pnf%m_livestemn_xfer_to_fire
m_retransn_to_fire => clm3%g%l%c%p%pnf%m_retransn_to_fire
hrv_deadstemn_to_prod10n => clm3%g%l%c%p%pnf%hrv_deadstemn_to_prod10n
hrv_deadstemn_to_prod100n => clm3%g%l%c%p%pnf%hrv_deadstemn_to_prod100n
ndeploy => clm3%g%l%c%p%pnf%ndeploy
pft_fire_nloss => clm3%g%l%c%p%pnf%pft_fire_nloss
retransn_to_npool => clm3%g%l%c%p%pnf%retransn_to_npool
sminn_to_npool => clm3%g%l%c%p%pnf%sminn_to_npool
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
deadstemn => clm3%g%l%c%p%pns%deadstemn
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
dispvegn => clm3%g%l%c%p%pns%dispvegn
frootn => clm3%g%l%c%p%pns%frootn
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
leafn => clm3%g%l%c%p%pns%leafn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
livecrootn => clm3%g%l%c%p%pns%livecrootn
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
#if (defined CROP)
grainn => clm3%g%l%c%p%pns%grainn
grainn_storage => clm3%g%l%c%p%pns%grainn_storage
grainn_xfer => clm3%g%l%c%p%pns%grainn_xfer
#endif
livestemn => clm3%g%l%c%p%pns%livestemn
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
retransn => clm3%g%l%c%p%pns%retransn
npool => clm3%g%l%c%p%pns%npool
pft_ntrunc => clm3%g%l%c%p%pns%pft_ntrunc
storvegn => clm3%g%l%c%p%pns%storvegn
totpftn => clm3%g%l%c%p%pns%totpftn
totvegn => clm3%g%l%c%p%pns%totvegn
! dynamic landcover pointers
wood_harvestn => clm3%g%l%c%p%pnf%wood_harvestn
col_wood_harvestn => clm3%g%l%c%cnf%pnf_a%wood_harvestn
dwt_nloss => clm3%g%l%c%cnf%dwt_nloss
dwt_conv_nflux => clm3%g%l%c%cnf%dwt_conv_nflux
prod10n_loss => clm3%g%l%c%cnf%prod10n_loss
prod100n_loss => clm3%g%l%c%cnf%prod100n_loss
product_nloss => clm3%g%l%c%cnf%product_nloss
seedn => clm3%g%l%c%cns%seedn
prod10n => clm3%g%l%c%cns%prod10n
prod100n => clm3%g%l%c%cns%prod100n
totprodn => clm3%g%l%c%cns%totprodn
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
! calculate pft-level summary nitrogen fluxes and states
! total N deployment (from sminn and retranslocated N pool) (NDEPLOY)
ndeploy(p) = &
sminn_to_npool(p) + &
retransn_to_npool(p)
! pft-level wood harvest
wood_harvestn(p) = &
hrv_deadstemn_to_prod10n(p) + &
hrv_deadstemn_to_prod100n(p)
! total pft-level fire N losses
pft_fire_nloss(p) = &
m_leafn_to_fire(p) + &
m_leafn_storage_to_fire(p) + &
m_leafn_xfer_to_fire(p) + &
m_frootn_to_fire(p) + &
m_frootn_storage_to_fire(p) + &
m_frootn_xfer_to_fire(p) + &
m_livestemn_to_fire(p) + &
m_livestemn_storage_to_fire(p) + &
m_livestemn_xfer_to_fire(p) + &
m_deadstemn_to_fire(p) + &
m_deadstemn_storage_to_fire(p) + &
m_deadstemn_xfer_to_fire(p) + &
m_livecrootn_to_fire(p) + &
m_livecrootn_storage_to_fire(p) + &
m_livecrootn_xfer_to_fire(p) + &
m_deadcrootn_to_fire(p) + &
m_deadcrootn_storage_to_fire(p) + &
m_deadcrootn_xfer_to_fire(p) + &
m_retransn_to_fire(p)
! displayed vegetation nitrogen, excluding storage (DISPVEGN)
dispvegn(p) = &
leafn(p) + &
frootn(p) + &
#if (defined CROP)
grainn(p) + &
#endif
livestemn(p) + &
deadstemn(p) + &
livecrootn(p) + &
deadcrootn(p)
! stored vegetation nitrogen, including retranslocated N pool (STORVEGN)
storvegn(p) = &
leafn_storage(p) + &
frootn_storage(p) + &
livestemn_storage(p) + &
deadstemn_storage(p) + &
livecrootn_storage(p) + &
deadcrootn_storage(p) + &
#if (defined CROP)
grainn_storage(p) + &
grainn_xfer(p) + &
#endif
leafn_xfer(p) + &
frootn_xfer(p) + &
livestemn_xfer(p) + &
deadstemn_xfer(p) + &
livecrootn_xfer(p) + &
deadcrootn_xfer(p) + &
npool(p) + &
retransn(p)
! total vegetation nitrogen (TOTVEGN)
totvegn(p) = dispvegn(p) + storvegn(p)
! total pft-level carbon (add pft_ntrunc)
totpftn(p) = totvegn(p) + pft_ntrunc(p)
write(6,*) 'NSummary, pft_fire_nloss(',p,')=',pft_fire_nloss(p)
write(6,*) 'NSummary, wood_harvestn(',p,')=',wood_harvestn(p)
write(6,*) 'NSummary, totvegn(',p,')=',totvegn(p)
write(6,*) 'NSummary, totpftn(',p,')=',totpftn(p)
end do ! end of pfts loop
! use p2c routine to get selected column-average pft-level fluxes and states
call p2c(num_soilc, filter_soilc, pft_fire_nloss, col_pft_fire_nloss)
call p2c(num_soilc, filter_soilc, wood_harvestn, col_wood_harvestn)
call p2c(num_soilc, filter_soilc, totvegn, col_totvegn)
call p2c(num_soilc, filter_soilc, totpftn, col_totpftn)
! column loop
do fc = 1,num_soilc
c = filter_soilc(fc)
! total N denitrification (DENIT)
denit(c) = &
sminn_to_denit_l1s1(c) + &
sminn_to_denit_l2s2(c) + &
sminn_to_denit_l3s3(c) + &
sminn_to_denit_s1s2(c) + &
sminn_to_denit_s2s3(c) + &
sminn_to_denit_s3s4(c) + &
sminn_to_denit_s4(c) + &
sminn_to_denit_excess(c)
! total column-level fire N losses
col_fire_nloss(c) = &
m_litr1n_to_fire(c) + &
m_litr2n_to_fire(c) + &
m_litr3n_to_fire(c) + &
m_cwdn_to_fire(c) + &
col_pft_fire_nloss(c)
! column-level N losses due to landcover change
dwt_nloss(c) = &
dwt_conv_nflux(c)
! total wood product N loss
product_nloss(c) = &
prod10n_loss(c) + &
prod100n_loss(c)
! total litter nitrogen (TOTLITN)
totlitn(c) = &
litr1n(c) + &
litr2n(c) + &
litr3n(c)
! total soil organic matter nitrogen (TOTSOMN)
totsomn(c) = &
soil1n(c) + &
soil2n(c) + &
soil3n(c) + &
soil4n(c)
! total wood product nitrogen
totprodn(c) = &
prod10n(c) + &
prod100n(c)
! total ecosystem nitrogen, including veg (TOTECOSYSN)
totecosysn(c) = &
cwdn(c) + &
totlitn(c) + &
totsomn(c) + &
sminn(c) + &
totprodn(c) + &
col_totvegn(c)
! total column nitrogen, including pft (TOTCOLN)
totcoln(c) = &
col_totpftn(c) + &
cwdn(c) + &
totlitn(c) + &
totsomn(c) + &
sminn(c) + &
totprodn(c) + &
seedn(c) + &
col_ntrunc(c)
end do ! end of columns loop
end subroutine NSummary
!-----------------------------------------------------------------------
#endif
end module CNSummaryMod
module CNVegStructUpdateMod 1,1
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNVegStructUpdateMod
!
! !DESCRIPTION:
! Module for vegetation structure updates (LAI, SAI, htop, hbot)
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public :: CNVegStructUpdate
!
! !REVISION HISTORY:
! 4/23/2004: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNVegStructUpdate
!
! !INTERFACE:
subroutine CNVegStructUpdate(num_soilp, filter_soilp) 1,5
!
! !DESCRIPTION:
! On the radiation time step, use C state variables and epc to diagnose
! vegetation structure (LAI, SAI, height)
!
! !USES:
use clmtype
!ylu remove use clm_atmlnd , only: clm_a2l
use pftvarcon , only: noveg, nc3crop, nc4crop, nbrdlf_evr_shrub, nbrdlf_dcd_brl_shrub
#if (defined CROP)
use pftvarcon , only: ncorn, npcropmin, ztopmx, laimx
! use clm_varctl , only: iulog
!ylu remove use shr_sys_mod , only: shr_sys_flush
#endif
use shr_const_mod, only: SHR_CONST_PI
! use clm_time_manager , only : get_rad_step_size
use globals , only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilp ! number of column soil points in pft filter
integer, intent(in) :: filter_soilp(:) ! pft filter for soil points
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 10/28/03: Created by Peter Thornton
! 2/29/08, David Lawrence: revised snow burial fraction for short vegetation
!
! !LOCAL VARIABLES:
! local pointers to implicit in scalars
!
#if (defined CNDV)
real(r8), pointer :: allom2(:) ! ecophys const
real(r8), pointer :: allom3(:) ! ecophys const
real(r8), pointer :: nind(:) ! number of individuals (#/m**2)
real(r8), pointer :: fpcgrid(:) ! fractional area of pft (pft area/nat veg area)
#endif
integer , pointer :: ivt(:) ! pft vegetation type
integer , pointer :: pcolumn(:) ! column index associated with each pft
integer , pointer :: pgridcell(:) ! pft's gridcell index
real(r8), pointer :: snowdp(:) ! snow height (m)
real(r8), pointer :: leafc(:) ! (kgC/m2) leaf C
real(r8), pointer :: deadstemc(:) ! (kgC/m2) dead stem C
real(r8), pointer :: woody(:) !binary flag for woody lifeform (1=woody, 0=not woody)
real(r8), pointer :: slatop(:) !specific leaf area at top of canopy, projected area basis [m^2/gC]
real(r8), pointer :: dsladlai(:) !dSLA/dLAI, projected area basis [m^2/gC]
real(r8), pointer :: z0mr(:) !ratio of momentum roughness length to canopy top height (-)
real(r8), pointer :: displar(:) !ratio of displacement height to canopy top height (-)
real(r8), pointer :: forc_hgt_u_pft(:) ! observational height of wind at pft-level [m]
real(r8), pointer :: dwood(:) ! density of wood (kgC/m^3)
!
! local pointers to implicit in/out scalars
!
integer , pointer :: frac_veg_nosno_alb(:) ! frac of vegetation not covered by snow [-]
real(r8), pointer :: tlai(:) !one-sided leaf area index, no burying by snow
real(r8), pointer :: tsai(:) !one-sided stem area index, no burying by snow
real(r8), pointer :: htop(:) !canopy top (m)
real(r8), pointer :: hbot(:) !canopy bottom (m)
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) ! one-sided stem area index with burying by snow
#if (defined CROP)
real(r8), pointer :: htmx(:) ! max hgt attained by a crop during yr
integer , pointer :: peaklai(:) ! 1: max allowed lai; 0: not at max
integer , pointer :: harvdate(:) ! harvest date
#endif
!
! local pointers to implicit out scalars
!
!
! !OTHER LOCAL VARIABLES:
integer :: p,c,g !indices
integer :: fp !lake filter indices
real(r8):: taper ! ratio of height:radius_breast_height (tree allometry)
real(r8):: stocking ! #stems / ha (stocking density)
real(r8):: ol ! thickness of canopy layer covered by snow (m)
real(r8):: fb ! fraction of canopy layer covered by snow
real(r8) :: tlai_old ! for use in Zeng tsai formula
real(r8) :: tsai_old ! for use in Zeng tsai formula
real(r8) :: tsai_min ! PFT derived minimum tsai
real(r8) :: tsai_alpha ! monthly decay rate of tsai
! real(r8) dt ! radiation time step (sec)
real(r8), parameter :: dtsmonth = 2592000._r8 ! number of seconds in a 30 day month (60x60x24x30)
!EOP
!-----------------------------------------------------------------------
! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835
!
! tsai(p) = max( tsai_alpha(ivt(p))*tsai_old + max(tlai_old-tlai(p),0_r8), tsai_min(ivt(p)) )
! notes:
! * RHS tsai & tlai are from previous timestep
! * should create tsai_alpha(ivt(p)) & tsai_min(ivt(p)) in pftvarcon.F90 - slevis
! * all non-crop pfts use same values:
! crop tsai_alpha,tsai_min = 0.0,0.1
! noncrop tsai_alpha,tsai_min = 0.5,1.0 (includes bare soil and urban)
!-------------------------------------------------------------------------------
! assign local pointers to derived type arrays (in)
#if (defined CNDV)
allom2 => dgv_pftcon%allom2
allom3 => dgv_pftcon%allom3
nind => clm3%g%l%c%p%pdgvs%nind
fpcgrid => clm3%g%l%c%p%pdgvs%fpcgrid
#endif
ivt => clm3%g%l%c%p%itype
pcolumn => clm3%g%l%c%p%column
pgridcell => clm3%g%l%c%p%gridcell
leafc => clm3%g%l%c%p%pcs%leafc
deadstemc => clm3%g%l%c%p%pcs%deadstemc
snowdp => clm3%g%l%c%cps%snowdp
woody => pftcon%woody
slatop => pftcon%slatop
dsladlai => pftcon%dsladlai
z0mr => pftcon%z0mr
displar => pftcon%displar
dwood => pftcon%dwood
! assign local pointers to derived type arrays (out)
tlai => clm3%g%l%c%p%pps%tlai
tsai => clm3%g%l%c%p%pps%tsai
htop => clm3%g%l%c%p%pps%htop
hbot => clm3%g%l%c%p%pps%hbot
elai => clm3%g%l%c%p%pps%elai
esai => clm3%g%l%c%p%pps%esai
frac_veg_nosno_alb => clm3%g%l%c%p%pps%frac_veg_nosno_alb
#if (defined CROP)
htmx => clm3%g%l%c%p%pps%htmx
peaklai => clm3%g%l%c%p%pps%peaklai
harvdate => clm3%g%l%c%p%pps%harvdate
#endif
forc_hgt_u_pft => clm3%g%l%c%p%pps%forc_hgt_u_pft
! dt = real( get_rad_step_size(), r8 )
! constant allometric parameters
taper = 200._r8
stocking = 1000._r8
! convert from stems/ha -> stems/m^2
stocking = stocking / 10000._r8
! pft loop
do fp = 1,num_soilp
p = filter_soilp(fp)
c = pcolumn(p)
g = pgridcell(p)
if (ivt(p) /= noveg) then
tlai_old = tlai(p) ! n-1 value
tsai_old = tsai(p) ! n-1 value
! update the leaf area index based on leafC and SLA
! Eq 3 from Thornton and Zimmerman, 2007, J Clim, 20, 3902-3923.
if (dsladlai(ivt(p)) > 0._r8) then
tlai(p) = (slatop(ivt(p))*(exp(leafc(p)*dsladlai(ivt(p))) - 1._r8))/dsladlai(ivt(p))
else
tlai(p) = slatop(ivt(p)) * leafc(p)
end if
tlai(p) = max(0._r8, tlai(p))
! update the stem area index and height based on LAI, stem mass, and veg type.
! With the exception of htop for woody vegetation, this follows the DGVM logic.
! tsai formula from Zeng et. al. 2002, Journal of Climate, p1835 (see notes)
! Assumes doalb time step .eq. CLM time step, SAI min and monthly decay factor
! alpha are set by PFT, and alpha is scaled to CLM time step by multiplying by
! dt and dividing by dtsmonth (seconds in average 30 day month)
! tsai_min scaled by 0.5 to match MODIS satellite derived values
if (ivt(p) == nc3crop .or. ivt(p) == nc4crop) then ! crops
tsai_alpha = 1.0_r8-1.0_r8*dt/dtsmonth
tsai_min = 0.1_r8
else
tsai_alpha = 1.0_r8-0.5_r8*dt/dtsmonth
tsai_min = 1.0_r8
end if
tsai_min = tsai_min * 0.5_r8
tsai(p) = max(tsai_alpha*tsai_old+max(tlai_old-tlai(p),0._r8),tsai_min)
if (woody(ivt(p)) == 1._r8) then
! trees and shrubs
! if shrubs have a squat taper
if (ivt(p) >= nbrdlf_evr_shrub .and. ivt(p) <= nbrdlf_dcd_brl_shrub) then
taper = 10._r8
! otherwise have a tall taper
else
taper = 200._r8
end if
! trees and shrubs for now have a very simple allometry, with hard-wired
! stem taper (height:radius) and hard-wired stocking density (#individuals/area)
#if (defined CNDV)
if (fpcgrid(p) > 0._r8 .and. nind(p) > 0._r8) then
stocking = nind(p)/fpcgrid(p) !#ind/m2 nat veg area -> #ind/m2 pft area
htop(p) = allom2(ivt(p)) * ( (24._r8 * deadstemc(p) / &
(SHR_CONST_PI * stocking * dwood(ivt(p)) * taper))**(1._r8/3._r8) )**allom3(ivt(p)) ! lpj's htop w/ cn's stemdiam
else
htop(p) = 0._r8
end if
#else
htop(p) = ((3._r8 * deadstemc(p) * taper * taper)/ &
(SHR_CONST_PI * stocking * dwood(ivt(p))))**(1._r8/3._r8)
#endif
! Peter Thornton, 5/3/2004
! Adding test to keep htop from getting too close to forcing height for windspeed
! Also added for grass, below, although it is not likely to ever be an issue.
htop(p) = min(htop(p),(forc_hgt_u_pft(p)/(displar(ivt(p))+z0mr(ivt(p))))-3._r8)
! Peter Thornton, 8/11/2004
! Adding constraint to keep htop from going to 0.0.
! This becomes an issue when fire mortality is pushing deadstemc
! to 0.0.
htop(p) = max(htop(p), 0.01_r8)
hbot(p) = max(0._r8, min(3._r8, htop(p)-1._r8))
#if (defined CROP)
else if (ivt(p) >= npcropmin) then ! prognostic crops
if (tlai(p) >= laimx(ivt(p))) peaklai(p) = 1 ! used in CNAllocation
if (ivt(p) == ncorn) then
tsai(p) = 0.1_r8 * tlai(p)
else
tsai(p) = 0.2_r8 * tlai(p)
end if
! "stubble" after harvest
if (harvdate(p) < 999 .and. tlai(p) == 0._r8) then
tsai(p) = 0.25_r8
htmx(p) = 0._r8
peaklai(p) = 0
end if
if (harvdate(p) < 999 .and. tlai(p) > 0._r8) write(6,*) 'CNVegStructUpdate: tlai>0 after harvest!' ! remove after initial debugging?
! canopy top and bottom heights
htop(p) = ztopmx(ivt(p)) * (min(tlai(p)/(laimx(ivt(p))-1._r8),1._r8))**2
htmx(p) = max(htmx(p), htop(p))
htop(p) = max(0.05_r8, max(htmx(p),htop(p)))
hbot(p) = 0.02_r8
#endif
else ! generic crops and ...
! grasses
! height for grasses depends only on LAI
htop(p) = max(0.25_r8, tlai(p) * 0.25_r8)
htop(p) = min(htop(p),(forc_hgt_u_pft(p)/(displar(ivt(p))+z0mr(ivt(p))))-3._r8)
! Peter Thornton, 8/11/2004
! Adding constraint to keep htop from going to 0.0.
htop(p) = max(htop(p), 0.01_r8)
hbot(p) = max(0.0_r8, min(0.05_r8, htop(p)-0.20_r8))
end if
else
tlai(p) = 0._r8
tsai(p) = 0._r8
htop(p) = 0._r8
hbot(p) = 0._r8
end if
! adjust lai and sai for burying by snow.
! snow burial fraction for short vegetation (e.g. grasses) as in
! Wang and Zeng, 2007.
if (ivt(p) > noveg .and. ivt(p) <= nbrdlf_dcd_brl_shrub ) then
ol = min( max(snowdp(c)-hbot(p), 0._r8), htop(p)-hbot(p))
fb = 1._r8 - ol / max(1.e-06_r8, htop(p)-hbot(p))
else
fb = 1._r8 - max(min(snowdp(c),0.2_r8),0._r8)/0.2_r8 ! 0.2m is assumed
!depth of snow required for complete burial of grasses
endif
elai(p) = max(tlai(p)*fb, 0.0_r8)
esai(p) = max(tsai(p)*fb, 0.0_r8)
! Fraction of vegetation free of snow
if ((elai(p) + esai(p)) > 0._r8) then
frac_veg_nosno_alb(p) = 1
else
frac_veg_nosno_alb(p) = 0
end if
end do
end subroutine CNVegStructUpdate
!-----------------------------------------------------------------------
#endif
end module CNVegStructUpdateMod
module CNWoodProductsMod 1,2
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNWoodProductsMod
!
! !DESCRIPTION:
! Calculate loss fluxes from wood products pools, and update product pool state variables
!
! !USES:
! ylu remove
! use decompMod , only : get_proc_bounds
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varcon , only: istsoil
! ylu remove
! use spmdMod , only: masterproc
implicit none
save
private
! !PUBLIC MEMBER FUNCTIONS:
public:: CNWoodProducts
!
! !REVISION HISTORY:
! 5/20/2009: Created by Peter Thornton
!
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNWoodProducts
!
! !INTERFACE:
subroutine CNWoodProducts(num_soilc, filter_soilc) 1,2
!
! !DESCRIPTION:
! Update all loss fluxes from wood product pools, and update product pool state variables
! for both loss and gain terms. Gain terms are calculated in pftdyn_cnbal() for gains associated
! with changes in landcover, and in CNHarvest(), for gains associated with wood harvest.
!
! !USES:
use clmtype
!ylu removed
! use clm_time_manager, only: get_step_size
use globals , only: dt
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(:) ! filter for soil columns
!
! !CALLED FROM:
! subroutine CNEcosystemDyn
!
! !REVISION HISTORY:
! 5/21/09: Created by Peter Thornton
!
! !LOCAL VARIABLES:
integer :: fc ! lake filter indices
integer :: c ! indices
! real(r8):: dt ! time step (seconds)
type(column_type), pointer :: cptr ! pointer to column derived subtype
real(r8) :: kprod10 ! decay constant for 10-year product pool
real(r8) :: kprod100 ! decay constant for 100-year product pool
!EOP
!-----------------------------------------------------------------------
cptr => clm3%g%l%c
! calculate column-level losses from product pools
! the following (1/s) rate constants result in ~90% loss of initial state over 10 and 100 years,
! respectively, using a discrete-time fractional decay algorithm.
kprod10 = 7.2e-9
kprod100 = 7.2e-10
!dir$ concurrent
!cdir nodep
do fc = 1,num_soilc
c = filter_soilc(fc)
! calculate fluxes (1/sec)
cptr%ccf%prod10c_loss(c) = cptr%ccs%prod10c(c) * kprod10
cptr%ccf%prod100c_loss(c) = cptr%ccs%prod100c(c) * kprod100
#if (defined C13)
cptr%cc13f%prod10c_loss(c) = cptr%cc13s%prod10c(c) * kprod10
cptr%cc13f%prod100c_loss(c) = cptr%cc13s%prod100c(c) * kprod100
#endif
cptr%cnf%prod10n_loss(c) = cptr%cns%prod10n(c) * kprod10
cptr%cnf%prod100n_loss(c) = cptr%cns%prod100n(c) * kprod100
end do
! set time steps
! dt = real( get_step_size(), r8 )
! update wood product state variables
! column loop
!dir$ concurrent
!cdir nodep
do fc = 1,num_soilc
c = filter_soilc(fc)
! column-level fluxes
! fluxes into wood product pools, from landcover change
cptr%ccs%prod10c(c) = cptr%ccs%prod10c(c) + cptr%ccf%dwt_prod10c_gain(c)*dt
cptr%ccs%prod100c(c) = cptr%ccs%prod100c(c) + cptr%ccf%dwt_prod100c_gain(c)*dt
#if (defined C13)
cptr%cc13s%prod10c(c) = cptr%cc13s%prod10c(c) + cptr%cc13f%dwt_prod10c_gain(c)*dt
cptr%cc13s%prod100c(c) = cptr%cc13s%prod100c(c) + cptr%cc13f%dwt_prod100c_gain(c)*dt
#endif
cptr%cns%prod10n(c) = cptr%cns%prod10n(c) + cptr%cnf%dwt_prod10n_gain(c)*dt
cptr%cns%prod100n(c) = cptr%cns%prod100n(c) + cptr%cnf%dwt_prod100n_gain(c)*dt
! fluxes into wood product pools, from harvest
cptr%ccs%prod10c(c) = cptr%ccs%prod10c(c) + cptr%ccf%hrv_deadstemc_to_prod10c(c)*dt
cptr%ccs%prod100c(c) = cptr%ccs%prod100c(c) + cptr%ccf%hrv_deadstemc_to_prod100c(c)*dt
#if (defined C13)
cptr%cc13s%prod10c(c) = cptr%cc13s%prod10c(c) + cptr%cc13f%hrv_deadstemc_to_prod10c(c)*dt
cptr%cc13s%prod100c(c) = cptr%cc13s%prod100c(c) + cptr%cc13f%hrv_deadstemc_to_prod100c(c)*dt
#endif
cptr%cns%prod10n(c) = cptr%cns%prod10n(c) + cptr%cnf%hrv_deadstemn_to_prod10n(c)*dt
cptr%cns%prod100n(c) = cptr%cns%prod100n(c) + cptr%cnf%hrv_deadstemn_to_prod100n(c)*dt
! fluxes out of wood product pools, from decomposition
cptr%ccs%prod10c(c) = cptr%ccs%prod10c(c) - cptr%ccf%prod10c_loss(c)*dt
cptr%ccs%prod100c(c) = cptr%ccs%prod100c(c) - cptr%ccf%prod100c_loss(c)*dt
#if (defined C13)
cptr%cc13s%prod10c(c) = cptr%cc13s%prod10c(c) - cptr%cc13f%prod10c_loss(c)*dt
cptr%cc13s%prod100c(c) = cptr%cc13s%prod100c(c) - cptr%cc13f%prod100c_loss(c)*dt
#endif
cptr%cns%prod10n(c) = cptr%cns%prod10n(c) - cptr%cnf%prod10n_loss(c)*dt
cptr%cns%prod100n(c) = cptr%cns%prod100n(c) - cptr%cnf%prod100n_loss(c)*dt
end do ! end of column loop
end subroutine CNWoodProducts
!-----------------------------------------------------------------------
#endif
end module CNWoodProductsMod
!#include <misc.h>
!#include <preproc.h>
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNiniSpecial
!
! !INTERFACE:
subroutine CNiniSpecial () 1,31
#ifdef CN
!
! !DESCRIPTION:
! One-time initialization of CN variables for special landunits
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use pftvarcon , only: noveg
use decompMod , only: get_proc_bounds
use clm_varcon , only: spval
! use clm_varctl , only: iulog
use clmtype
use CNSetValueMod
!
! !ARGUMENTS:
implicit none
!
! !CALLED FROM:
! subroutine iniTimeConst in file iniTimeConst.F90
!
! !REVISION HISTORY:
! 11/13/03: Created by Peter Thornton
!
!
! local pointers to implicit in arguments
!
integer , pointer :: clandunit(:) ! landunit index of corresponding column
integer , pointer :: plandunit(:) ! landunit index of corresponding pft
logical , pointer :: ifspecial(:) ! BOOL: true=>landunit is wetland,ice,lake, or urban
!
! local pointers to implicit out arguments
!
! !LOCAL VARIABLES:
!EOP
integer :: fc,fp,l,c,p ! indices
integer :: begp, endp ! per-clump/proc beginning and ending pft indices
integer :: begc, endc ! per-clump/proc beginning and ending column indices
integer :: begl, endl ! per-clump/proc beginning and ending landunit indices
integer :: begg, endg ! per-clump/proc gridcell ending gridcell indices
integer :: num_specialc ! number of good values in specialc filter
integer :: num_specialp ! number of good values in specialp filter
integer, allocatable :: specialc(:) ! special landunit filter - columns
integer, allocatable :: specialp(:) ! special landunit filter - pfts
!-----------------------------------------------------------------------
call CLMDebug('Enter CNiniSpecial()')
! assign local pointers at the landunit level
ifspecial => clm3%g%l%ifspecial
! assign local pointers at the column level
clandunit => clm3%g%l%c%landunit
! assign local pointers at the pft level
plandunit => clm3%g%l%c%p%landunit
! Determine subgrid bounds on this processor
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! allocate special landunit filters
allocate(specialc(endc-begc+1))
allocate(specialp(endp-begp+1))
! fill special landunit filters
num_specialc = 0
do c = begc, endc
l = clandunit(c)
if (ifspecial(l)) then
num_specialc = num_specialc + 1
specialc(num_specialc) = c
end if
end do
num_specialp = 0
do p = begp, endp
l = plandunit(p)
if (ifspecial(l)) then
num_specialp = num_specialp + 1
specialp(num_specialp) = p
end if
end do
! initialize column-level fields
call CLMDebug('start call CNSetCps()')
call CNSetCps(num_specialc, specialc, spval, clm3%g%l%c%cps)
call CNSetCcs(num_specialc, specialc, 0._r8, clm3%g%l%c%ccs)
call CNSetCns(num_specialc, specialc, 0._r8, clm3%g%l%c%cns)
call CNSetCcf(num_specialc, specialc, 0._r8, clm3%g%l%c%ccf)
call CNSetCnf(num_specialc, specialc, 0._r8, clm3%g%l%c%cnf)
#if (defined C13)
! 4/14/05: PET
! adding isotope code
call CNSetCcs(num_specialc, specialc, 0._r8, clm3%g%l%c%cc13s)
call CNSetCcf(num_specialc, specialc, 0._r8, clm3%g%l%c%cc13f)
#endif
! initialize column-average pft fields
call CNSetPps(num_specialc, specialc, spval, clm3%g%l%c%cps%pps_a)
call CNSetPcs(num_specialc, specialc, 0._r8, clm3%g%l%c%ccs%pcs_a)
call CNSetPns(num_specialc, specialc, 0._r8, clm3%g%l%c%cns%pns_a)
call CNSetPcf(num_specialc, specialc, 0._r8, clm3%g%l%c%ccf%pcf_a)
call CNSetPnf(num_specialc, specialc, 0._r8, clm3%g%l%c%cnf%pnf_a)
! initialize pft-level fields
call CNSetPepv(num_specialp, specialp, spval, clm3%g%l%c%p%pepv)
call CNSetPps(num_specialp, specialp, spval, clm3%g%l%c%p%pps)
call CNSetPcs(num_specialp, specialp, 0._r8, clm3%g%l%c%p%pcs)
call CNSetPns(num_specialp, specialp, 0._r8, clm3%g%l%c%p%pns)
call CNSetPcf(num_specialp, specialp, 0._r8, clm3%g%l%c%p%pcf)
call CNSetPnf(num_specialp, specialp, 0._r8, clm3%g%l%c%p%pnf)
#if (defined C13)
! 4/14/05: PET
! adding isotope code
call CNSetPcs(num_specialp, specialp, 0._r8, clm3%g%l%c%p%pc13s)
call CNSetPcf(num_specialp, specialp, 0._r8, clm3%g%l%c%p%pc13f)
#endif
call CLMDebug('All CNSet call are right')
! now loop through special filters and explicitly set the variables that
! have to be in place for SurfaceAlbedo and biogeophysics
! also set pcf%psnsun and pcf%psnsha to 0 (not included in CNSetPcf())
!dir$ concurrent
!cdir nodep
do fp = 1,num_specialp
p = specialp(fp)
clm3%g%l%c%p%pps%tlai(p) = 0._r8
clm3%g%l%c%p%pps%tsai(p) = 0._r8
clm3%g%l%c%p%pps%elai(p) = 0._r8
clm3%g%l%c%p%pps%esai(p) = 0._r8
clm3%g%l%c%p%pps%htop(p) = 0._r8
clm3%g%l%c%p%pps%hbot(p) = 0._r8
clm3%g%l%c%p%pps%fwet(p) = 0._r8
clm3%g%l%c%p%pps%fdry(p) = 0._r8
clm3%g%l%c%p%pps%frac_veg_nosno_alb(p) = 0._r8
clm3%g%l%c%p%pps%frac_veg_nosno(p) = 0._r8
clm3%g%l%c%p%pcf%psnsun(p) = 0._r8
clm3%g%l%c%p%pcf%psnsha(p) = 0._r8
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
clm3%g%l%c%p%pc13f%psnsun(p) = 0._r8
clm3%g%l%c%p%pc13f%psnsha(p) = 0._r8
#endif
end do
!dir$ concurrent
!cdir nodep
do fc = 1,num_specialc
c = specialc(fc)
clm3%g%l%c%ccf%pcf_a%psnsun(c) = 0._r8
clm3%g%l%c%ccf%pcf_a%psnsha(c) = 0._r8
#if (defined C13)
! 8/17/05: PET
! Adding isotope code
clm3%g%l%c%cc13f%pcf_a%psnsun(c) = 0._r8
clm3%g%l%c%cc13f%pcf_a%psnsha(c) = 0._r8
#endif
! adding dynpft code
clm3%g%l%c%ccs%seedc(c) = 0._r8
clm3%g%l%c%ccs%prod10c(c) = 0._r8
clm3%g%l%c%ccs%prod100c(c) = 0._r8
clm3%g%l%c%ccs%totprodc(c) = 0._r8
#if (defined C13)
clm3%g%l%c%cc13s%seedc(c) = 0._r8
clm3%g%l%c%cc13s%prod10c(c) = 0._r8
clm3%g%l%c%cc13s%prod100c(c) = 0._r8
clm3%g%l%c%cc13s%totprodc(c) = 0._r8
#endif
clm3%g%l%c%cns%seedn(c) = 0._r8
clm3%g%l%c%cns%prod10n(c) = 0._r8
clm3%g%l%c%cns%prod100n(c) = 0._r8
clm3%g%l%c%cns%totprodn(c) = 0._r8
clm3%g%l%c%ccf%dwt_seedc_to_leaf(c) = 0._r8
clm3%g%l%c%ccf%dwt_seedc_to_deadstem(c) = 0._r8
clm3%g%l%c%ccf%dwt_conv_cflux(c) = 0._r8
clm3%g%l%c%ccf%dwt_prod10c_gain(c) = 0._r8
clm3%g%l%c%ccf%prod10c_loss(c) = 0._r8
clm3%g%l%c%ccf%dwt_prod100c_gain(c) = 0._r8
clm3%g%l%c%ccf%prod100c_loss(c) = 0._r8
clm3%g%l%c%ccf%dwt_frootc_to_litr1c(c) = 0._r8
clm3%g%l%c%ccf%dwt_frootc_to_litr2c(c) = 0._r8
clm3%g%l%c%ccf%dwt_frootc_to_litr3c(c) = 0._r8
clm3%g%l%c%ccf%dwt_livecrootc_to_cwdc(c) = 0._r8
clm3%g%l%c%ccf%dwt_deadcrootc_to_cwdc(c) = 0._r8
clm3%g%l%c%ccf%dwt_closs(c) = 0._r8
clm3%g%l%c%ccf%landuseflux(c) = 0._r8
clm3%g%l%c%ccf%landuptake(c) = 0._r8
#if (defined C13)
clm3%g%l%c%cc13f%dwt_seedc_to_leaf(c) = 0._r8
clm3%g%l%c%cc13f%dwt_seedc_to_deadstem(c) = 0._r8
clm3%g%l%c%cc13f%dwt_conv_cflux(c) = 0._r8
clm3%g%l%c%cc13f%dwt_prod10c_gain(c) = 0._r8
clm3%g%l%c%cc13f%prod10c_loss(c) = 0._r8
clm3%g%l%c%cc13f%dwt_prod100c_gain(c) = 0._r8
clm3%g%l%c%cc13f%prod100c_loss(c) = 0._r8
clm3%g%l%c%cc13f%dwt_frootc_to_litr1c(c) = 0._r8
clm3%g%l%c%cc13f%dwt_frootc_to_litr2c(c) = 0._r8
clm3%g%l%c%cc13f%dwt_frootc_to_litr3c(c) = 0._r8
clm3%g%l%c%cc13f%dwt_livecrootc_to_cwdc(c) = 0._r8
clm3%g%l%c%cc13f%dwt_deadcrootc_to_cwdc(c) = 0._r8
clm3%g%l%c%cc13f%dwt_closs(c) = 0._r8
#endif
clm3%g%l%c%cnf%dwt_seedn_to_leaf(c) = 0._r8
clm3%g%l%c%cnf%dwt_seedn_to_deadstem(c) = 0._r8
clm3%g%l%c%cnf%dwt_conv_nflux(c) = 0._r8
clm3%g%l%c%cnf%dwt_prod10n_gain(c) = 0._r8
clm3%g%l%c%cnf%prod10n_loss(c) = 0._r8
clm3%g%l%c%cnf%dwt_prod100n_gain(c) = 0._r8
clm3%g%l%c%cnf%prod100n_loss(c) = 0._r8
clm3%g%l%c%cnf%dwt_frootn_to_litr1n(c) = 0._r8
clm3%g%l%c%cnf%dwt_frootn_to_litr2n(c) = 0._r8
clm3%g%l%c%cnf%dwt_frootn_to_litr3n(c) = 0._r8
clm3%g%l%c%cnf%dwt_livecrootn_to_cwdn(c) = 0._r8
clm3%g%l%c%cnf%dwt_deadcrootn_to_cwdn(c) = 0._r8
clm3%g%l%c%cnf%dwt_nloss(c) = 0._r8
end do
! deallocate special landunit filters
deallocate(specialc)
deallocate(specialp)
#endif
end subroutine CNiniSpecial
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNiniTimeVar
!
! !INTERFACE:
subroutine CNiniTimeVar(htmx_buf,croplive_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf & 1,11
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf &
)
#ifdef CN
!
! !DESCRIPTION:
! Initializes time varying variables used only in
! coupled carbon-nitrogen mode (CN):
!
! !USES:
use clmtype
! use clm_atmlnd , only: clm_a2l !removed for coupling purpose Yaqiong Lu 01/25/11
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varcon , only: istsoil
#ifdef CROP
use clm_varcon , only: istcrop
#endif
#if (defined C13)
use clm_varcon , only: c13ratio
#endif
use pftvarcon , only: noveg
#if (defined CROP)
use pftvarcon , only: npcropmin
#endif
use decompMod , only: get_proc_bounds
use globals , only: nstep
use clm_varpar , only: maxpatch
!
! !ARGUMENTS:
implicit none
!
! !CALLED FROM:
! subroutine iniTimeVar in file iniTimeVar.F90
!
! !REVISION HISTORY:
! 10/21/03: Created by Peter Thornton
!
!
! local pointers to implicit in arguments
!
real(r8), pointer :: evergreen(:) ! binary flag for evergreen leaf habit (0 or 1)
real(r8), pointer :: woody(:) ! binary flag for woody lifeform (1=woody, 0=not woody)
real(r8), pointer :: leafcn(:) ! leaf C:N (gC/gN)
real(r8), pointer :: deadwdcn(:) ! dead wood (xylem and heartwood) C:N (gC/gN)
integer , pointer :: ivt(:) ! pft vegetation type
logical , pointer :: lakpoi(:) ! true => landunit is a lake point
integer , pointer :: plandunit(:) ! landunit index associated with each pft
integer , pointer :: clandunit(:) ! landunit index associated with each column
integer , pointer :: itypelun(:) ! landunit type
!
! local pointers to implicit out arguments
!
real(r8), pointer :: forc_hgt_u_pft(:) !observational height of wind at pft-level [m]
real(r8), pointer :: annsum_counter(:) ! seconds since last annual accumulator turnover
real(r8), pointer :: cannsum_npp(:) ! annual sum of NPP, averaged from pft-level (gC/m2/yr)
real(r8), pointer :: cannavg_t2m(:) !annual average of 2m air temperature, averaged from pft-level (K)
real(r8), pointer :: cwdc(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c(:) ! (gC/m2) litter lignin C
real(r8), pointer :: soil1c(:) ! (gC/m2) soil organic matter C (fast pool)
real(r8), pointer :: soil2c(:) ! (gC/m2) soil organic matter C (medium pool)
real(r8), pointer :: soil3c(:) ! (gC/m2) soil organic matter C (slow pool)
real(r8), pointer :: soil4c(:) ! (gC/m2) soil organic matter C (slowest pool)
real(r8), pointer :: cwdn(:) ! (gN/m2) coarse woody debris N
real(r8), pointer :: litr1n(:) ! (gN/m2) litter labile N
real(r8), pointer :: litr2n(:) ! (gN/m2) litter cellulose N
real(r8), pointer :: litr3n(:) ! (gN/m2) litter lignin N
real(r8), pointer :: soil1n(:) ! (gN/m2) soil organic matter N (fast pool)
real(r8), pointer :: soil2n(:) ! (gN/m2) soil organic matter N (medium pool)
real(r8), pointer :: soil3n(:) ! (gN/m2) soil orgainc matter N (slow pool)
real(r8), pointer :: soil4n(:) ! (gN/m2) soil orgainc matter N (slowest pool)
real(r8), pointer :: sminn(:) ! (gN/m2) soil mineral N
real(r8), pointer :: leafc(:) ! (gC/m2) leaf C
real(r8), pointer :: leafc_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc_xfer(:) ! (gC/m2) leaf C transfer
#if (defined CROP)
real(r8), pointer :: grainc(:) ! (gC/m2) grain C
real(r8), pointer :: grainc_storage(:) ! (gC/m2) grain C storage
real(r8), pointer :: grainc_xfer(:) ! (gC/m2) grain C transfer
integer , pointer :: croplive(:) ! post planting+pre harvest+live=1; else 0
real(r8), pointer :: htmx(:) ! max hgt attained by a crop during yr
real(r8), pointer :: gdd020(:) ! 20-yr means of same variables
real(r8), pointer :: gdd820(:)
real(r8), pointer :: gdd1020(:)
integer , pointer :: harvdate(:)
integer , pointer :: peaklai(:) ! 1: max allowed lai; 0: not at max
integer , pointer :: cropplant(:) ! field can be planted = 0; else 1
real(r8), pointer :: vf(:) ! vernalization factor for wheat
#endif
real(r8), pointer :: frootc(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: livestemc(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: deadstemc(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: livecrootc(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: deadcrootc(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: cpool(:) ! (gC/m2) temporary photosynthate C pool
real(r8), pointer :: xsmrpool(:) ! (gC/m2) abstract C pool to meet excess MR demand
real(r8), pointer :: leafn(:) ! (gN/m2) leaf N
real(r8), pointer :: leafn_storage(:) ! (gN/m2) leaf N storage
real(r8), pointer :: leafn_xfer(:) ! (gN/m2) leaf N transfer
#if (defined CROP)
real(r8), pointer :: grainn(:) ! (gN/m2) grain N
real(r8), pointer :: grainn_storage(:) ! (gN/m2) grain N storage
real(r8), pointer :: grainn_xfer(:) ! (gN/m2) grain N transfer
#endif
real(r8), pointer :: frootn(:) ! (gN/m2) fine root N
real(r8), pointer :: frootn_storage(:) ! (gN/m2) fine root N storage
real(r8), pointer :: frootn_xfer(:) ! (gN/m2) fine root N transfer
real(r8), pointer :: livestemn(:) ! (gN/m2) live stem N
real(r8), pointer :: livestemn_storage(:) ! (gN/m2) live stem N storage
real(r8), pointer :: livestemn_xfer(:) ! (gN/m2) live stem N transfer
real(r8), pointer :: deadstemn(:) ! (gN/m2) dead stem N
real(r8), pointer :: deadstemn_storage(:) ! (gN/m2) dead stem N storage
real(r8), pointer :: deadstemn_xfer(:) ! (gN/m2) dead stem N transfer
real(r8), pointer :: livecrootn(:) ! (gN/m2) live coarse root N
real(r8), pointer :: livecrootn_storage(:) ! (gN/m2) live coarse root N storage
real(r8), pointer :: livecrootn_xfer(:) ! (gN/m2) live coarse root N transfer
real(r8), pointer :: deadcrootn(:) ! (gN/m2) dead coarse root N
real(r8), pointer :: deadcrootn_storage(:) ! (gN/m2) dead coarse root N storage
real(r8), pointer :: deadcrootn_xfer(:) ! (gN/m2) dead coarse root N transfer
real(r8), pointer :: retransn(:) ! (gN/m2) plant pool of retranslocated N
real(r8), pointer :: npool(:) ! (gN/m2) temporary plant N pool
real(r8), pointer :: psnsun(:) ! sunlit leaf photosynthesis (umol CO2 /m**2/ s)
real(r8), pointer :: psnsha(:) ! shaded leaf photosynthesis (umol CO2 /m**2/ s)
#if (defined C13)
real(r8), pointer :: c13_psnsun(:) ! sunlit leaf photosynthesis (umol CO2 /m**2/ s)
real(r8), pointer :: c13_psnsha(:) ! shaded leaf photosynthesis (umol CO2 /m**2/ s)
#endif
real(r8), pointer :: laisun(:) ! sunlit projected leaf area index
real(r8), pointer :: laisha(:) ! shaded projected leaf area index
real(r8), pointer :: dormant_flag(:) ! dormancy flag
real(r8), pointer :: days_active(:) ! number of days since last dormancy
real(r8), pointer :: onset_flag(:) ! onset flag
real(r8), pointer :: onset_counter(:) ! onset days counter
real(r8), pointer :: onset_gddflag(:) ! onset flag for growing degree day sum
real(r8), pointer :: onset_fdd(:) ! onset freezing degree days counter
real(r8), pointer :: onset_gdd(:) ! onset growing degree days
real(r8), pointer :: onset_swi(:) ! onset soil water index
real(r8), pointer :: offset_flag(:) ! offset flag
real(r8), pointer :: offset_counter(:) ! offset days counter
real(r8), pointer :: offset_fdd(:) ! offset freezing degree days counter
real(r8), pointer :: offset_swi(:) ! offset soil water index
real(r8), pointer :: lgsf(:) ! long growing season factor [0-1]
real(r8), pointer :: bglfr(:) ! background litterfall rate (1/s)
real(r8), pointer :: bgtr(:) ! background transfer rate (1/s)
real(r8), pointer :: dayl(:) ! daylength (seconds)
real(r8), pointer :: prev_dayl(:) ! daylength from previous timestep (seconds)
real(r8), pointer :: annavg_t2m(:) ! annual average 2m air temperature (K)
real(r8), pointer :: tempavg_t2m(:) ! temporary average 2m air temperature (K)
real(r8), pointer :: gpp(:) ! GPP flux before downregulation (gC/m2/s)
real(r8), pointer :: availc(:) ! C flux available for allocation (gC/m2/s)
real(r8), pointer :: xsmrpool_recover(:) ! C flux assigned to recovery of negative cpool (gC/m2/s)
#if (defined C13)
real(r8), pointer :: xsmrpool_c13ratio(:) ! C flux assigned to recovery of negative cpool (gC/m2/s)
#endif
real(r8), pointer :: alloc_pnow(:) ! fraction of current allocation to display as new growth (DIM)
real(r8), pointer :: c_allometry(:) ! C allocation index (DIM)
real(r8), pointer :: n_allometry(:) ! N allocation index (DIM)
real(r8), pointer :: plant_ndemand(:) ! N flux required to support initial GPP (gN/m2/s)
real(r8), pointer :: tempsum_potential_gpp(:) ! temporary annual sum of plant_ndemand
real(r8), pointer :: annsum_potential_gpp(:) ! annual sum of plant_ndemand
real(r8), pointer :: tempmax_retransn(:) ! temporary max of retranslocated N pool (gN/m2)
real(r8), pointer :: annmax_retransn(:) ! annual max of retranslocated N pool (gN/m2)
real(r8), pointer :: avail_retransn(:) ! N flux available from retranslocation pool (gN/m2/s)
real(r8), pointer :: plant_nalloc(:) ! total allocated N flux (gN/m2/s)
real(r8), pointer :: plant_calloc(:) ! total allocated C flux (gC/m2/s)
real(r8), pointer :: excess_cflux(:) ! C flux not allocated due to downregulation (gC/m2/s)
real(r8), pointer :: downreg(:) ! fractional reduction in GPP due to N limitation (DIM)
real(r8), pointer :: tempsum_npp(:) ! temporary annual sum of NPP
real(r8), pointer :: annsum_npp(:) ! annual sum of NPP
#if (defined CNDV)
real(r8), pointer :: tempsum_litfall(:) ! temporary annual sum of litfall
real(r8), pointer :: annsum_litfall(:) ! annual sum of litfall
#endif
#if (defined C13)
real(r8), pointer :: rc13_canair(:) !C13O2/C12O2 in canopy air
real(r8), pointer :: rc13_psnsun(:) !C13O2/C12O2 in sunlit canopy psn flux
real(r8), pointer :: rc13_psnsha(:) !C13O2/C12O2 in shaded canopy psn flux
real(r8), pointer :: alphapsnsun(:) !sunlit 13c fractionation ([])
real(r8), pointer :: alphapsnsha(:) !shaded 13c fractionation ([])
#endif
real(r8), pointer :: qflx_drain(:) ! sub-surface runoff (mm H2O /s)
! new variables for fire
real(r8), pointer :: wf(:) ! soil moisture in top 0.5 m
real(r8), pointer :: me(:) ! moisture of extinction (proportion)
real(r8), pointer :: fire_prob(:) ! daily fire probability (0-1)
real(r8), pointer :: mean_fire_prob(:) ! e-folding mean of daily fire probability (0-1)
real(r8), pointer :: fireseasonl(:) ! annual fire season length (days, <= 365)
real(r8), pointer :: farea_burned(:) ! timestep fractional area burned (proportion)
real(r8), pointer :: ann_farea_burned(:) ! annual total fractional area burned (proportion)
real(r8), pointer :: col_ctrunc(:) ! (gC/m2) column-level sink for C truncation
real(r8), pointer :: totcolc(:) ! (gC/m2) total column carbon, incl veg and cpool
real(r8), pointer :: totecosysc(:) ! (gC/m2) total ecosystem carbon, incl veg but excl cpool
real(r8), pointer :: totlitc(:) ! (gC/m2) total litter carbon
real(r8), pointer :: totsomc(:) ! (gC/m2) total soil organic matter carbon
#if (defined CLAMP)
! new CLAMP state variables
real(r8), pointer :: woodc(:) ! (gC/m2) pft-level wood C
#endif
real(r8), pointer :: col_ntrunc(:) ! (gN/m2) column-level sink for N truncation
real(r8), pointer :: totcoln(:) ! (gN/m2) total column nitrogen, incl veg
real(r8), pointer :: totecosysn(:) ! (gN/m2) total ecosystem nitrogen, incl veg
real(r8), pointer :: totlitn(:) ! (gN/m2) total litter nitrogen
real(r8), pointer :: totsomn(:) ! (gN/m2) total soil organic matter nitrogen
real(r8), pointer :: dispvegc(:) ! (gC/m2) displayed veg carbon, excluding storage and cpool
real(r8), pointer :: pft_ctrunc(:) ! (gC/m2) pft-level sink for C truncation
real(r8), pointer :: storvegc(:) ! (gC/m2) stored vegetation carbon, excluding cpool
real(r8), pointer :: totpftc(:) ! (gC/m2) total pft-level carbon, including cpool
real(r8), pointer :: totvegc(:) ! (gC/m2) total vegetation carbon, excluding cpool
real(r8), pointer :: prev_frootc_to_litter(:)!previous timestep froot C litterfall flux (gC/m2/s)
real(r8), pointer :: prev_leafc_to_litter(:) !previous timestep leaf C litterfall flux (gC/m2/s)
real(r8), pointer :: dispvegn(:) ! (gN/m2) displayed veg nitrogen, excluding storage
real(r8), pointer :: pft_ntrunc(:) ! (gN/m2) pft-level sink for N truncation
real(r8), pointer :: storvegn(:) ! (gN/m2) stored vegetation nitrogen
real(r8), pointer :: totpftn(:) ! (gN/m2) total pft-level nitrogen
real(r8), pointer :: totvegn(:) ! (gN/m2) total vegetation nitrogen
real(r8), pointer :: lncsha(:) ! leaf N concentration per unit projected LAI (gN leaf/m^2)
real(r8), pointer :: lncsun(:) ! leaf N concentration per unit projected LAI (gN leaf/m^2)
real(r8), pointer :: vcmxsha(:) ! shaded leaf Vcmax (umolCO2/m^2/s)
real(r8), pointer :: vcmxsun(:) ! sunlit leaf Vcmax (umolCO2/m^2/s)
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
real(r8), pointer :: cwdc13(:) ! (gC/m2) coarse woody debris C
real(r8), pointer :: litr1c13(:) ! (gC/m2) litter labile C
real(r8), pointer :: litr2c13(:) ! (gC/m2) litter cellulose C
real(r8), pointer :: litr3c13(:) ! (gC/m2) litter lignin C
real(r8), pointer :: soil1c13(:) ! (gC/m2) soil organic matter C (fast pool)
real(r8), pointer :: soil2c13(:) ! (gC/m2) soil organic matter C (medium pool)
real(r8), pointer :: soil3c13(:) ! (gC/m2) soil organic matter C (slow pool)
real(r8), pointer :: soil4c13(:) ! (gC/m2) soil organic matter C (slowest pool)
real(r8), pointer :: c13_col_ctrunc(:) ! (gC/m2) C truncation term
real(r8), pointer :: leafc13(:) ! (gC/m2) leaf C
real(r8), pointer :: leafc13_storage(:) ! (gC/m2) leaf C storage
real(r8), pointer :: leafc13_xfer(:) ! (gC/m2) leaf C transfer
#if (defined CROP)
real(r8), pointer :: grainc13(:) ! (gC/m2) grain C
real(r8), pointer :: grainc13_storage(:) ! (gC/m2) grain C storage
real(r8), pointer :: grainc13_xfer(:) ! (gC/m2) grain C transfer
#endif
real(r8), pointer :: frootc13(:) ! (gC/m2) fine root C
real(r8), pointer :: frootc13_storage(:) ! (gC/m2) fine root C storage
real(r8), pointer :: frootc13_xfer(:) ! (gC/m2) fine root C transfer
real(r8), pointer :: livestemc13(:) ! (gC/m2) live stem C
real(r8), pointer :: livestemc13_storage(:) ! (gC/m2) live stem C storage
real(r8), pointer :: livestemc13_xfer(:) ! (gC/m2) live stem C transfer
real(r8), pointer :: deadstemc13(:) ! (gC/m2) dead stem C
real(r8), pointer :: deadstemc13_storage(:) ! (gC/m2) dead stem C storage
real(r8), pointer :: deadstemc13_xfer(:) ! (gC/m2) dead stem C transfer
real(r8), pointer :: livecrootc13(:) ! (gC/m2) live coarse root C
real(r8), pointer :: livecrootc13_storage(:) ! (gC/m2) live coarse root C storage
real(r8), pointer :: livecrootc13_xfer(:) ! (gC/m2) live coarse root C transfer
real(r8), pointer :: deadcrootc13(:) ! (gC/m2) dead coarse root C
real(r8), pointer :: deadcrootc13_storage(:) ! (gC/m2) dead coarse root C storage
real(r8), pointer :: deadcrootc13_xfer(:) ! (gC/m2) dead coarse root C transfer
real(r8), pointer :: c13_gresp_storage(:) ! (gC/m2) growth respiration storage
real(r8), pointer :: c13_gresp_xfer(:) ! (gC/m2) growth respiration transfer
real(r8), pointer :: c13pool(:) ! (gC/m2) temporary photosynthate C pool
real(r8), pointer :: c13xsmrpool(:) ! (gC/m2) temporary photosynthate C pool
real(r8), pointer :: c13_pft_ctrunc(:) ! (gC/m2) C truncation term
real(r8), pointer :: totvegc13(:) ! (gC/m2) total vegetation carbon, excluding cpool
#endif
! dynamic landuse variables
real(r8), pointer :: seedc(:) ! (gC/m2) column-level pool for seeding new PFTs
real(r8), pointer :: prod10c(:) ! (gC/m2) wood product C pool, 10-year lifespan
real(r8), pointer :: prod100c(:) ! (gC/m2) wood product C pool, 100-year lifespan
real(r8), pointer :: totprodc(:) ! (gC/m2) total wood product C
#if (defined C13)
real(r8), pointer :: seedc13(:) ! (gC/m2) column-level pool for seeding new PFTs
real(r8), pointer :: prod10c13(:) ! (gC/m2) wood product C13 pool, 10-year lifespan
real(r8), pointer :: prod100c13(:) ! (gC/m2) wood product C13 pool, 100-year lifespan
real(r8), pointer :: totprodc13(:) ! (gC/m2) total wood product C13
#endif
real(r8), pointer :: seedn(:) ! (gN/m2) column-level pool for seeding new PFTs
real(r8), pointer :: prod10n(:) ! (gN/m2) wood product N pool, 10-year lifespan
real(r8), pointer :: prod100n(:) ! (gN/m2) wood product N pool, 100-year lifespan
real(r8), pointer :: totprodn(:) ! (gN/m2) total wood product N
!CN CROP vars
!CROP&CN buf variables
integer,dimension(maxpatch) :: croplive_buf
real(r8), dimension(maxpatch) :: &
htmx_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf
!
! !LOCAL VARIABLES:
integer :: g,l,c,p ! indices
integer :: begp, endp ! per-clump/proc beginning and ending pft indices
integer :: begc, endc ! per-clump/proc beginning and ending column indices
integer :: begl, endl ! per-clump/proc beginning and ending landunit indices
integer :: begg, endg ! per-clump/proc gridcell ending gridcell indices
!EOP
!-----------------------------------------------------------------------
! assign local pointers at the gridcell level
! assign local pointers at the landunit level
lakpoi => clm3%g%l%lakpoi
itypelun => clm3%g%l%itype
! assign local pointers at the column level
clandunit => clm3%g%l%c%landunit
annsum_counter => clm3%g%l%c%cps%annsum_counter
cannsum_npp => clm3%g%l%c%cps%cannsum_npp
cannavg_t2m => clm3%g%l%c%cps%cannavg_t2m
wf => clm3%g%l%c%cps%wf
me => clm3%g%l%c%cps%me
fire_prob => clm3%g%l%c%cps%fire_prob
mean_fire_prob => clm3%g%l%c%cps%mean_fire_prob
fireseasonl => clm3%g%l%c%cps%fireseasonl
farea_burned => clm3%g%l%c%cps%farea_burned
ann_farea_burned => clm3%g%l%c%cps%ann_farea_burned
qflx_drain => clm3%g%l%c%cwf%qflx_drain
cwdc => clm3%g%l%c%ccs%cwdc
litr1c => clm3%g%l%c%ccs%litr1c
litr2c => clm3%g%l%c%ccs%litr2c
litr3c => clm3%g%l%c%ccs%litr3c
soil1c => clm3%g%l%c%ccs%soil1c
soil2c => clm3%g%l%c%ccs%soil2c
soil3c => clm3%g%l%c%ccs%soil3c
soil4c => clm3%g%l%c%ccs%soil4c
! dynamic landuse variables
seedc => clm3%g%l%c%ccs%seedc
prod10c => clm3%g%l%c%ccs%prod10c
prod100c => clm3%g%l%c%ccs%prod100c
totprodc => clm3%g%l%c%ccs%totprodc
#if (defined C13)
seedc13 => clm3%g%l%c%cc13s%seedc
prod10c13 => clm3%g%l%c%cc13s%prod10c
prod100c13 => clm3%g%l%c%cc13s%prod100c
totprodc13 => clm3%g%l%c%cc13s%totprodc
#endif
seedn => clm3%g%l%c%cns%seedn
prod10n => clm3%g%l%c%cns%prod10n
prod100n => clm3%g%l%c%cns%prod100n
totprodn => clm3%g%l%c%cns%totprodn
cwdn => clm3%g%l%c%cns%cwdn
litr1n => clm3%g%l%c%cns%litr1n
litr2n => clm3%g%l%c%cns%litr2n
litr3n => clm3%g%l%c%cns%litr3n
soil1n => clm3%g%l%c%cns%soil1n
soil2n => clm3%g%l%c%cns%soil2n
soil3n => clm3%g%l%c%cns%soil3n
soil4n => clm3%g%l%c%cns%soil4n
sminn => clm3%g%l%c%cns%sminn
col_ctrunc => clm3%g%l%c%ccs%col_ctrunc
totcolc => clm3%g%l%c%ccs%totcolc
totecosysc => clm3%g%l%c%ccs%totecosysc
totlitc => clm3%g%l%c%ccs%totlitc
totsomc => clm3%g%l%c%ccs%totsomc
col_ntrunc => clm3%g%l%c%cns%col_ntrunc
totcoln => clm3%g%l%c%cns%totcoln
totecosysn => clm3%g%l%c%cns%totecosysn
totlitn => clm3%g%l%c%cns%totlitn
totsomn => clm3%g%l%c%cns%totsomn
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
cwdc13 => clm3%g%l%c%cc13s%cwdc
litr1c13 => clm3%g%l%c%cc13s%litr1c
litr2c13 => clm3%g%l%c%cc13s%litr2c
litr3c13 => clm3%g%l%c%cc13s%litr3c
soil1c13 => clm3%g%l%c%cc13s%soil1c
soil2c13 => clm3%g%l%c%cc13s%soil2c
soil3c13 => clm3%g%l%c%cc13s%soil3c
soil4c13 => clm3%g%l%c%cc13s%soil4c
c13_col_ctrunc => clm3%g%l%c%cc13s%col_ctrunc
#endif
! assign local pointers at the pft level
ivt => clm3%g%l%c%p%itype
plandunit => clm3%g%l%c%p%landunit
leafc => clm3%g%l%c%p%pcs%leafc
leafc_storage => clm3%g%l%c%p%pcs%leafc_storage
leafc_xfer => clm3%g%l%c%p%pcs%leafc_xfer
#if (defined CROP)
grainc => clm3%g%l%c%p%pcs%grainc
grainc_storage => clm3%g%l%c%p%pcs%grainc_storage
grainc_xfer => clm3%g%l%c%p%pcs%grainc_xfer
gdd020 => clm3%g%l%c%p%pps%gdd020
gdd820 => clm3%g%l%c%p%pps%gdd820
gdd1020 => clm3%g%l%c%p%pps%gdd1020
croplive => clm3%g%l%c%p%pps%croplive
htmx => clm3%g%l%c%p%pps%htmx
harvdate => clm3%g%l%c%p%pps%harvdate
peaklai => clm3%g%l%c%p%pps%peaklai
cropplant => clm3%g%l%c%p%pps%cropplant
vf => clm3%g%l%c%p%pps%vf
#endif
frootc => clm3%g%l%c%p%pcs%frootc
frootc_storage => clm3%g%l%c%p%pcs%frootc_storage
frootc_xfer => clm3%g%l%c%p%pcs%frootc_xfer
livestemc => clm3%g%l%c%p%pcs%livestemc
livestemc_storage => clm3%g%l%c%p%pcs%livestemc_storage
livestemc_xfer => clm3%g%l%c%p%pcs%livestemc_xfer
deadstemc => clm3%g%l%c%p%pcs%deadstemc
deadstemc_storage => clm3%g%l%c%p%pcs%deadstemc_storage
deadstemc_xfer => clm3%g%l%c%p%pcs%deadstemc_xfer
livecrootc => clm3%g%l%c%p%pcs%livecrootc
livecrootc_storage => clm3%g%l%c%p%pcs%livecrootc_storage
livecrootc_xfer => clm3%g%l%c%p%pcs%livecrootc_xfer
deadcrootc => clm3%g%l%c%p%pcs%deadcrootc
deadcrootc_storage => clm3%g%l%c%p%pcs%deadcrootc_storage
deadcrootc_xfer => clm3%g%l%c%p%pcs%deadcrootc_xfer
gresp_storage => clm3%g%l%c%p%pcs%gresp_storage
gresp_xfer => clm3%g%l%c%p%pcs%gresp_xfer
cpool => clm3%g%l%c%p%pcs%cpool
xsmrpool => clm3%g%l%c%p%pcs%xsmrpool
forc_hgt_u_pft => clm3%g%l%c%p%pps%forc_hgt_u_pft
#if (defined CLAMP)
! CLAMP variable
woodc => clm3%g%l%c%p%pcs%woodc
#endif
leafn => clm3%g%l%c%p%pns%leafn
leafn_storage => clm3%g%l%c%p%pns%leafn_storage
leafn_xfer => clm3%g%l%c%p%pns%leafn_xfer
#if (defined CROP)
grainn => clm3%g%l%c%p%pns%grainn
grainn_storage => clm3%g%l%c%p%pns%grainn_storage
grainn_xfer => clm3%g%l%c%p%pns%grainn_xfer
#endif
frootn => clm3%g%l%c%p%pns%frootn
frootn_storage => clm3%g%l%c%p%pns%frootn_storage
frootn_xfer => clm3%g%l%c%p%pns%frootn_xfer
livestemn => clm3%g%l%c%p%pns%livestemn
livestemn_storage => clm3%g%l%c%p%pns%livestemn_storage
livestemn_xfer => clm3%g%l%c%p%pns%livestemn_xfer
deadstemn => clm3%g%l%c%p%pns%deadstemn
deadstemn_storage => clm3%g%l%c%p%pns%deadstemn_storage
deadstemn_xfer => clm3%g%l%c%p%pns%deadstemn_xfer
livecrootn => clm3%g%l%c%p%pns%livecrootn
livecrootn_storage => clm3%g%l%c%p%pns%livecrootn_storage
livecrootn_xfer => clm3%g%l%c%p%pns%livecrootn_xfer
deadcrootn => clm3%g%l%c%p%pns%deadcrootn
deadcrootn_storage => clm3%g%l%c%p%pns%deadcrootn_storage
deadcrootn_xfer => clm3%g%l%c%p%pns%deadcrootn_xfer
retransn => clm3%g%l%c%p%pns%retransn
npool => clm3%g%l%c%p%pns%npool
psnsun => clm3%g%l%c%p%pcf%psnsun
psnsha => clm3%g%l%c%p%pcf%psnsha
#if (defined C13)
c13_psnsun => clm3%g%l%c%p%pc13f%psnsun
c13_psnsha => clm3%g%l%c%p%pc13f%psnsha
#endif
laisun => clm3%g%l%c%p%pps%laisun
laisha => clm3%g%l%c%p%pps%laisha
dormant_flag => clm3%g%l%c%p%pepv%dormant_flag
days_active => clm3%g%l%c%p%pepv%days_active
onset_flag => clm3%g%l%c%p%pepv%onset_flag
onset_counter => clm3%g%l%c%p%pepv%onset_counter
onset_gddflag => clm3%g%l%c%p%pepv%onset_gddflag
onset_fdd => clm3%g%l%c%p%pepv%onset_fdd
onset_gdd => clm3%g%l%c%p%pepv%onset_gdd
onset_swi => clm3%g%l%c%p%pepv%onset_swi
offset_flag => clm3%g%l%c%p%pepv%offset_flag
offset_counter => clm3%g%l%c%p%pepv%offset_counter
offset_fdd => clm3%g%l%c%p%pepv%offset_fdd
offset_swi => clm3%g%l%c%p%pepv%offset_swi
lgsf => clm3%g%l%c%p%pepv%lgsf
bglfr => clm3%g%l%c%p%pepv%bglfr
bgtr => clm3%g%l%c%p%pepv%bgtr
dayl => clm3%g%l%c%p%pepv%dayl
prev_dayl => clm3%g%l%c%p%pepv%prev_dayl
annavg_t2m => clm3%g%l%c%p%pepv%annavg_t2m
tempavg_t2m => clm3%g%l%c%p%pepv%tempavg_t2m
gpp => clm3%g%l%c%p%pepv%gpp
availc => clm3%g%l%c%p%pepv%availc
xsmrpool_recover => clm3%g%l%c%p%pepv%xsmrpool_recover
#if (defined C13)
xsmrpool_c13ratio => clm3%g%l%c%p%pepv%xsmrpool_c13ratio
#endif
alloc_pnow => clm3%g%l%c%p%pepv%alloc_pnow
c_allometry => clm3%g%l%c%p%pepv%c_allometry
n_allometry => clm3%g%l%c%p%pepv%n_allometry
plant_ndemand => clm3%g%l%c%p%pepv%plant_ndemand
tempsum_potential_gpp => clm3%g%l%c%p%pepv%tempsum_potential_gpp
annsum_potential_gpp => clm3%g%l%c%p%pepv%annsum_potential_gpp
tempmax_retransn => clm3%g%l%c%p%pepv%tempmax_retransn
annmax_retransn => clm3%g%l%c%p%pepv%annmax_retransn
avail_retransn => clm3%g%l%c%p%pepv%avail_retransn
plant_nalloc => clm3%g%l%c%p%pepv%plant_nalloc
plant_calloc => clm3%g%l%c%p%pepv%plant_calloc
excess_cflux => clm3%g%l%c%p%pepv%excess_cflux
downreg => clm3%g%l%c%p%pepv%downreg
tempsum_npp => clm3%g%l%c%p%pepv%tempsum_npp
annsum_npp => clm3%g%l%c%p%pepv%annsum_npp
#if (defined CNDV)
tempsum_litfall => clm3%g%l%c%p%pepv%tempsum_litfall
annsum_litfall => clm3%g%l%c%p%pepv%annsum_litfall
#endif
dispvegc => clm3%g%l%c%p%pcs%dispvegc
pft_ctrunc => clm3%g%l%c%p%pcs%pft_ctrunc
storvegc => clm3%g%l%c%p%pcs%storvegc
totpftc => clm3%g%l%c%p%pcs%totpftc
totvegc => clm3%g%l%c%p%pcs%totvegc
prev_frootc_to_litter => clm3%g%l%c%p%pepv%prev_frootc_to_litter
prev_leafc_to_litter => clm3%g%l%c%p%pepv%prev_leafc_to_litter
dispvegn => clm3%g%l%c%p%pns%dispvegn
pft_ntrunc => clm3%g%l%c%p%pns%pft_ntrunc
storvegn => clm3%g%l%c%p%pns%storvegn
totpftn => clm3%g%l%c%p%pns%totpftn
totvegn => clm3%g%l%c%p%pns%totvegn
lncsha => clm3%g%l%c%p%pps%lncsha
lncsun => clm3%g%l%c%p%pps%lncsun
vcmxsha => clm3%g%l%c%p%pps%vcmxsha
vcmxsun => clm3%g%l%c%p%pps%vcmxsun
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
alphapsnsun => clm3%g%l%c%p%pps%alphapsnsun
alphapsnsha => clm3%g%l%c%p%pps%alphapsnsha
leafc13 => clm3%g%l%c%p%pc13s%leafc
leafc13_storage => clm3%g%l%c%p%pc13s%leafc_storage
leafc13_xfer => clm3%g%l%c%p%pc13s%leafc_xfer
#if (defined CROP)
grainc13 => clm3%g%l%c%p%pc13s%grainc
grainc13_storage => clm3%g%l%c%p%pc13s%grainc_storage
grainc13_xfer => clm3%g%l%c%p%pc13s%grainc_xfer
#endif
frootc13 => clm3%g%l%c%p%pc13s%frootc
frootc13_storage => clm3%g%l%c%p%pc13s%frootc_storage
frootc13_xfer => clm3%g%l%c%p%pc13s%frootc_xfer
livestemc13 => clm3%g%l%c%p%pc13s%livestemc
livestemc13_storage => clm3%g%l%c%p%pc13s%livestemc_storage
livestemc13_xfer => clm3%g%l%c%p%pc13s%livestemc_xfer
deadstemc13 => clm3%g%l%c%p%pc13s%deadstemc
deadstemc13_storage => clm3%g%l%c%p%pc13s%deadstemc_storage
deadstemc13_xfer => clm3%g%l%c%p%pc13s%deadstemc_xfer
livecrootc13 => clm3%g%l%c%p%pc13s%livecrootc
livecrootc13_storage => clm3%g%l%c%p%pc13s%livecrootc_storage
livecrootc13_xfer => clm3%g%l%c%p%pc13s%livecrootc_xfer
deadcrootc13 => clm3%g%l%c%p%pc13s%deadcrootc
deadcrootc13_storage => clm3%g%l%c%p%pc13s%deadcrootc_storage
deadcrootc13_xfer => clm3%g%l%c%p%pc13s%deadcrootc_xfer
c13_gresp_storage => clm3%g%l%c%p%pc13s%gresp_storage
c13_gresp_xfer => clm3%g%l%c%p%pc13s%gresp_xfer
c13pool => clm3%g%l%c%p%pc13s%cpool
c13xsmrpool => clm3%g%l%c%p%pc13s%xsmrpool
c13_pft_ctrunc => clm3%g%l%c%p%pc13s%pft_ctrunc
totvegc13 => clm3%g%l%c%p%pc13s%totvegc
rc13_canair => clm3%g%l%c%p%pepv%rc13_canair
rc13_psnsun => clm3%g%l%c%p%pepv%rc13_psnsun
rc13_psnsha => clm3%g%l%c%p%pepv%rc13_psnsha
#endif
! assign local pointers for ecophysiological constants
evergreen => pftcon%evergreen
woody => pftcon%woody
leafcn => pftcon%leafcn
deadwdcn => pftcon%deadwdcn
! Determine subgrid bounds on this processor
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! Added 5/4/04, PET: initialize forc_hgt_u (gridcell-level),
! since this is not initialized before first call to CNVegStructUpdate,
! and it is required to set the upper bound for canopy top height.
! Changed 3/21/08, KO: still needed but don't have sufficient information
! to set this properly (e.g., pft-level displacement height and roughness
! length). So leave at 30m.
!dir$ concurrent
!cdir nodep
!if this is the first time step, then initiate all variable to the start up value
write(6,*) 'in CNiniTimeVar,nstep=',nstep
IF(nstep == 1) THEN
do p = begp, endp
forc_hgt_u_pft(p) = 30._r8
end do
! initialize column-level variables
!dir$ concurrent
!cdir nodep
do c = begc, endc
l = clandunit(c)
#ifndef CROP
if (itypelun(l) == istsoil) then
#else
if (itypelun(l) == istsoil .or. itypelun(l) == istcrop) then
#endif
! column physical state variables
annsum_counter(c) = 0._r8
cannsum_npp(c) = 0._r8
cannavg_t2m(c) = 280._r8
wf(c) = 1.0_r8 ! it needs to be non zero so the first time step has no fires
me(c) = 0._r8
fire_prob(c) = 0._r8
mean_fire_prob(c) = 0._r8
fireseasonl(c) = 0._r8
farea_burned(c) = 0._r8
ann_farea_burned(c) = 0._r8
! needed for CNNLeaching
qflx_drain(c) = 0._r8
! column carbon state variable initialization
cwdc(c) = 0._r8
litr1c(c) = 0._r8
litr2c(c) = 0._r8
litr3c(c) = 0._r8
soil1c(c) = 0._r8
soil2c(c) = 0._r8
soil3c(c) = 0._r8
soil4c(c) = 10._r8
col_ctrunc(c) = 0._r8
totlitc(c) = 0._r8
totsomc(c) = 0._r8
totecosysc(c) = 0._r8
totcolc(c) = 0._r8
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
cwdc13(c) = cwdc(c) * c13ratio
litr1c13(c) = litr1c(c) * c13ratio
litr2c13(c) = litr2c(c) * c13ratio
litr3c13(c) = litr3c(c) * c13ratio
soil1c13(c) = soil1c(c) * c13ratio
soil2c13(c) = soil2c(c) * c13ratio
soil3c13(c) = soil3c(c) * c13ratio
soil4c13(c) = soil4c(c) * c13ratio
c13_col_ctrunc(c) = col_ctrunc(c) * c13ratio
#endif
! column nitrogen state variables
cwdn(c) = cwdc(c) / 500._r8
litr1n(c) = litr1c(c) / 90._r8
litr2n(c) = litr2c(c) / 90._r8
litr3n(c) = litr3c(c) / 90._r8
soil1n(c) = soil1c(c) / 12._r8
soil2n(c) = soil2c(c) / 12._r8
soil3n(c) = soil3c(c) / 10._r8
soil4n(c) = soil4c(c) / 10._r8
sminn(c) = 0._r8
col_ntrunc(c) = 0._r8
totlitn(c) = 0._r8
totsomn(c) = 0._r8
totecosysn(c) = 0._r8
totcoln(c) = 0._r8
! dynamic landcover state variables
seedc(c) = 0._r8
prod10c(c) = 0._r8
prod100c(c) = 0._r8
totprodc(c) = 0._r8
#if (defined C13)
seedc13(c) = 0._r8
prod10c13(c) = 0._r8
prod100c13(c) = 0._r8
totprodc13(c) = 0._r8
#endif
seedn(c) = 0._r8
prod10n(c) = 0._r8
prod100n(c) = 0._r8
totprodn(c) = 0._r8
! also initialize dynamic landcover fluxes so that they have
! real values on first timestep, prior to calling pftdyn_cnbal
clm3%g%l%c%ccf%dwt_seedc_to_leaf(c) = 0._r8
clm3%g%l%c%ccf%dwt_seedc_to_deadstem(c) = 0._r8
clm3%g%l%c%ccf%dwt_conv_cflux(c) = 0._r8
clm3%g%l%c%ccf%dwt_prod10c_gain(c) = 0._r8
clm3%g%l%c%ccf%prod10c_loss(c) = 0._r8
clm3%g%l%c%ccf%dwt_prod100c_gain(c) = 0._r8
clm3%g%l%c%ccf%prod100c_loss(c) = 0._r8
clm3%g%l%c%ccf%dwt_frootc_to_litr1c(c) = 0._r8
clm3%g%l%c%ccf%dwt_frootc_to_litr2c(c) = 0._r8
clm3%g%l%c%ccf%dwt_frootc_to_litr3c(c) = 0._r8
clm3%g%l%c%ccf%dwt_livecrootc_to_cwdc(c) = 0._r8
clm3%g%l%c%ccf%dwt_deadcrootc_to_cwdc(c) = 0._r8
clm3%g%l%c%ccf%dwt_closs(c) = 0._r8
#if (defined C13)
clm3%g%l%c%cc13f%dwt_seedc_to_leaf(c) = 0._r8
clm3%g%l%c%cc13f%dwt_seedc_to_deadstem(c) = 0._r8
clm3%g%l%c%cc13f%dwt_conv_cflux(c) = 0._r8
clm3%g%l%c%cc13f%dwt_prod10c_gain(c) = 0._r8
clm3%g%l%c%cc13f%prod10c_loss(c) = 0._r8
clm3%g%l%c%cc13f%dwt_prod100c_gain(c) = 0._r8
clm3%g%l%c%cc13f%prod100c_loss(c) = 0._r8
clm3%g%l%c%cc13f%dwt_frootc_to_litr1c(c) = 0._r8
clm3%g%l%c%cc13f%dwt_frootc_to_litr2c(c) = 0._r8
clm3%g%l%c%cc13f%dwt_frootc_to_litr3c(c) = 0._r8
clm3%g%l%c%cc13f%dwt_livecrootc_to_cwdc(c) = 0._r8
clm3%g%l%c%cc13f%dwt_deadcrootc_to_cwdc(c) = 0._r8
clm3%g%l%c%cc13f%dwt_closs(c) = 0._r8
#endif
clm3%g%l%c%cnf%dwt_seedn_to_leaf(c) = 0._r8
clm3%g%l%c%cnf%dwt_seedn_to_deadstem(c) = 0._r8
clm3%g%l%c%cnf%dwt_conv_nflux(c) = 0._r8
clm3%g%l%c%cnf%dwt_prod10n_gain(c) = 0._r8
clm3%g%l%c%cnf%prod10n_loss(c) = 0._r8
clm3%g%l%c%cnf%dwt_prod100n_gain(c) = 0._r8
clm3%g%l%c%cnf%prod100n_loss(c) = 0._r8
clm3%g%l%c%cnf%dwt_frootn_to_litr1n(c) = 0._r8
clm3%g%l%c%cnf%dwt_frootn_to_litr2n(c) = 0._r8
clm3%g%l%c%cnf%dwt_frootn_to_litr3n(c) = 0._r8
clm3%g%l%c%cnf%dwt_livecrootn_to_cwdn(c) = 0._r8
clm3%g%l%c%cnf%dwt_deadcrootn_to_cwdn(c) = 0._r8
clm3%g%l%c%cnf%dwt_nloss(c) = 0._r8
end if
end do
! initialize pft-level variables
!dir$ concurrent
!cdir nodep
do p = begp, endp
l = plandunit(p)
#ifndef CROP
if (itypelun(l) == istsoil) then
#else
if (itypelun(l) == istsoil .or. itypelun(l) == istcrop) then
#endif
! carbon state variables
if (ivt(p) == noveg) then
leafc(p) = 0._r8
leafc_storage(p) = 0._r8
else
if (evergreen(ivt(p)) == 1._r8) then
leafc(p) = 1._r8
leafc_storage(p) = 0._r8
#if (defined CROP)
else if (ivt(p) >= npcropmin) then ! prognostic crop types
leafc(p) = 0._r8
leafc_storage(p) = 0._r8
#endif
else
leafc(p) = 0._r8
leafc_storage(p) = 1._r8
end if
end if
leafc_xfer(p) = 0._r8
#if (defined CROP)
grainc(p) = 0._r8
grainc_storage(p) = 0._r8
grainc_xfer(p) = 0._r8
htmx(p) = 0._r8! max hgt attained by a crop during yr
vf(p) = 0._r8! vernalization factor for wheat
croplive(p) = 0._r8! added the rest here to avoid nans in non-crop
cropplant(p) = 0._r8! pfts in output files (slevis)
harvdate(p) = 999
peaklai(p) = 0 ! 1: max allowed lai; 0: not at max
#endif
frootc(p) = 0._r8
frootc_storage(p) = 0._r8
frootc_xfer(p) = 0._r8
livestemc(p) = 0._r8
livestemc_storage(p) = 0._r8
livestemc_xfer(p) = 0._r8
! tree types need to be initialized with some stem mass so that
! roughness length is not zero in canopy flux calculation
if (woody(ivt(p)) == 1._r8) then
deadstemc(p) = 0.1_r8
else
deadstemc(p) = 0._r8
end if
write(6,*) 'in CNiniTimeVar, deadstemc(',p,')=',deadstemc(p)
deadstemc_storage(p) = 0._r8
deadstemc_xfer(p) = 0._r8
livecrootc(p) = 0._r8
livecrootc_storage(p) = 0._r8
livecrootc_xfer(p) = 0._r8
deadcrootc(p) = 0._r8
deadcrootc_storage(p) = 0._r8
deadcrootc_xfer(p) = 0._r8
gresp_storage(p) = 0._r8
gresp_xfer(p) = 0._r8
cpool(p) = 0._r8
xsmrpool(p) = 0._r8
pft_ctrunc(p) = 0._r8
dispvegc(p) = 0._r8
storvegc(p) = 0._r8
totpftc(p) = 0._r8
! calculate totvegc explicitly so that it is available for the isotope
! code on the first time step.
totvegc(p) = leafc(p) + leafc_storage(p) + leafc_xfer(p) + frootc(p) + &
frootc_storage(p) + frootc_xfer(p) + livestemc(p) + livestemc_storage(p) + &
livestemc_xfer(p) + deadstemc(p) + deadstemc_storage(p) + deadstemc_xfer(p) + &
livecrootc(p) + livecrootc_storage(p) + livecrootc_xfer(p) + deadcrootc(p) + &
deadcrootc_storage(p) + deadcrootc_xfer(p) + gresp_storage(p) + &
gresp_xfer(p) + cpool(p)
#if (defined CLAMP)
! CLAMP variables
woodc(p) = 0._r8
#endif
#if (defined C13)
! 4/14/05: PET
! Adding isotope code
leafc13(p) = leafc(p) * c13ratio
leafc13_storage(p) = leafc_storage(p) * c13ratio
leafc13_xfer(p) = leafc_xfer(p) * c13ratio
#if (defined CROP)
grainc13(p) = grainc(p) * c13ratio
grainc13_storage(p) = grainc_storage(p) * c13ratio
grainc13_xfer(p) = grainc_xfer(p) * c13ratio
#endif
frootc13(p) = frootc(p) * c13ratio
frootc13_storage(p) = frootc_storage(p) * c13ratio
frootc13_xfer(p) = frootc_xfer(p) * c13ratio
livestemc13(p) = livestemc(p) * c13ratio
livestemc13_storage(p) = livestemc_storage(p) * c13ratio
livestemc13_xfer(p) = livestemc_xfer(p) * c13ratio
deadstemc13(p) = deadstemc(p) * c13ratio
deadstemc13_storage(p) = deadstemc_storage(p) * c13ratio
deadstemc13_xfer(p) = deadstemc_xfer(p) * c13ratio
livecrootc13(p) = livecrootc(p) * c13ratio
livecrootc13_storage(p) = livecrootc_storage(p) * c13ratio
livecrootc13_xfer(p) = livecrootc_xfer(p) * c13ratio
deadcrootc13(p) = deadcrootc(p) * c13ratio
deadcrootc13_storage(p) = deadcrootc_storage(p) * c13ratio
deadcrootc13_xfer(p) = deadcrootc_xfer(p) * c13ratio
c13_gresp_storage(p) = gresp_storage(p) * c13ratio
c13_gresp_xfer(p) = gresp_xfer(p) * c13ratio
c13pool(p) = cpool(p) * c13ratio
c13xsmrpool(p) = xsmrpool(p) * c13ratio
c13_pft_ctrunc(p) = pft_ctrunc(p) * c13ratio
! calculate totvegc explicitly so that it is available for the isotope
! code on the first time step.
totvegc13(p) = leafc13(p) + leafc13_storage(p) + leafc13_xfer(p) + frootc13(p) + &
frootc13_storage(p) + frootc13_xfer(p) + livestemc13(p) + livestemc13_storage(p) + &
livestemc13_xfer(p) + deadstemc13(p) + deadstemc13_storage(p) + deadstemc13_xfer(p) + &
livecrootc13(p) + livecrootc13_storage(p) + livecrootc13_xfer(p) + deadcrootc13(p) + &
deadcrootc13_storage(p) + deadcrootc13_xfer(p) + c13_gresp_storage(p) + &
c13_gresp_xfer(p) + c13pool(p)
#endif
! nitrogen state variables
if (ivt(p) == noveg) then
leafn(p) = 0._r8
leafn_storage(p) = 0._r8
else
leafn(p) = leafc(p) / leafcn(ivt(p))
leafn_storage(p) = leafc_storage(p) / leafcn(ivt(p))
end if
leafn_xfer(p) = 0._r8
#if (defined CROP)
grainn(p) = 0._r8
grainn_storage(p) = 0._r8
grainn_xfer(p) = 0._r8
#endif
frootn(p) = 0._r8
frootn_storage(p) = 0._r8
frootn_xfer(p) = 0._r8
livestemn(p) = 0._r8
livestemn_storage(p) = 0._r8
livestemn_xfer(p) = 0._r8
! tree types need to be initialized with some stem mass so that
! roughness length is not zero in canopy flux calculation
if (woody(ivt(p)) == 1._r8) then
deadstemn(p) = deadstemc(p) / deadwdcn(ivt(p))
write(6,*) 'in CNiniTimeVar,deadwdcn(',ivt(p),')=', deadwdcn(ivt(p))
else
deadstemn(p) = 0._r8
end if
write(6,*) 'in CNiniTimeVar, deadstemn(',p,')=',deadstemn(p)
deadstemn_storage(p) = 0._r8
deadstemn_xfer(p) = 0._r8
livecrootn(p) = 0._r8
livecrootn_storage(p) = 0._r8
livecrootn_xfer(p) = 0._r8
deadcrootn(p) = 0._r8
deadcrootn_storage(p) = 0._r8
deadcrootn_xfer(p) = 0._r8
retransn(p) = 0._r8
npool(p) = 0._r8
pft_ntrunc(p) = 0._r8
dispvegn(p) = 0._r8
storvegn(p) = 0._r8
totvegn(p) = 0._r8
totpftn(p) = 0._r8
! initialization for psnsun and psnsha required for
! proper arbitrary initialization of allocation routine
! in initial ecosysdyn call
psnsun(p) = 0._r8
psnsha(p) = 0._r8
#if (defined C13)
c13_psnsun(p) = 0._r8
c13_psnsha(p) = 0._r8
#endif
laisun(p) = 0._r8
laisha(p) = 0._r8
lncsun(p) = 0._r8
lncsha(p) = 0._r8
vcmxsun(p) = 0._r8
vcmxsha(p) = 0._r8
! ecophysiological variables
! phenology variables
dormant_flag(p) = 1._r8
days_active(p) = 0._r8
onset_flag(p) = 0._r8
onset_counter(p) = 0._r8
onset_gddflag(p) = 0._r8
onset_fdd(p) = 0._r8
onset_gdd(p) = 0._r8
onset_swi(p) = 0.0_r8
offset_flag(p) = 0._r8
offset_counter(p) = 0._r8
offset_fdd(p) = 0._r8
offset_swi(p) = 0._r8
lgsf(p) = 0._r8
bglfr(p) = 0._r8
bgtr(p) = 0._r8
annavg_t2m(p) = 280._r8
tempavg_t2m(p) = 0._r8
! non-phenology variables
gpp(p) = 0._r8
availc(p) = 0._r8
xsmrpool_recover(p) = 0._r8
#if (defined C13)
xsmrpool_c13ratio(p) = c13ratio
#endif
alloc_pnow(p) = 1._r8
c_allometry(p) = 0._r8
n_allometry(p) = 0._r8
plant_ndemand(p) = 0._r8
tempsum_potential_gpp(p) = 0._r8
annsum_potential_gpp(p) = 0._r8
tempmax_retransn(p) = 0._r8
annmax_retransn(p) = 0._r8
avail_retransn(p) = 0._r8
plant_nalloc(p) = 0._r8
plant_calloc(p) = 0._r8
excess_cflux(p) = 0._r8
downreg(p) = 0._r8
prev_leafc_to_litter(p) = 0._r8
prev_frootc_to_litter(p) = 0._r8
tempsum_npp(p) = 0._r8
annsum_npp(p) = 0._r8
#if (defined CNDV)
tempsum_litfall(p) = 0._r8
annsum_litfall(p) = 0._r8
#endif
#if (defined C13)
rc13_canair(p) = 0._r8
rc13_psnsun(p) = 0._r8
rc13_psnsha(p) = 0._r8
alphapsnsun(p) = 0._r8
alphapsnsha(p) = 0._r8
#endif
end if ! end of if-istsoil block
end do ! end of loop over pfts
END IF
!for other time step, assinge current value to the previous step value
IF(nstep .ne. 1) THEN
do c = begc, endc
l = clandunit(c)
#ifndef CROP
if (itypelun(l) == istsoil) then
#else
if (itypelun(l) == istsoil .or. itypelun(l) == istcrop) then
#endif
annsum_counter(c) = annsum_counter_buf(c)
cannsum_npp(c) = cannsum_npp_buf(c)
cannavg_t2m(c) = cannavg_t2m_buf(c)
wf(c) = wf_buf(c)
me(c) = me_buf(c)
mean_fire_prob(c) = mean_fire_prob_buf(c)
cwdc(c) = cwdc_buf(c)
litr1c(c) = litr1c_buf(c)
litr2c(c) = litr2c_buf(c)
litr3c(c) = litr3c_buf(c)
soil1c(c) = soil1c_buf(c)
soil2c(c) = soil2c_buf(c)
soil3c(c) = soil3c_buf(c)
soil4c(c) = soil4c_buf(c)
col_ctrunc(c) = col_ctrunc_buf(c)
cwdn(c) = cwdn_buf(c)
litr1n(c) = litr1n_buf(c)
litr2n(c) = litr2n_buf(c)
litr3n(c) = litr3n_buf(c)
soil1n(c) = soil1n_buf(c)
soil2n(c) = soil2n_buf(c)
soil3n(c) = soil3n_buf(c)
soil4n(c) = soil4n_buf(c)
sminn(c) = sminn_buf(c)
col_ntrunc(c) = col_ntrunc_buf(c)
seedc(c) = seedc_buf(c)
prod10c(c) = prod10c_buf(c)
prod100c(c) = prod100c_buf(c)
seedn(c) = seedn_buf(c)
prod10n(c) = prod10n_buf(c)
prod100n(c) = prod100n_buf(c)
totlitc(c) = totlitc_buf(c)
clm3%g%l%c%ccf%dwt_seedc_to_leaf(c) = dwt_seedc_to_leaf_buf(c)
clm3%g%l%c%ccf%dwt_seedc_to_deadstem(c) = dwt_seedc_to_deadstem_buf(c)
clm3%g%l%c%ccf%dwt_conv_cflux(c) = dwt_conv_cflux_buf(c)
clm3%g%l%c%ccf%dwt_prod10c_gain(c) = dwt_prod10c_gain_buf(c)
clm3%g%l%c%ccf%prod10c_loss(c) = 0._r8
clm3%g%l%c%ccf%dwt_prod100c_gain(c) = dwt_prod100c_gain_buf(c)
clm3%g%l%c%ccf%prod100c_loss(c) = prod100c_loss_buf(c)
clm3%g%l%c%ccf%dwt_frootc_to_litr1c(c) = dwt_frootc_to_litr1c_buf(c)
clm3%g%l%c%ccf%dwt_frootc_to_litr2c(c) = dwt_frootc_to_litr2c_buf(c)
clm3%g%l%c%ccf%dwt_frootc_to_litr3c(c) = dwt_frootc_to_litr3c_buf(c)
clm3%g%l%c%ccf%dwt_livecrootc_to_cwdc(c) = dwt_livecrootc_to_cwdc_buf(c)
clm3%g%l%c%ccf%dwt_deadcrootc_to_cwdc(c) = dwt_deadcrootc_to_cwdc_buf(c)
clm3%g%l%c%ccf%dwt_closs(c) = 0._r8
clm3%g%l%c%cnf%dwt_seedn_to_leaf(c) = dwt_seedn_to_leaf_buf(c)
clm3%g%l%c%cnf%dwt_seedn_to_deadstem(c) = dwt_seedn_to_deadstem_buf(c)
clm3%g%l%c%cnf%dwt_conv_nflux(c) = dwt_conv_nflux_buf(c)
clm3%g%l%c%cnf%dwt_prod10n_gain(c) = dwt_prod10n_gain_buf(c)
clm3%g%l%c%cnf%prod10n_loss(c) = 0._r8
clm3%g%l%c%cnf%dwt_prod100n_gain(c) = dwt_prod100n_gain_buf(c)
clm3%g%l%c%cnf%prod100n_loss(c) = prod100n_loss_buf(c)
clm3%g%l%c%cnf%dwt_frootn_to_litr1n(c) = dwt_frootn_to_litr1n_buf(c)
clm3%g%l%c%cnf%dwt_frootn_to_litr2n(c) = dwt_frootn_to_litr2n_buf(c)
clm3%g%l%c%cnf%dwt_frootn_to_litr3n(c) = dwt_frootn_to_litr3n_buf(c)
clm3%g%l%c%cnf%dwt_livecrootn_to_cwdn(c) = dwt_livecrootn_to_cwdn_buf(c)
clm3%g%l%c%cnf%dwt_deadcrootn_to_cwdn(c) = dwt_deadcrootn_to_cwdn_buf(c)
clm3%g%l%c%cnf%dwt_nloss(c) = 0._r8
fire_prob(c) = 0._r8
fireseasonl(c) = 0._r8
farea_burned(c) = 0._r8
ann_farea_burned(c) = 0._r8
! needed for CNNLeaching
qflx_drain(c) = 0._r8
totsomc(c) = 0._r8
totecosysc(c) = 0._r8
totcolc(c) = 0._r8
totlitn(c) = 0._r8
totsomn(c) = 0._r8
totecosysn(c) = 0._r8
totcoln(c) = 0._r8
totprodc(c) = 0._r8
totprodn(c) = 0._r8
end if
end do
do p = begp, endp
l = plandunit(p)
#ifndef CROP
if (itypelun(l) == istsoil) then
#else
if (itypelun(l) == istsoil .or. itypelun(l) == istcrop) then
#endif
leafc(p) = annsum_npp_buf(p)
leafc_storage(p) = leafc_storage_buf(p)
leafc_xfer(p) = leafc_xfer_buf(p)
#if (defined CROP)
htmx(p) = htmx_buf(p)
croplive(p) = croplive_buf(p)
gdd1020(p) = gdd1020_buf(p)
gdd820(p) = gdd820_buf(p)
gdd020(p) = gdd020_buf(p)
grainc(p) = grainc_buf(p)
grainc_storage(p) = grainc_storage_buf(p)
grainc_xfer(p) = grainc_xfer_buf(p)
#endif
frootc(p) = frootc_buf(p)
frootc_storage(p) = frootc_storage_buf(p)
frootc_xfer(p) = frootc_xfer_buf(p)
livestemc(p) = livestemc_buf(p)
livestemc_storage(p) = livestemc_storage_buf(p)
livestemc_xfer(p) = livestemc_xfer_buf(p)
deadstemc(p) = deadstemc_buf(p)
write(6,*) 'CNiniTimeVar, nstep>1,deadstemc(',p,')=',deadstemc(p)
deadstemc_storage(p) = deadstemc_storage_buf(p)
deadstemc_xfer(p) = deadstemc_xfer_buf(p)
livecrootc(p) = livecrootc_buf(p)
livecrootc_storage(p) = livecrootc_storage_buf(p)
livecrootc_xfer(p) = livecrootc_xfer_buf(p)
deadcrootc(p) = deadcrootc_buf(p)
deadcrootc_storage(p) = deadcrootc_storage_buf(p)
deadcrootc_xfer(p) = deadcrootc_xfer_buf(p)
gresp_storage(p) = gresp_storage_buf(p)
gresp_xfer(p) = gresp_xfer_buf(p)
cpool(p) = cpool_buf(p)
xsmrpool(p) = xsmrpool_buf(p)
pft_ctrunc(p) = pft_ctrunc_buf(p)
leafn(p) = leafn_buf(p)
leafn_storage(p) = leafn_storage_buf(p)
leafn_xfer(p) = leafn_xfer_buf(p)
frootn(p) = frootn_buf(p)
frootn_storage(p) = frootn_storage_buf(p)
frootn_xfer(p) = frootn_xfer_buf(p)
livestemn(p) = livestemn_buf(p)
livestemn_storage(p) = livestemn_storage_buf(p)
livestemn_xfer(p) = livestemn_xfer_buf(p)
deadstemn(p) = deadstemn_buf(p)
deadstemn_storage(p) = deadstemn_storage_buf(p)
deadstemn_xfer(p) = deadstemn_xfer_buf(p)
livecrootn(p) = livecrootn_buf(p)
livecrootn_storage(p) = livecrootn_storage_buf(p)
livecrootn_xfer(p) = livecrootn_xfer_buf(p)
deadcrootn(p) = deadcrootn_buf(p)
deadcrootn_storage(p) = deadcrootn_storage_buf(p)
deadcrootn_xfer(p) = deadcrootn_xfer_buf(p)
npool(p) = npool_buf(p)
pft_ntrunc(p) = pft_ntrunc_buf(p)
#if (defined CROP)
grainn(p) = grainn_buf(p)
grainn_storage(p) = grainn_storage_buf(p)
grainn_xfer(p) = grainn_xfer_buf(p)
#endif
days_active(p) = days_active_buf(p)
onset_flag(p) = onset_flag_buf(p)
onset_counter(p) = onset_counter_buf(p)
onset_gddflag(p) = onset_gddflag_buf(p)
onset_fdd(p) = onset_fdd_buf(p)
onset_gdd(p) = onset_gdd_buf(p)
onset_swi(p) = onset_swi_buf(p)
offset_flag(p) = offset_flag_buf(p)
offset_counter(p) = offset_counter_buf(p)
offset_fdd(p) = offset_fdd_buf(p)
offset_swi(p) = offset_swi_buf(p)
dayl(p) = dayl_buf(p)
annavg_t2m(p) = annavg_t2m_buf(p)
tempavg_t2m(p) = tempavg_t2m_buf(p)
tempsum_potential_gpp(p) = tempsum_potential_gpp_buf(p)
annsum_potential_gpp(p) = annsum_potential_gpp_buf(p)
tempmax_retransn(p) = tempmax_retransn_buf(p)
annmax_retransn(p) = annmax_retransn_buf(p)
prev_leafc_to_litter(p) = prev_leafc_to_litter_buf(p)
prev_frootc_to_litter(p) = prev_frootc_to_litter_buf(p)
tempsum_npp(p) = tempsum_npp_buf(p)
annsum_npp(p) = annsum_npp_buf(p)
retransn(p) = retransn_buf(p)
dispvegc(p) = 0._r8
storvegc(p) = 0._r8
totpftc(p) = 0._r8
totvegc(p) = leafc(p) + leafc_storage(p) + leafc_xfer(p) + frootc(p) + &
frootc_storage(p) + frootc_xfer(p) + livestemc(p) + livestemc_storage(p) + &
livestemc_xfer(p) + deadstemc(p) + deadstemc_storage(p) + deadstemc_xfer(p) + &
livecrootc(p) + livecrootc_storage(p) + livecrootc_xfer(p) + deadcrootc(p) + &
deadcrootc_storage(p) + deadcrootc_xfer(p) + gresp_storage(p) + &
gresp_xfer(p) + cpool(p)
dispvegn(p) = 0._r8
storvegn(p) = 0._r8
totvegn(p) = 0._r8
totpftn(p) = 0._r8
! initialization for psnsun and psnsha required for
! proper arbitrary initialization of allocation routine
! in initial ecosysdyn call
psnsun(p) = 0._r8
psnsha(p) = 0._r8
laisun(p) = 0._r8
laisha(p) = 0._r8
lncsun(p) = 0._r8
lncsha(p) = 0._r8
vcmxsun(p) = 0._r8
vcmxsha(p) = 0._r8
! ecophysiological variables
! phenology variables
dormant_flag(p) = 1._r8
lgsf(p) = 0._r8
bglfr(p) = 0._r8
bgtr(p) = 0._r8
gpp(p) = 0._r8
availc(p) = 0._r8
xsmrpool_recover(p) = 0._r8
alloc_pnow(p) = 1._r8
c_allometry(p) = 0._r8
n_allometry(p) = 0._r8
plant_ndemand(p) = 0._r8
avail_retransn(p) = 0._r8
plant_nalloc(p) = 0._r8
plant_calloc(p) = 0._r8
excess_cflux(p) = 0._r8
downreg(p) = 0._r8
end if ! end of if-istsoil block
end do ! end of loop over pfts
END IF
#endif
end subroutine CNiniTimeVar
module CNEcosystemDynMod 2,2
#ifdef CN
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: CNEcosystemDynMod
!
! !DESCRIPTION:
! Ecosystem dynamics: phenology, vegetation
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use clm_varcon , only: fpftdyn !Yaqiong Lu removed
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: CNEcosystemDyn ! Ecosystem dynamics: phenology, vegetation
!
! !REVISION HISTORY:
! Created by Peter Thornton
! 19 May 2009: PET - modified to include call to harvest routine
!
!
! !PRIVATE MEMBER FUNCTIONS:
!
! !PRIVATE TYPES:
!EOP
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: CNEcosystemDyn
!
! !INTERFACE:
#if (defined CROP)
subroutine CNEcosystemDyn(lbc, ubc, lbp, ubp, num_soilc, filter_soilc, & 4,73
num_soilp, filter_soilp, num_pcropp, filter_pcropp, doalb)
#else
subroutine CNEcosystemDyn(lbc, ubc, lbp, ubp, num_soilc, filter_soilc, & 4,73
num_soilp, filter_soilp, doalb)
#endif
!
! !DESCRIPTION:
! The core CN code is executed here. Calculates fluxes for maintenance
! respiration, decomposition, allocation, phenology, and growth respiration.
! These routines happen on the radiation time step so that canopy structure
! stays synchronized with albedo calculations.
!
! !USES:
use clmtype
!ylu remove use spmdMod , only: masterproc
use CNSetValueMod , only: CNZeroFluxes
use CNNDynamicsMod , only: CNNDeposition,CNNFixation, CNNLeaching
use CNMRespMod , only: CNMResp
use CNDecompMod , only: CNDecompAlloc
use CNPhenologyMod , only: CNPhenology
use CNGRespMod , only: CNGResp
use CNCStateUpdate1Mod , only: CStateUpdate1,CStateUpdate0
use CNNStateUpdate1Mod , only: NStateUpdate1
use CNGapMortalityMod , only: CNGapMortality
use CNCStateUpdate2Mod , only: CStateUpdate2, CStateUpdate2h
use CNNStateUpdate2Mod , only: NStateUpdate2, NStateUpdate2h
use CNFireMod , only: CNFireArea, CNFireFluxes
use CNCStateUpdate3Mod , only: CStateUpdate3
use CNNStateUpdate3Mod , only: NStateUpdate3
use CNBalanceCheckMod , only: CBalanceCheck, NBalanceCheck
use CNPrecisionControlMod, only: CNPrecisionControl
use CNVegStructUpdateMod , only: CNVegStructUpdate
use CNAnnualUpdateMod , only: CNAnnualUpdate
use CNSummaryMod , only: CSummary, NSummary
#if (defined C13)
use CNC13StateUpdate1Mod , only: C13StateUpdate1,C13StateUpdate0
use CNC13StateUpdate2Mod , only: C13StateUpdate2, C13StateUpdate2h
use CNC13StateUpdate3Mod , only: C13StateUpdate3
use CNC13FluxMod , only: C13Flux1, C13Flux2, C13Flux2h, C13Flux3
use C13SummaryMod , only: C13Summary
#endif
use pftdynMod , only: CNHarvest
use CNWoodProductsMod , only: CNWoodProducts
!
! !ARGUMENTS:
implicit none
integer, intent(in) :: lbc, ubc ! column bounds
integer, intent(in) :: lbp, ubp ! pft bounds
integer, intent(in) :: num_soilc ! number of soil columns in filter
integer, intent(in) :: filter_soilc(ubc-lbc+1) ! filter for soil columns
integer, intent(in) :: num_soilp ! number of soil pfts in filter
integer, intent(in) :: filter_soilp(ubp-lbp+1) ! filter for soil pfts
#if (defined CROP)
integer, intent(in) :: num_pcropp ! number of prog. crop pfts in filter
integer, intent(in) :: filter_pcropp(:)! filter for prognostic crop pfts
#endif
logical, intent(in) :: doalb ! true = surface albedo calculation time step
!
! !CALLED FROM:
!
! !REVISION HISTORY:
! 10/22/03, Peter Thornton: created from EcosystemDyn during migration to
! new vector code.
! 11/3/03, Peter Thornton: removed update of elai, esai, frac_veg_nosno_alb.
! These are now done in CNVegStructUpdate(), which is called
! prior to SurfaceAlbedo().
! 11/13/03, Peter Thornton: switched from nolake to soil filtering.
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
! local pointers to implicit out arguments
!
! !OTHER LOCAL VARIABLES:
!
!EOP
!-----------------------------------------------------------------------
! if (doalb) then
! Call the main CN routines
! call CLMDebug('Begin CNZeroFluxes')
! call CNZeroFluxes(num_soilc, filter_soilc, num_soilp, filter_soilp) ! CNSetValueMod.F
call CLMDebug('Begin CNNDeposition')
call CNNDeposition(lbc, ubc) !CNNDynamicsMod.F
call CLMDebug('Begin CNFixation')
call CNNFixation(num_soilc,filter_soilc) !CNNDynamicsMod.F
call CLMDebug('Begin CNMResp')
call CNMResp(lbc, ubc, num_soilc, filter_soilc, num_soilp, filter_soilp) !CNMRespMod.F
call CLMDebug('Begin CNNDecompAlloc')
call CNDecompAlloc(lbp, ubp, lbc, ubc, num_soilc, filter_soilc, num_soilp, filter_soilp) !CNDecompMod.F
! CNphenology needs to be called after CNdecompAlloc, becuase it
! depends on current time-step fluxes to new growth on the last
! litterfall timestep in deciduous systems
#if (defined CROP)
call CLMDebug('Begin CNPhenology')
call CNPhenology(num_soilc, filter_soilc, num_soilp, filter_soilp, num_pcropp, filter_pcropp) !CNPhenologyMod.F
#else
call CNPhenology(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin CNGResp')
call CNGResp(num_soilp, filter_soilp) !CNGRespMod.F
call CLMDebug('Begin CStateUpdate')
call CStateUpdate0(num_soilp, filter_soilp) !CNCStateUpdate1Mod.F
#if (defined C13)
call C13StateUpdate0(num_soilp, filter_soilp)
call C13Flux1(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin CStateUpdate1')
call CStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp) !CNCStateUpdate1Mod.F
#if (defined C13)
call C13StateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin NStateUpdate1')
call NStateUpdate1(num_soilc, filter_soilc, num_soilp, filter_soilp) ! CNNStateUpdate1Mod.F
call CLMDebug('Begin CNGapMortality')
call CNGapMortality(num_soilc, filter_soilc, num_soilp, filter_soilp) ! CNGapMortalityMod.F
#if (defined C13)
call C13Flux2(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin CStateUpdate2')
call CStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp) ! CNCStateUpdate2Mod.F
#if (defined C13)
call C13StateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin NStateUpdate2')
call NStateUpdate2(num_soilc, filter_soilc, num_soilp, filter_soilp) !CNNStateUpdate2Mod
if (fpftdyn /= ' ') then !Yaqiong Lu removed
!fpftdyn /= ' ' means there is dynamic land use data sets used
call CLMDebug('Begin CNHarvest')
call CNHarvest(num_soilc, filter_soilc, num_soilp, filter_soilp) !pftdynMod.F
end if
#if (defined C13)
call C13Flux2h(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin CStateUpdate2h')
call CStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp) !CNCStateUpdate2Mod.F
#if (defined C13)
call C13StateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin NStateUpdate2h')
call NStateUpdate2h(num_soilc, filter_soilc, num_soilp, filter_soilp) ! CNNStateUpdate2Mod.F
call CLMDebug('Begin CNWoodProducts')
call CNWoodProducts(num_soilc, filter_soilc) ! CNWoodProductsMod.F
call CLMDebug('Begin CNFireArea')
call CNFireArea(num_soilc, filter_soilc) !CNFireMod.F
call CLMDebug('Begin CNFireFluxes')
call CNFireFluxes(num_soilc, filter_soilc, num_soilp, filter_soilp) !CNFireMod.F
call CLMDebug('Begin CNNLeaching')
call CNNLeaching(lbc, ubc, num_soilc, filter_soilc) !CNNDynamicsMod.F
#if (defined C13)
call C13Flux3(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin CStateUpdate3')
call CStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp) ! CNCStateUpdate3Mod.F
#if (defined C13)
call C13StateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin NStateUpdate3')
call NStateUpdate3(num_soilc, filter_soilc, num_soilp, filter_soilp) !CNNStateUpdate3Mod.F
call CLMDebug('Begin CNPrecisionControl')
call CNPrecisionControl(num_soilc, filter_soilc, num_soilp, filter_soilp) !CNPrecisionControlMod.F
if (doalb) then
call CLMDebug('Begin CNVegStructUpdate')
call CNVegStructUpdate(num_soilp, filter_soilp) ! CNVegStructUpdateMod.F
end if
! call CNAnnualUpdate(num_soilc, filter_soilc, num_soilp, filter_soilp)
call CLMDebug('Begin CSummary')
call CSummary(num_soilc, filter_soilc, num_soilp, filter_soilp) !CNSummaryMod.F
#if (defined C13)
call C13Summary(num_soilc, filter_soilc, num_soilp, filter_soilp)
#endif
call CLMDebug('Begin NSummary')
call NSummary(num_soilc, filter_soilc, num_soilp, filter_soilp) !CNSummaryMod.F
! end if !end of if-doalb block
end subroutine CNEcosystemDyn
#endif
!-----------------------------------------------------------------------
end module CNEcosystemDynMod
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: iniTimeVar !This subroutine was used in CLM3.0, but not in CLM3.5&CLM4.0
!
! !INTERFACE:
subroutine iniTimeVar(snlx ,snowdpx ,dzclmx ,zclmx ,& 1,23
ziclmx ,h2osnox ,h2osoi_liqx,h2osoi_icex,t_grndx,&
t_soisnox ,t_lakex ,t_vegx ,h2ocanx ,h2ocan_colx,&
h2osoi_volx,declin,t_ref2mx,xlat,xlon)
!
! !DESCRIPTION:
! Initializes the following time varying variables:
! water : h2osno, h2ocan, h2osoi_liq, h2osoi_ice, h2osoi_vol
! snow : snowdp, snowage, snl, dz, z, zi
! temperature: t_soisno, t_veg, t_grnd
! The variable, h2osoi_vol, is needed by the soil albedo routine - this is not needed
! on restart since it is computed before the soil albedo computation is called.
! The remaining variables are initialized by calls to ecosystem dynamics and
! albedo subroutines.
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtype
use decompMod , only : get_proc_bounds
use filterMod , only : filter
use clm_varpar , only : nlevsoi,nlevgrnd, nlevsno, nlevlak,maxpatch
use clm_varcon , only : denice, denh2o, zlnd,istsoil,isturb
use FracWetMod , only : FracWet
use SurfaceAlbedoMod , only : SurfaceAlbedo
use globals , only : month, day, calday
#if (defined CN)
use CNEcosystemDynMod , only : CNEcosystemDyn
#endif
#if (!defined CN)
use STATICEcosysDynMod, only : EcosystemDyn, interpMonthlyVeg
#endif
use shr_const_mod, only : SHR_CONST_PI
!
! !ARGUMENTS:
implicit none
!
! !CALLED FROM:
! subroutine initialize in module initializeMod
!
! !REVISION HISTORY:
! Created by Mariana Vertenstein
! The following vraiables for MM5 and restart run
real(r8) :: xlon
real(r8) :: xlat
integer :: snlx(maxpatch)
real(r8) :: snowdpx(maxpatch)
! real(r8) :: snowagex(maxpatch)
real(r8) :: h2osnox(maxpatch)
real(r8) :: t_grndx(maxpatch)
real(r8) :: t_vegx(maxpatch)
real(r8) :: h2ocanx(maxpatch)
real(r8) :: h2ocan_colx(maxpatch)
real(r8) :: t_ref2mx(maxpatch)
real(r8) :: t_lakex(maxpatch,nlevlak)
real(r8) :: t_soisnox(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: h2osoi_liqx(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: h2osoi_icex(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: dzclmx(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: zclmx(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: ziclmx(maxpatch,-nlevsno:nlevgrnd)
real(r8) :: h2osoi_volx(maxpatch,nlevgrnd)
!
! !LOCAL VARIABLES:
!
! local pointers to implicit in arguments
!
integer , pointer :: plandunit(:) ! landunit index associated with each pft
logical , pointer :: lakpoi(:) ! true => landunit is a lake point
real(r8), pointer :: dz(:,:) ! layer thickness depth (m)
real(r8), pointer :: h2osoi_ice(:,:) ! ice lens (kg/m2)
real(r8), pointer :: h2osoi_liq(:,:) ! liquid water (kg/m2)
integer , pointer :: frac_veg_nosno_alb(:) ! fraction of vegetation not covered by snow (0 OR 1) [-]
!
! local pointers to implicit out arguments
!
real(r8), pointer :: h2osoi_vol(:,:) ! volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3]
real(r8), pointer :: snowdp(:) ! snow height (m)
real(r8), pointer :: frac_sno(:) ! fraction of ground covered by snow (0 to 1)
integer , pointer :: frac_veg_nosno(:) ! fraction of vegetation not covered by snow (0 OR 1) [-]
real(r8), pointer :: fwet(:) ! fraction of canopy that is wet (0 to 1) (pft-level)
!
! local pointers to implicit out arguments (lake points only)
!
real(r8), pointer :: fdry(:) ! fraction of foliage that is green and dry [-] (new)
real(r8), pointer :: tlai(:) ! one-sided leaf area index, no burying by snow
real(r8), pointer :: tsai(:) ! one-sided stem area index, no burying by snow
real(r8), pointer :: htop(:) ! canopy top (m)
real(r8), pointer :: hbot(:) ! canopy bottom (m)
real(r8), pointer :: elai(:) ! one-sided leaf area index with burying by snow
real(r8), pointer :: esai(:) ! one-sided stem area index with burying by snow
real(r8) :: declin ! solar declination angle in radians for nstep
!
!EOP
!
real(r8):: snowbd ! temporary calculation of snow bulk density (kg/m3)
real(r8):: fmelt ! snowbd/100
integer , pointer :: clandunit(:) ! landunit index associated with each column
integer , pointer :: itypelun(:) ! landunit type
! !OTHER LOCAL VARIABLES:
integer :: g,nc,j,l,c,p,fp,fc ! indices
integer :: begp, endp ! per-clump beginning and ending pft indices
integer :: begc, endc ! per-clump beginning and ending column indices
integer :: begl, endl ! per-clump beginning and ending landunit indices
integer :: begg, endg ! per-clump gridcell ending gridcell indices
#if (defined DGVM)
integer , pointer :: clandunit(:) ! column's landunit
integer , pointer :: pcolumn(:) ! column index of corresponding pft
integer , pointer :: ityplun(:) ! landunit type
real(r8), pointer :: z(:,:) ! (m)
real(r8), pointer :: tsoi25(:) ! soil temperature to 0.25 m (Kelvin)
real(r8), pointer :: t_soisno(:,:) ! soil temperature (Kelvin) (-nlevsno+1:nlevsoi)
real(r8), pointer :: watsat(:,:) ! volumetric soil water at saturation (porosity)
real(r8), pointer :: sucsat(:,:) ! minimum soil suction (mm)
real(r8), pointer :: bsw(:,:) ! Clapp and Hornberger "b"
real(r8), pointer :: wf(:) ! soil water as frac. of whc for top 0.5 m
real(r8) ,allocatable :: tsoi(:) ! temporary
real(r8) ,allocatable :: dep(:) ! temporary
real(r8) ,allocatable :: rwat(:) ! soil water wgted by depth to maximum depth of 0.5 m
real(r8) ,allocatable :: swat(:) ! same as rwat but at saturation
real(r8) ,allocatable :: rz(:) ! thickness of soil layers contributing to rwat (m)
real(r8) :: watdry ! temporary
real(r8) :: tsw ! volumetric soil water to 0.5 m
real(r8) :: stsw ! volumetric soil water to 0.5 m at saturation
#endif
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (landunit-level)
lakpoi => clm3%g%l%lakpoi
itypelun => clm3%g%l%itype
! Assign local pointers to derived subtypes components (column-level)
dz => clm3%g%l%c%cps%dz
h2osoi_ice => clm3%g%l%c%cws%h2osoi_ice
h2osoi_liq => clm3%g%l%c%cws%h2osoi_liq
h2osoi_vol => clm3%g%l%c%cws%h2osoi_vol
snowdp => clm3%g%l%c%cps%snowdp
frac_sno => clm3%g%l%c%cps%frac_sno
clandunit => clm3%g%l%c%landunit
! Assign local pointers to derived subtypes components (pft-level)
plandunit => clm3%g%l%c%p%landunit
frac_veg_nosno_alb => clm3%g%l%c%p%pps%frac_veg_nosno_alb
frac_veg_nosno => clm3%g%l%c%p%pps%frac_veg_nosno
fwet => clm3%g%l%c%p%pps%fwet
! Assign local pointers to derived subtypes components (pft-level)
! The folowing pointers will only be used for lake points in this routine
htop => clm3%g%l%c%p%pps%htop
hbot => clm3%g%l%c%p%pps%hbot
tlai => clm3%g%l%c%p%pps%tlai
tsai => clm3%g%l%c%p%pps%tsai
elai => clm3%g%l%c%p%pps%elai
esai => clm3%g%l%c%p%pps%esai
fdry => clm3%g%l%c%p%pps%fdry
!#endif
! ========================================================================
! Initialize water and temperature based on:
! readini = true : read initial data set -- requires netCDF codes
! readini = false: arbitrary initialization
! ========================================================================
!moved to initialize.F
! call mkarbinit(snlx ,snowdpx, snowagex ,dzclmx ,zclmx ,&
! ziclmx ,h2osnox ,h2osoi_liqx,h2osoi_icex,t_grndx,&
! t_soisnox ,t_lakex ,t_vegx ,h2ocanx ,h2ocan_colx,&
! h2osoi_volx,t_ref2mx)
! after this subroutine, t_soisno has values -- Jiming Jin
! ========================================================================
! Remaining variables are initialized by calls to ecosystem dynamics and
! albedo subroutines.
! Note: elai, esai, frac_veg_nosno_alb are computed in
! Ecosysdyn and needed by routines FracWet and SurfaceAlbedo
! frac_veg_nosno is needed by FracWet
! fwet is needed in routine TwoStream (called by SurfaceAlbedo)
! frac_sno is needed by SoilAlbedo (called by SurfaceAlbedo)
! ========================================================================
call CLMDebug('iniTimeVar mark0')
#if (!defined CN)
! Read monthly vegetation data for interpolation to daily values
call CLMDebug('call interpMonthlyVeg')
call interpMonthlyVeg(month, day)
#endif
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
do g = begg, endg
clm3%g%lat_a(g) = xlat*(SHR_CONST_PI/180._r8) ! redians "atm" latitude (radians) for albedo
clm3%g%lon_a(g) = xlon*(SHR_CONST_PI/180._r8)
end do
! Determine variables needed by SurfaceAlbedo for lake points
!dir$ concurrent
!cdir nodep
!For lake point, set all the following value=0
do p = begp,endp
l = plandunit(p)
if (lakpoi(l)) then
fwet(p) = 0.
fdry(p) = 0.
elai(p) = 0.
esai(p) = 0.
htop(p) = 0.
hbot(p) = 0.
tlai(p) = 0.
tsai(p) = 0.
frac_veg_nosno_alb(p) = 0.
frac_veg_nosno(p) = 0.
end if
end do
call CLMDebug('iniTimeVar mark1')
#if (defined CN)
#if (defined CROP)
call CNEcosystemDyn(begc, endc, begp, endp, filter%num_soilc, filter%soilc, &
filter%num_soilp, filter%soilp, &
filter%num_pcropp, filter%pcropp, doalb=.true.)
#else
call CNEcosystemDyn(begc, endc, begp, endp, filter%num_soilc, filter%soilc, &
filter%num_soilp, filter%soilp, doalb=.true.)
#endif
#else
call EcosystemDyn(begp, endp, filter%num_nolakep, filter%nolakep, &
doalb=.true.)
#endif
!dir$ concurrent
!cdir nodep
do p = begp, endp
l = plandunit(p)
if (.not. lakpoi(l)) then
frac_veg_nosno(p) = frac_veg_nosno_alb(p)
fwet(p) = 0.
end if
end do
call CLMDebug('call FracWet')
call FracWet(filter%num_nolakep, filter%nolakep)
! Compute Surface Albedo - all land points (including lake)
! Needs as input fracion of soil covered by snow (Z.-L. Yang U. Texas)
!dir$ concurrent
!cdir nodep
! do c = begc, endc
! snowdp(c) = snowdpx(c)
! frac_sno(c) = snowdp(c)/(10.*zlnd + snowdp(c))
! end do
! Compute Surface Albedo - all land points (including lake) other than urban
! Needs as input fracion of soil covered by snow (Z.-L. Yang U. Texas)
do c = begc, endc
snowdp(c) = snowdpx(c)
l = clandunit(c)
if (itypelun(l) == isturb) then
! From Bonan 1996 (LSM technical note)
frac_sno(c) = min( snowdp(c)/0.05_r8, 1._r8)
else
frac_sno(c) = 0._r8
! snow cover fraction as in Niu and Yang 2007
if(snowdp(c) .gt. 0.0 .and. h2osnox(c) .gt. 0.0) then
snowbd = min(800._r8,h2osnox(c)/snowdp(c)) !bulk density of snow (kg/m3)
fmelt = (snowbd/100.)**1.
! 100 is the assumed fresh snow density; 1 is a melting factor that could be
! reconsidered, optimal value of 1.5 in Niu et al., 2007
frac_sno(c) = tanh( snowdp(c) /(2.5 * zlnd * fmelt) )
endif
end if
end do
call SurfaceAlbedo(begg, endg, begc, endc, begp, endp,filter%num_nourbanc, filter%nourbanc, &
filter%num_nourbanp, filter%nourbanp, calday,declin)
end subroutine iniTimeVar
module initializeMod 1
!-----------------------------------------------------------------------
!BOP
!
! !MODULE: initializeMod
!
! !DESCRIPTION:
! Performs land model initialization
!
! !PUBLIC TYPES:
implicit none
save
!
! !PUBLIC MEMBER FUNCTIONS:
public :: initialize
!
! !REVISION HISTORY:
! Created by Gordon Bonan, Sam Levis and Mariana Vertenstein
! In CLM4.0, DGVM option changed to CNDV--ylu 01/21/2011
!
!EOP
!
! !PRIVATE MEMBER FUNCTIONS:
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: initialize
!
! !INTERFACE:
subroutine initialize(snl ,snowdp ,dzclm ,zclm & 1,46
,ziclm ,h2osno ,h2osoi_liq,h2osoi_ice,t_grnd &
,t_soisno ,t_lake ,t_veg ,h2ocan ,h2ocan_col &
,h2osoi_vol ,xlat ,xlon ,areaxy ,iveg &
,isl ,lndmsk &
,t_ref2m ,ilx ,jlx,calday,declin,declinp1 &
, organicxy, efisopxy,gtixy ,snw_rdsx &
#ifdef CN
,tlai ,tsai ,htop ,hbot &
,htmx_buf,croplive_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf &
#endif
)
!
! !DESCRIPTION:
! Land model initialization.
! o Initializes run control variables via the [clmexp] namelist.
! o Reads surface data on model grid.
! o Defines the multiple plant types and fraction areas for each surface type.
! o Builds the appropriate subgrid <-> grid mapping indices and weights.
! o Set up parallel processing.
! o Initializes time constant variables.
! o Reads restart data for a restart or branch run.
! o Reads initial data and initializes the time variant variables for an initial run.
! o Initializes history file output.
! o Initializes river routing model.
! o Initializes accumulation variables.
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clmtypeInitMod , only : initClmtype
use initGridCellsMod, only : initGridCells
use clm_varpar , only : lsmlon, lsmlat, maxpatch,nlevgrnd,nlevsno,&
nlevlak
use clm_varsur , only : varsur_alloc, longxy,latixy,&
area
use filterMod , only : filter,allocFilters,setFilters
use decompMod , only : initDecomp
! use accFldsMod , only : initAccFlds, initAccClmtype
use surfFileMod , only : surfrd
use pftvarcon , only : pftconrd
#ifdef CN
use CNSetValueMod , only : CNZeroFluxes_dwt,CNZeroFluxes
#endif
use decompMod , only: get_proc_bounds
!CLM4
! use ndepFileMod , only : ndepdyn_init, ndepdyn_interp
!Yaqiong Lu changed add new from CLM4--01/21/11
!#if (defined DGVM)
! use DGVMEcosystemDynMod, only : DGVMEcosystemDynini
!#else
! use STATICEcosysDynMod , only : EcosystemDynini
!#endif
!#if (defined DGVM)
! use DGVMMod , only : resetTimeConstDGVM
!#endif
!
#if (defined CNDV)
use pftdynMod , only : pftwt_init, pftwt_interp
use CNDVEcosystemDyniniMod, only : CNDVEcosystemDynini
#elif (!defined CN)
use STATICEcosysDynMod , only : EcosystemDynini
#endif
#if (defined DUST)
use DustMod , only : Dustini
#endif
#if (defined CASA)
use CASAMod , only : initCASA
use CASAPhenologyMod, only : initCASAPhenology
#if (defined CLAMP)
use CASAiniTimeVarMod,only : CASAiniTimeVar
#endif
#endif
#if (defined RTM)
use RtmMod , only : Rtmini
#endif
! use globals , only: nstep
use clm_varcon , only : var_par
use aerdepMOD , only : aerdepini
!!!
! !ARGUMENTS:
implicit none
!
! !REVISION HISTORY:
! Created by Gordon Bonan, Sam Levis and Mariana Vertenstein
!
!EOP
!
! !LOCAL VARIABLES:
integer :: i,j,k !indices
integer :: yr !current year (0, ...)
integer :: mon !current month (1 -> 12)
integer :: day !current day (1 -> 31)
integer :: ncsec !current time of day [seconds]
logical :: readini !true if read in initial data set
integer :: ier
!ylu add new 01/13/2009
real(r8),intent(in) :: gtixy
real(r8), intent(in) :: calday ! calendar day for declin
real(r8), intent(in) :: declin ! declination angle (radians) for calday
real(r8), intent(in), optional :: declinp1 ! declination angle (radians) for caldaym1
real(r8) :: organicxy(maxpatch)
real(r8) :: efisopxy(6)
!add ilx,jlx
integer :: ilx,jlx
integer :: begc,endc
integer :: snl(maxpatch)
real(r8) :: snowdp(maxpatch)
! real(r8) :: snowage(maxpatch)
real(r8) :: h2osno(maxpatch)
real(r8) :: t_grnd(maxpatch)
real(r8) :: t_veg(maxpatch)
real(r8) :: h2ocan(maxpatch)
real(r8) :: h2ocan_col(maxpatch)
#ifdef CN
real(r8) :: tlai(maxpatch)
real(r8) :: tsai(maxpatch)
real(r8) :: htop(maxpatch)
real(r8) :: hbot(maxpatch)
#endif
real(r8) :: t_lake(maxpatch,nlevlak)
real(r8) :: t_soisno(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: h2osoi_liq(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: h2osoi_ice(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: dzclm(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: zclm(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: ziclm(maxpatch,-nlevsno:nlevgrnd)
real(r8) :: h2osoi_vol(maxpatch,nlevgrnd)
real(r8) :: snw_rdsx(maxpatch,-nlevsno+1:0)
real(r8) :: xlon
real(r8) :: xlat
real(r8) :: areaxy
integer :: iveg
integer :: isl
integer :: lndmsk
real(r8) :: t_ref2m(maxpatch)
#ifdef CN
!CN CROP vars
!CROP&CN buf variables
integer,dimension(maxpatch) :: croplive_buf
real(r8), dimension(maxpatch) :: &
htmx_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf
#endif
call CLMDebug('Now in Initialize. Next call varsur_alloc.')
call get_proc_bounds(begc,endc)
!-----------------------------------------------------------------------
longxy(1) = xlon
latixy(1) = xlat
area(1) = areaxy
!-----------------------------------------------------------------------
! Allocate surface grid dynamic memory
call varsur_alloc () !subroution in CLM3.0, but not in CLM3.5&CLM4.0--Yaqiong Lu
! Read list of PFTs and their corresponding parameter values
! This is independent of the model resolution
call CLMDebug('call pftconrd')
call pftconrd ()
! If no surface dataset name is specified then make surface dataset
! from original data sources. Always read surface boundary data in.
! This insures that bit for bit results are obtained for a run where a
! surface dataset file is generated and a run where a surface dataset
! is specified and read in. Set up vegetation type [veg] and weight [wt]
! arrays for [maxpatch] subgrid patches.
call var_par()
call CLMDebug('call surfrd')
call surfrd (organicxy,efisopxy,gtixy,ilx,jlx, iveg, isl, lndmsk)
! Initialize clump and processor decomposition
call CLMDebug('call initDecomp')
call initDecomp()
! Is this is actually necessary? Probably only for multiple gridcells. Or maybenot...
! Allocate memory and initialize values of clmtype data structures
call CLMDebug('initClmtype')
call initClmtype()
! Build hierarchy and topological info for derived typees
call CLMDebug('call initGridCells')
call initGridCells()
call CLMDebug('call allocFilters')
! Initialize filters
call allocFilters()
call CLMDebug('call setFilters')
call setFilters()
#if (defined CN)
call CNZeroFluxes_dwt() !CNSetValueMod.F
call CNZeroFluxes(filter%num_soilc, filter%soilc, filter%num_soilp, filter%soilp)
#endif
! Initialize time constant variables
call CLMDebug('call iniTimeConst')
call iniTimeConst()
call mkarbinit(snl ,snowdp, dzclm ,zclm ,&
ziclm ,h2osno ,h2osoi_liq,h2osoi_ice,t_grnd,&
t_soisno ,t_lake ,t_veg ,h2ocan ,h2ocan_col,&
h2osoi_vol,t_ref2m ,snw_rdsx &
#ifdef CN
,tlai,tsai,htop,hbot &
#endif
)
! call iniTimeVar(snl ,snowdp ,dzclm ,zclm ,&
! ziclm ,h2osno ,h2osoi_liq,h2osoi_ice,t_grnd ,&
! t_soisno ,t_lake ,t_veg ,h2ocan ,h2ocan_col,&
! h2osoi_vol,declin,t_ref2m)
! Initialize Ecosystem Dynamics
!In CLM4, DGVM option changed to CNDV option--Yaqiong Lu
!#if (defined DGVM)
#if (defined CNDV)
call CNDVEcosystemDynini(t_mo_min ,annpsn ,annpsnpot ,fmicr ,&
bm_inc ,afmicr ,t10min ,tmomin20 ,&
agdd20 ,fpcgrid ,lai_ind ,crownarea ,&
dphen ,leafon ,leafof ,firelength,&
litterag ,litterbg ,cpool_fast ,cpool_slow,&
k_fast_ave ,k_slow_ave ,nind ,lm_ind ,&
sm_ind ,hm_ind ,rm_ind ,present ,&
htop ,tsai ,litter_decom_ave)
!New in CLM4 --ylu 01/21/2011
#elif (!defined CN)
call CLMDebug('init_ecosys') !in CLM4,CLMDebug() subroution changed to t_startf()&t_stopf()
call EcosystemDynini() !but for coupled version, we still use CLMDebug()
#endif
#if (defined CN)
call CLMDebug('init_cninitim')
! if (nsrest == 0) then !only call for if not restart run.
call CNiniTimeVar(htmx_buf,croplive_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf &
)
! end if
#endif
!#if (defined CROP)
! call initialcrop() !removed,already added to CNiniTimeVar.F
!#endif
! Initialize dust emissions model
#if (defined DUST)
call CLMDebug('init_dust')
call Dustini()
! call t_stopf('init_dust')
#endif
call aerdepini()
!#else
! call CLMDebug('EcosystemDynini')
! call EcosystemDynini()
!#endif
! Initialize accumulator fields to be time accumulated for various purposes.
! call CLMDebug('call initAccFlds')
! call initAccFlds()
! ------------------------------------------------------------------------
! Initialization of dynamic pft weights
! ------------------------------------------------------------------------
! Determine correct pft weights (interpolate pftdyn dataset if initial run)
! Otherwise these are read in for a restart run
!#if (defined CNDV)
! call pftwt_init()
!#else
! if (fpftdyn /= ' ') then
! call CLMDebug('init_pftdyn')
! call pftdyn_init()
! call pftdyn_interp( )
! end if
!#endif
!!!
!CLM4 -ylu 09 Feb 2011 The coupling model will read the NDEP_year at same level as LAI,SAI
!therefor remove this part and even ndepFileMod.F
! ------------------------------------------------------------------------
! Initialize dynamic nitrogen deposition
! ------------------------------------------------------------------------
! if (fndepdyn /= ' ') then
! call CLMDebug('init_ndepdyn')
! call ndepdyn_init()
! call ndepdyn_interp()
! end if
!!!!!
! ------------------------------------------------------------------------
! Initialization for Urban or CASA options--add here is needed.
! ------------------------------------------------------------------------
call CLMDebug('call iniTimeVar')
call iniTimeVar(snl ,snowdp ,dzclm ,zclm ,&
ziclm ,h2osno ,h2osoi_liq,h2osoi_ice,t_grnd ,&
t_soisno ,t_lake ,t_veg ,h2ocan ,h2ocan_col,&
h2osoi_vol,declin,t_ref2m,xlat,xlon)
! Initialize clmtype variables that are obtained from accumulated fields.
! This routine is called in an initial run at nstep=0 for cam and csm mode
! and at nstep=1 for offline mode. This routine is also always called for a
! restart run and must therefore be called after the restart file is read in
! call CLMDebug('call initAccClmtype')
! call initAccClmtype()
! Deallocate surface grid dynamic memory
! call CLMDebug('entering varsurdealloc')
! call varsur_dealloc()
! call CLMDebug('done varsurdealloc')
! End initialization
! call CLMDebug('call initSurfalb')
! call initSurfalb( calday, declin, declinp1)
end subroutine initialize
end module initializeMod
subroutine clm(forc_txy ,forc_uxy ,forc_vxy & 1,43
,forc_qxy ,zgcmxy ,precxy &
,flwdsxy ,forc_solsxy ,forc_sollxy &
,forc_solsdxy ,forc_solldxy ,forc_pbotxy &
,forc_psrfxy ,iveg ,isl &
,lndmsk ,xlat ,xlon &
,areaxy ,dt1 ,yr &
,mnth ,dy ,nsec &
,cxday ,yr1 ,mnp1 &
,dyp1 ,nsec1 ,cxday1 &
,mbdate ,qsfxy ,qdnxy &
,snl ,snowdp ,snw_rdsxy &
,dzclm ,zclm ,ziclm &
,h2osno ,h2osoi_liq ,h2osoi_ice &
,t_grnd ,t_soisno ,t_lake &
,t_veg ,h2ocan ,h2ocan_col &
,h2osoi_vol ,wtc ,wtp &
,numc ,nump &
,t_ref2m ,albxy , tsxy, trefxy &
,shxy ,lhxy ,nstp &
,inest ,ilx ,jlx &
,soiflx ,sabv ,sabg &
,lwupxy ,znt0 ,q_ref2m &
,rhoxy &
,ALBEDOsubgrid,LHsubgrid,HFXsubgrid,LWUPsubgrid &
,Q2subgrid,SABVsubgrid,SABGsubgrid,NRAsubgrid &
,SWUPsubgrid ,LHsoi,LHveg,LHtran,organicxy,efisopxy,gtixy &
,alswnirdir ,alswnirdif, alswvisdir,alswvisdif &
#ifdef CN
!CROP and CN restart and outputs
,forc_ndepxy,tlaixy,tsaixy,htopxy,hbotxy &
,htmx_buf,croplive_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf &
#endif
)
!-----------------------------------------------------------------------
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use clm_varpar, only : nlevgrnd,nlevsoi,numrad,maxpatch,&
nlevsno,nlevlak,lsmlon,lsmlat
use initializeMod
use nanMod
use clmtype
use clm_varcon , only : rair, cpair, po2, pco2, tcrit,tfrz,pstd,sb
use globals
use decompMod , only : get_proc_bounds
use clmtypeInitMod
use shr_orb_mod
use shr_const_mod, only : SHR_CONST_PI
use filterMod, only : filters_dealloc
use clm_varsur , only :varsur_dealloc
!
! !PUBLIC TYPES:
implicit none
save
!
! !REVISION HISTORY:
! Created by Gordon Bonan, Sam Levis and Mariana Vertenstein
!
!EOP
! atmospheric forcing variables on land model grid
!
real(r8) :: gtixy
real(r8) :: forc_txy !atm bottom level temperature (Kelvin)
real(r8) :: forc_uxy !atm bottom level zonal wind (m/s)
real(r8) :: forc_vxy !atm bottom level meridional wind (m/s)
real(r8) :: forc_qxy !atm bottom level specific humidity (kg/kg)
real(r8) :: zgcmxy !atm bottom level height above surface (m)
real(r8) :: precxy !precipitation rate (mm H2O/s)
real(r8) :: flwdsxy !downward longwave rad onto surface (W/m**2)
real(r8) :: forc_solsxy !vis direct beam solar rad onto srf (W/m**2)
real(r8) :: forc_sollxy !nir direct beam solar rad onto srf (W/m**2)
real(r8) :: forc_solsdxy !vis diffuse solar rad onto srf (W/m**2)
real(r8) :: forc_solldxy !nir diffuse solar rad onto srf(W/m**2)
real(r8) :: forc_pbotxy !atm bottom level pressure (Pa)
real(r8) :: forc_psrfxy !atm surface pressure (Pa)
!ADD_NEW_VAR
real(r8) :: forc_ndepxy !nitrogen deposition rate (gN/m2/s)
!!!
real(r8) :: alswnirdir ,alswnirdif, alswvisdir,alswvisdif
real(r8) :: swdall
! atmosphere grid to land model surface grid mapping for each land grid cell:
!=======================================================================
! !DESCRIPTION:
! This code reads in atmospheric fields from an input file and generates
! the required atmospheric forcing. These data files have [atmmin] minute
! average data for each month. Input data files are named in month-year
! format (e.g., 09-0001 contains 240 3-hour time slices of data, 30*8, for
! September of year one). The model will cycle through however many full
! years of data are available [pyr]. At least one full year of data is
! necessary for cycling. The model may start on any base date, as long as
! this date corresponds to an existing data file. A run need not be an
! exact multiple of a year.
!
! ============================
! Possible atmospheric fields:
! ============================
! Name Description Required/Optional
! -----------------------------------------------------------------------------
! TBOT temperature (K) Required
! WIND wind:sqrt(u**2+v**2) (m/s) Required
! QBOT specific humidity (kg/kg) Required
! Tdew dewpoint temperature (K) Alternative to Q
! RH relative humidity (percent) Alternative to Q
! ZBOT reference height (m) optional
! PSRF surface pressure (Pa) optional
! FSDS total incident solar radiation (W/m**2) Required
! FSDSdir direct incident solar radiation (W/m**2) optional (replaces FSDS)
! FSDSdif diffuse incident solar rad (W/m**2) optional (replaces FSDS)
! FLDS incident longwave radiation (W/m**2) optional
! PRECTmms total precipitation (mm H2O / sec) Required
! PRECCmms convective precipitation (mm H2O / sec) optional (replaces PRECT)
! PRECLmms large-scale precipitation (mm H2O / sec) optional (replaces PRECT)
!
! LOCAL VARIABLES:
integer :: i,j,k,g,p,c !indices
integer :: begp, endp ! per-proc beginning and ending pft indices
integer :: begc, endc ! per-proc beginning and ending column indices
integer :: begl, endl ! per-proc beginning and ending landunit indices
integer :: begg, endg ! per-proc gridcell ending gridcell indices
type(gridcell_type), pointer :: gptr ! pointer to gridcell derived subtype
!------------------------------------------------------------------------
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#if (defined DGVM)
! The following vraiables for MM5 and restart run
real(r8):: t_mo_min(maxpatch) !annual min of t_mo (Kelvin)
real(r8):: annpsn(maxpatch) !annual photosynthesis (umol CO2 /m**2)
real(r8):: annpsnpot(maxpatch) !annual potential photosynthesis (same units)
real(r8):: fmicr(maxpatch) !microbial respiration (umol CO2 /m**2 /s)
real(r8):: bm_inc(maxpatch) !biomass increment
real(r8):: afmicr(maxpatch) !microbial respiration (Rh) for each naturally-vegetated pft
real(r8):: t10min(maxpatch) !annual minimum of 10-day running mean (K)
real(r8):: tmomin20(maxpatch) !20-yr running mean of tmomin
real(r8):: agdd20(maxpatch) !20-yr running mean of agdd
real(r8):: fpcgrid(maxpatch) !foliar projective cover on gridcell (fraction)
real(r8):: lai_ind(maxpatch) !LAI per individual
real(r8):: crownarea(maxpatch) !area that each individual tree takes up (m^2)
real(r8):: dphen(maxpatch) !phenology [0 to 1]
real(r8):: leafon(maxpatch) !leafon days
real(r8):: leafof(maxpatch) !leafoff days
real(r8):: firelength(maxpatch) !fire season in days
real(r8):: litterag(maxpatch) !above ground litter
real(r8):: litterbg(maxpatch) !below ground litter
real(r8):: cpool_fast(maxpatch) !fast carbon pool
real(r8):: cpool_slow(maxpatch) !slow carbon pool
real(r8):: k_fast_ave(maxpatch) !decomposition rate
real(r8):: k_slow_ave(maxpatch) !decomposition rate
real(r8):: litter_decom_ave(maxpatch) !decomposition rate
real(r8):: nind(maxpatch) !number of individuals (#/m**2)
real(r8):: lm_ind(maxpatch) !individual leaf mass
real(r8):: sm_ind(maxpatch) !individual sapwood mass
real(r8):: hm_ind(maxpatch) !individual heartwood mass
real(r8):: rm_ind(maxpatch) !individual root mass
logical :: present(maxpatch) !whether PFT present in patch
real(r8) :: tda(maxpatch)
real(r8) :: t10(maxpatch)
real(r8) :: fnpsn10(maxpatch)
real(r8) :: prec365(maxpatch)
real(r8) :: agdd0(maxpatch)
real(r8) :: agdd5(maxpatch)
real(r8) :: agddtw(maxpatch)
real(r8) :: agdd(maxpatch)
#endif
integer :: snl(maxpatch)
real(r8) :: snowdp(maxpatch)
! real(r8) :: snowage(maxpatch)
real(r8) :: h2osno(maxpatch)
real(r8) :: t_grnd(maxpatch)
real(r8) :: t_veg(maxpatch)
real(r8) :: h2ocan(maxpatch)
real(r8) :: h2ocan_col(maxpatch)
real(r8) :: wtc(maxpatch)
real(r8) :: wtp(maxpatch)
integer :: numc,nump
real(r8) :: htop(maxpatch)
real(r8) :: tsai(maxpatch)
real(r8) :: efisopxy(6)
real(r8) :: t_lake(maxpatch,nlevlak)
real(r8),dimension(maxpatch,-nlevsno+1:nlevgrnd) :: t_soisno
real(r8) :: h2osoi_liq(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: h2osoi_ice(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: dzclm(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: zclm(maxpatch,-nlevsno+1:nlevgrnd)
real(r8) :: ziclm(maxpatch,-nlevsno:nlevgrnd)
real(r8) :: h2osoi_vol(maxpatch,nlevgrnd)
real(r8) :: snw_rdsxy(maxpatch,-nlevsno+1:0)
real(r8) :: t_ref2m(maxpatch)
!New PFT-level output variables
real(r8), dimension(1:maxpatch), intent(out) :: ALBEDOsubgrid,LHsubgrid,HFXsubgrid,LWUPsubgrid, &
Q2subgrid,SABVsubgrid,SABGsubgrid,NRAsubgrid,SWUPsubgrid,LHsoi,LHveg,LHtran
real(r8) :: znt(maxpatch),organicxy(maxpatch)
real(r8) :: q_ref2m(maxpatch)
#ifdef CN
real(r8),dimension(maxpatch) :: tlaixy,tsaixy,htopxy,hbotxy
!CROP&CN buf variables
integer,dimension(maxpatch) :: croplive_buf
real(r8), dimension(maxpatch) :: &
htmx_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf
#endif
logical doalb !true if surface albedo calculation time step
real(r8) :: albxy,albixy(numrad),albdxy(numrad) &
!For new output variables
,albedotemp(maxpatch, numrad)
real(r8) :: trefxy,tsxy
real(r8) :: shxy
real(r8) :: lhxy
real(r8) :: lwupxy
real(r8) :: qsfxy
real(r8) :: qdnxy
real(r8) :: soiflx
real(r8) :: sabv
real(r8) :: sabg
real(r8) :: znt0
real(r8),intent(out) :: rhoxy
integer :: nstp
!ylu add albedo coefficients
real(r8),dimension(1:numrad) :: cof_dir,cof_dif !1=visible, 2=nir
real(r8) :: areaxy !gridcell area (km^2)
real(r8) :: dt1
real(r8) :: cxday
real(r8) :: cxday1
real(r8) :: xlat
real(r8) :: xlon
integer :: iveg
integer :: isl
integer :: lndmsk
integer :: yr
integer :: mnth
integer :: dy
integer :: nsec
integer :: yr1
integer :: mnp1
integer :: dyp1
integer :: nsec1
integer :: mbdate
integer :: inest
integer :: ilx,jlx
real(r8) :: t2m,dsq,dsqmin
character*256 :: msg
!ylu add for calculate orbit parameters and decline
real(r8) :: eccen ! orbital eccentricity
real(r8) :: obliq ! obliquity in degrees
real(r8) :: mvelp ! moving vernal equinox long
integer :: orb_iyear_AD ! Year to calculate orbit for
real(r8) :: obliqr ! Earths obliquity in rad
real(r8) :: lambm0 ! Mean long of perihelion at
! vernal equinox (radians)
real(r8) :: mvelpp ! moving vernal equinox long
! of perihelion plus pi (rad)
real(r8) :: declinp1 ! solar declination angle in radians for nstep+1
real(r8) :: declin ! solar declination angle in radians for nstep
real(r8) :: eccf ! earth orbit eccentricity factor
!------------------------------------------------------------------------
call CLMDebug('Starting clm3.F')
msg= ''
write(msg, *) 'At i,j = ', ilx, ', ', jlx, '.'
call CLMDebug(msg)
msg = ''
write(msg, *) 't_grnd(1) = ', t_grnd(1), '.'
call CLMDebug(msg)
! setup the step, monthn and day
call clmtype_mod
call globals_mod
dtime = dt1
dt = dt1
year = yr
month = mnth
day = dy
secs = nsec
calday = cxday
yrp1 = yr1
monp1 = mnp1
dayp1 = dyp1
secp1 = nsec1
caldayp1 = cxday1
nbdate = mbdate
nstep = nstp
if(mod(year,4)==0) then
day_per_year = 366
else
day_per_year = 365
end if
orb_iyear_AD = 1990 !according to buildnml of CCSM_crop
!------------------------------------------------------------------------
!set albedo coefficients -- ylu
!------------------------------------------------------------------------
swdall = forc_sollxy+forc_solsxy+forc_solsdxy+forc_solldxy
if(swdall.ne. 0) then ! if daytime
cof_dir(2) = forc_sollxy/swdall
cof_dif(2) = forc_solldxy/swdall
cof_dir(1) = forc_solsxy/swdall
cof_dif(1) = forc_solsdxy/swdall
else !if night
cof_dir(2) = 0.35 !it doesn't matter what values for night, albedo equal to 1 anyway in CLM.
cof_dif(2) = 0.15 !here I use the value from old version of WRF-CLM --ylu
cof_dir(1) = 0.35
cof_dif(1) = 0.15
end if
!-------------------------------------------------
!Yaqiong Lu 03/07/2011
call CLMDebug('Start shr_orb_params')
call shr_orb_params(orb_iyear_AD, eccen, obliq, mvelp, & !get orbit parameres
obliqr, lambm0, mvelpp)
call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, declin, eccf ) !get decline for current step
call shr_orb_decl(caldayp1, eccen, mvelpp, lambm0, obliqr, declinp1, eccf ) !get decline for next step
call CLMDebug('End shr_orb_params & decl')
call CLMDebug('Start initialize()')
! write(6,*) 'in clm3, t_soisno=',t_soisno
call initialize(snl ,snowdp ,dzclm ,zclm &
,ziclm ,h2osno ,h2osoi_liq,h2osoi_ice,t_grnd &
,t_soisno ,t_lake ,t_veg ,h2ocan ,h2ocan_col &
,h2osoi_vol ,xlat ,xlon ,areaxy ,iveg &
,isl ,lndmsk &
,t_ref2m ,ilx,jlx,calday,declin,declinp1&
,organicxy, efisopxy,gtixy, snw_rdsxy &
#ifdef CN
,tlaixy ,tsaixy ,htopxy ,hbotxy &
,htmx_buf,croplive_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf &
#endif
)
call CLMDebug('initialize done. Back in clm3')
! Determine necessary indices
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp)
! Set pointers into derived type
gptr => clm3%g
do g = begg, endg
!i = gptr%ixy(g)
!j = gptr%jxy(g)
!lat and lon
clm3%g%latdeg(g) = xlat !degree
clm3%g%londeg(g) = xlon
clm3%g%lat(g) = xlat*(SHR_CONST_PI/180._r8) ! redians
clm3%g%lon(g) = xlon*(SHR_CONST_PI/180._r8)
clm3%g%latdeg_a(g) = xlat !degree "atm" latitude (degrees) for albedo
clm3%g%londeg_a(g) = xlon
clm3%g%lat_a(g) = xlat*(SHR_CONST_PI/180._r8) ! redians "atm" latitude (radians) for albedo
clm3%g%lon_a(g) = xlon*(SHR_CONST_PI/180._r8)
!States
clm_a2l%forc_t(g) = forc_txy
clm_a2l%forc_u(g) = forc_uxy
clm_a2l%forc_v(g) = forc_vxy
clm_a2l%forc_wind(g) = sqrt(forc_uxy**2 + forc_vxy**2)
clm_a2l%forc_q(g) = forc_qxy
clm_a2l%forc_hgt(g) = zgcmxy
clm_a2l%forc_hgt_u(g) = zgcmxy !observational height of wind [m]
clm_a2l%forc_hgt_t(g) = zgcmxy !observational height of temp [m]
clm_a2l%forc_hgt_q(g) = zgcmxy !observational height of humidity [m]
clm_a2l%forc_pbot(g) = forc_pbotxy
clm_a2l%forc_psrf(g) = forc_psrfxy
clm_a2l%forc_th(g) = clm_a2l%forc_t(g) * (clm_a2l%forc_psrf(g) &
/ clm_a2l%forc_pbot(g))**(rair/cpair)
clm_a2l%forc_vp(g) = clm_a2l%forc_q(g) * clm_a2l%forc_pbot(g) &
/ (0.622 + 0.378 * clm_a2l%forc_q(g))
clm_a2l%forc_rho(g) = (clm_a2l%forc_pbot(g) - 0.378 * clm_a2l%forc_vp(g)) &
/ (rair * clm_a2l%forc_t(g))
clm_a2l%forc_pco2(g) = pco2 * clm_a2l%forc_pbot(g)
clm_a2l%forc_po2(g) = po2 * clm_a2l%forc_pbot(g)
#ifdef CN
!ADD_NEW_VAR
clm_a2l%forc_ndep(g) =forc_ndepxy
!!!
#endif
!Fluxes
clm_a2l%forc_lwrad(g) = flwdsxy
clm_a2l%forc_solad(g,1) = forc_solsxy
clm_a2l%forc_solad(g,2) = forc_sollxy
clm_a2l%forc_solai(g,1) = forc_solsdxy
clm_a2l%forc_solai(g,2) = forc_solldxy
clm_a2l%forc_solar(g) = forc_solsxy + forc_sollxy &
+ forc_solsdxy + forc_solldxy
! Snow and Rain
! Set upper limit of air temperature for snowfall at 275.65K.
! This cut-off was selected based on Fig. 1, Plate 3-1, of Snow
! Hydrology (1956).
if (precxy > 0.) then
if (clm_a2l%forc_t(g) > (tfrz + tcrit)) then
clm_a2l%forc_rain(g) = precxy
clm_a2l%forc_snow(g) = 0.
! clm_a2l%flfall(g) = 1.
else
clm_a2l%forc_rain(g) = 0.
clm_a2l%forc_snow(g) = precxy
if (clm_a2l%forc_t(g) <= tfrz) then
! clm_a2l%flfall(g) = 0.
else if (clm_a2l%forc_t(g) <= tfrz+2.) then
! clm_a2l%flfall(g) = -54.632 + 0.2 * clm_a2l%forc_t(g)
else
! clm_a2l%flfall(g) = 0.4
endif
endif
else
clm_a2l%forc_rain(g) = 0.
clm_a2l%forc_snow(g) = 0.
! clm_a2l%flfall(g) = 1.
endif
rhoxy = clm_a2l%forc_rho(g) ! here assume that g is always 1
clm_a2l%rainf(g) = clm_a2l%forc_rain(g)+clm_a2l%forc_snow(g)
end do
! doalb is true when the next time step is a radiation time step
! this allows for the fact that an atmospheric model may not do
! the radiative calculations every time step. for example:
! nstep dorad doalb
! 1 F F
! 2 F T
! 3 T F
!Yaqiong Lu 03/07/2011
! call CLMDebug('Start shr_orb_params')
! call shr_orb_params(orb_iyear_AD, eccen, obliq, mvelp, & !get orbit parameres
! obliqr, lambm0, mvelpp)
! call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, declin, eccf ) !get decline for current step
! call shr_orb_decl(caldayp1, eccen, mvelpp, lambm0, obliqr, declinp1, eccf ) !get decline for next step
! call CLMDebug('End shr_orb_params & decl')
!!
doalb = .true.
! Call land surface model driver
! Note that surface fields used by the atmospheric model are zero for
! non-land points and must be set by the appropriate surface model
call CLMDebug('Calling Driver')
call driver (doalb,ilx,jlx,caldayp1, declinp1, declin)
call CLMDebug('Driver done, back to clm3.F')
!-------------------------------------------------------------------------
call CLMDebug('biophy_to_wrf')
call biophy_to_wrf(snl ,snowdp ,dzclm ,zclm ,&
ziclm ,h2osno ,h2osoi_liq ,h2osoi_ice ,t_grnd ,&
t_soisno ,t_lake ,t_veg ,h2ocan ,h2ocan_col ,&
h2osoi_vol ,wtc ,wtp ,numc ,nump ,&
htop ,tsai &
,t_ref2m ,znt ,q_ref2m, snw_rdsxy)
#if (defined CN)
call biochem_to_wrf(htmx_buf,croplive_buf,gdd1020_buf,gdd820_buf,gdd020_buf,grainc_buf,grainc_storage_buf &
,grainc_xfer_buf,grainn_buf,grainn_storage_buf,grainn_xfer_buf,days_active_buf &
,onset_flag_buf,onset_counter_buf,onset_gddflag_buf,onset_fdd_buf,onset_gdd_buf &
,onset_swi_buf,offset_flag_buf,offset_counter_buf,offset_fdd_buf,offset_swi_buf &
,dayl_buf,annavg_t2m_buf,tempavg_t2m_buf,tempsum_potential_gpp_buf &
,annsum_potential_gpp_buf,tempmax_retransn_buf,annmax_retransn_buf &
,prev_leafc_to_litter_buf,prev_frootc_to_litter_buf,tempsum_npp_buf &
,annsum_npp_buf,leafc_buf,leafc_storage_buf,leafc_xfer_buf,frootc_buf &
,frootc_storage_buf,frootc_xfer_buf,livestemc_buf,livestemc_storage_buf &
,livestemc_xfer_buf,deadstemc_buf,deadstemc_storage_buf,deadstemc_xfer_buf &
,livecrootc_buf,livecrootc_storage_buf,livecrootc_xfer_buf,deadcrootc_buf &
,deadcrootc_storage_buf,deadcrootc_xfer_buf,cpool_buf,pft_ctrunc_buf &
,leafn_buf,leafn_storage_buf,leafn_xfer_buf,frootn_buf,frootn_storage_buf &
,frootn_xfer_buf,livestemn_buf,livestemn_storage_buf,livestemn_xfer_buf &
,deadstemn_buf,deadstemn_storage_buf,deadstemn_xfer_buf,livecrootn_buf &
,livecrootn_storage_buf,livecrootn_xfer_buf,deadcrootn_buf &
,deadcrootn_storage_buf,deadcrootn_xfer_buf,npool_buf,pft_ntrunc_buf &
,gresp_storage_buf,gresp_xfer_buf,xsmrpool_buf,annsum_counter_buf &
,cannsum_npp_buf,cannavg_t2m_buf,wf_buf,me_buf,mean_fire_prob_buf,cwdc_buf,litr1c_buf &
,litr2c_buf,litr3c_buf,soil1c_buf,soil2c_buf,soil3c_buf,soil4c_buf,seedc_buf,col_ctrunc_buf &
,prod10c_buf,prod100c_buf,cwdn_buf,litr1n_buf,litr2n_buf,litr3n_buf,soil1n_buf,soil2n_buf &
,soil3n_buf,soil4n_buf,seedn_buf,col_ntrunc_buf,prod10n_buf,prod100n_buf,sminn_buf &
,totlitc_buf,dwt_seedc_to_leaf_buf,dwt_seedc_to_deadstem_buf,dwt_conv_cflux_buf &
,dwt_prod10c_gain_buf,dwt_prod100c_gain_buf,prod100c_loss_buf,dwt_frootc_to_litr1c_buf &
,dwt_frootc_to_litr2c_buf,dwt_frootc_to_litr3c_buf,dwt_livecrootc_to_cwdc_buf &
,dwt_deadcrootc_to_cwdc_buf,dwt_seedn_to_leaf_buf,dwt_seedn_to_deadstem_buf &
,dwt_conv_nflux_buf,dwt_prod10n_gain_buf,dwt_prod100n_gain_buf,prod100n_loss_buf &
,dwt_frootn_to_litr1n_buf,dwt_frootn_to_litr2n_buf, dwt_frootn_to_litr3n_buf &
, dwt_livecrootn_to_cwdn_buf,dwt_deadcrootn_to_cwdn_buf,retransn_buf &
)
#endif
call CLMDebug('start accumulate in clm3.F')
albxy = 0._r8
do j = 1,numrad
do p = begp,endp
albxy =albxy + clm3%g%l%c%p%pps%albd(p,j)*wtp(p)*cof_dir(j) + clm3%g%l%c%p%pps%albi(p,j)*wtp(p)*cof_dif(j)
albedosubgrid(p) = clm3%g%l%c%p%pps%albd(p,j)*cof_dir(j)+clm3%g%l%c%p%pps%albi(p,j)*cof_dif(j)
end do
end do
msg = ''
write(msg,*) 'Calculated albedo is ', albxy, '.'
call CLMDebug(msg)
lwupxy= 0._r8
shxy = 0._r8
lhxy = 0._r8
soiflx= 0._r8
sabv = 0._r8
sabg = 0._r8
trefxy = 0._r8
tsxy = 0._r8
znt0 = 0._r8
alswvisdir = 0._r8
alswvisdif = 0._r8
alswnirdir = 0._r8
alswnirdif = 0._r8
!!
do p = begp,endp
lwupxy= lwupxy+ clm3%g%l%c%p%pef%eflx_lwrad_out(p)*wtp(p)
shxy = shxy + clm3%g%l%c%p%pef%eflx_sh_tot(p)*wtp(p)
lhxy = lhxy + clm3%g%l%c%p%pef%eflx_lh_tot(p)*wtp(p)
soiflx= soiflx+ clm3%g%l%c%p%pef%eflx_soil_grnd(p)*wtp(p) ! [+ into soil]
sabv = sabv + clm3%g%l%c%p%pef%sabv(p)*wtp(p)
sabg = sabg + clm3%g%l%c%p%pef%sabg(p)*wtp(p)
tsxy = tsxy + clm3%g%l%c%p%pes%t_veg(p)*wtp(p)
trefxy = trefxy + clm3%g%l%c%p%pes%t_ref2m(p)*wtp(p)
!over lakes and bare soils, t_veg = t_grnd
znt0 = znt0 + znt(p)*wtp(p)
alswvisdir = alswvisdir + clm3%g%l%c%p%pps%albd(p,1)*wtp(p)
alswnirdif = alswnirdif + clm3%g%l%c%p%pps%albi(p,1)*wtp(p)
alswnirdir = alswnirdir + clm3%g%l%c%p%pps%albd(p,2)*wtp(p) !1=visible, 2=nir
alswnirdif = alswnirdif + clm3%g%l%c%p%pps%albi(p,2)*wtp(p)
!!PFT-level outputs
if ( wtp(p) > 0.001 ) then
lhsubgrid(p) = clm3%g%l%c%p%pef%eflx_lh_tot(p)
hfxsubgrid(p) = clm3%g%l%c%p%pef%eflx_sh_tot(p)
lwupsubgrid(p) = clm3%g%l%c%p%pef%eflx_lwrad_out(p)
q2subgrid(p) = q_ref2m(p)
sabvsubgrid(p) = clm3%g%l%c%p%pef%sabv(p) !solar radiation absorbed by vegetation
sabgsubgrid(p) = clm3%g%l%c%p%pef%sabg(p) !solar radiation absorbed by ground
nrasubgrid(p) = clm3%g%l%c%p%pef%fsa(p) !solar radiation absorbed total=net radiation
swupsubgrid(p) = clm3%g%l%c%p%pef%fsr(p) !solar radiation reflected
lhsoi(p) = clm3%g%l%c%p%pef%eflx_lh_grnd(p)
lhveg(p) = clm3%g%l%c%p%pef%eflx_lh_vege(p)
lhtran(p) = clm3%g%l%c%p%pef%eflx_lh_vegt(p)
#ifdef CN
tlaixy(p) = clm3%g%l%c%p%pps%tlai(p)
tsaixy(p) = clm3%g%l%c%p%pps%tsai(p)
htopxy(p) = clm3%g%l%c%p%pps%htop(p)
hbotxy(p) = clm3%g%l%c%p%pps%hbot(p)
#endif
endif
!!
end do
!Debug
msg = ''
write(msg,*) 'LWUP is', lwupxy, '.'
call CLMDebug(msg)
qsfxy = 0._r8
qdnxy = 0._r8
do c = begc,endc
qsfxy = qsfxy + clm3%g%l%c%cwf%qflx_surf(c)*wtc(c)*dtime
qdnxy = qdnxy + clm3%g%l%c%cwf%qflx_drain(c)*wtc(c)*dtime
end do
!-------------------------------------------------------------------------
call CLMDebug('call clmtype_dealloc')
call clmtype_dealloc()
call CLMDebug('call filters_dealloc')
call filters_dealloc()
call CLMDebug('entering varsurdealloc')
call varsur_dealloc()
!-------------------------------------------------------------------------
call CLMDebug('done clm()')
return
end subroutine clm
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: driver
!
! !INTERFACE:
subroutine driver (doalb,ilx,jlx,nextsw_cday, declinp1, declin) 1,97
!
! !DESCRIPTION:
! This subroutine provides the main CLM driver calling sequence. Most
! computations occurs over ``clumps'' of gridcells (and associated subgrid
! scale entities) assigned to each MPI process. Computation is further
! parallelized by looping over clumps on each process using shared memory
! OpenMP or Cray Streaming Directives.
!
! The main CLM driver calling sequence is as follows:
! \begin{verbatim}
! * Communicate with flux coupler [COUP_CSM]
! + interpMonthlyVeg interpolate monthly vegetation data [!DGVM]
! + readMonthlyVegetation read vegetation data for two months [!DGVM]
! ==== Begin Loop 1 over clumps ====
! -> DriverInit save of variables from previous time step
! -> Hydrology1 canopy interception and precip on ground
! -> FracWet fraction of wet vegetated surface and dry elai
! -> SurfaceRadiation surface solar radiation
! -> Biogeophysics1 leaf temperature and surface fluxes
! -> BareGroundFluxes surface fluxes for bare soil or snow-covered
! vegetation patches
! -> MoninObukIni first-guess Monin-Obukhov length and wind speed
! -> FrictionVelocity friction velocity and potential temperature and
! humidity profiles
! -> CanopyFluxes leaf temperature and surface fluxes for vegetated
! patches
! -> QSat saturated vapor pressure, specific humidity, &
! derivatives at leaf surface
! -> MoninObukIni first-guess Monin-Obukhov length and wind speed
! -> FrictionVelocity friction velocity and potential temperature and
! humidity profiles
! -> Stomata stomatal resistance and photosynthesis for
! sunlit leaves
! -> Stomata stomatal resistance and photosynthesis for
! shaded leaves
! -> QSat recalculation of saturated vapor pressure,
! specific humidity, & derivatives at leaf surface
! -> Biogeophysics_Lake lake temperature and surface fluxes
! + VOCEmission compute VOC emission [VOC]
! + DGVMRespiration CO2 respriation and plant production [DGVM]
! + DGVMEcosystemDyn DGVM ecosystem dynamics: vegetation phenology [!DGVM]
! -> EcosystemDyn "static" ecosystem dynamics: vegetation phenology
! and soil carbon [!DGVM]
! -> SurfaceAlbedo albedos for next time step
! -> Biogeophysics2 soil/snow & ground temp and update surface fluxes
! -> pft2col Average from PFT level to column level
! ==== End Loop 1 over clumps ====
! * Average fluxes over time interval and send to flux coupler [COUP_CSM]
! ==== Begin Loop 2 over clumps ====
! -> Hydrology2 surface and soil hydrology
! -> Hydrology_Lake lake hydrology
! -> SnowAge update snow age for surface albedo calcualtion
! -> BalanceCheck check for errors in energy and water balances
! ==== End Loop 2 over clumps ====
! -> write_diagnostic output diagnostic if appropriate
! + Rtmriverflux calls RTM river routing model [RTM]
! -> updateAccFlds update accumulated fields
! -> update_hbuf accumulate history fields for time interval
! Begin DGVM calculations at end of model year [DGVM]
! ==== Begin Loop over clumps ====
! + lpj LPJ ecosystem dynamics: reproduction, turnover,
! kill, allocation, light, mortality, fire
! + lpjreset1 reset variables & initialize for next year
! ==== End Loop over clumps ====
! End DGVM calculations at end of model year [DGVM]
! -> htapes_wrapup write history tapes if appropriate
! Begin DGVM calculations at end of model year [DGVM]
! ==== Begin Loop over clumps ====
! + lpjreset2 reset variables and patch weights
! ==== End Loop over clumps ====
! End DGVM calculations at end of model year [DGVM]
! -> restart write restart file if appropriate
! -> inicfile write initial file if appropriate
! \end{verbatim}
! Optional subroutines are denoted by an plus (+) with the associated
! CPP variable in brackets at the end of the line. Coupler communication
! when coupled with CCSM components is denoted by an asterisk (*).
!
! !USES:
use shr_kind_mod, only: r8 => shr_kind_r8
use globals
use clmtype
!ylu add new from CLM4
! use clm_varctl , only : fpftdyn, fndepdyn !ylu removed wrtdia
use decompMod , only : get_proc_bounds
use filterMod , only : filter
#if (defined CNDV)
use CNDVMod , only : dv, histCNDV
use pftdynMod , only : pftwt_interp
#endif
use pftdynMod , only : pftdyn_interp, pftdyn_wbal_init, pftdyn_wbal
#ifdef CN
use pftdynMod , only : pftdyn_cnbal
#endif
use dynlandMod , only : dynland_hwcontent
use clm_varcon , only : set_caerdep_from_file,set_dustdep_from_file,zlnd, isturb, fpftdyn, fndepdyn !move fpftdyn, fndepdyn to clm_varcon.F
use DriverInitMod , only : DriverInit
use BalanceCheckMod , only : BalanceCheck, BeginWaterBalance
use SurfaceRadiationMod , only : SurfaceRadiation
use Hydrology1Mod , only : Hydrology1
use Hydrology2Mod , only : Hydrology2
use HydrologyLakeMod , only : HydrologyLake
use Biogeophysics1Mod , only : Biogeophysics1
use BareGroundFluxesMod , only : BareGroundFluxes
use CanopyFluxesMod , only : CanopyFluxes
use Biogeophysics2Mod , only : Biogeophysics2
use BiogeophysicsLakeMod, only : BiogeophysicsLake
use SurfaceAlbedoMod , only : SurfaceAlbedo
use pft2colMod , only : pft2col
! use accFldsMod , only : updateAccFlds
! use accumulMod , only : accum_dealloc
#if (defined CN)
!ylu begin 1
use pftdynMod , only : pftdyn_cnbal
use CNSetValueMod , only : CNZeroFluxes_dwt
use CNEcosystemDynMod , only : CNEcosystemDyn
use CNAnnualUpdateMod , only : CNAnnualUpdate
use CNBalanceCheckMod , only : BeginCBalance, BeginNBalance, &
CBalanceCheck, NBalanceCheck
! use ndepFileMod , only : ndepdyn_interp !ndep data will be passed from module_surface_driver.F
#else
use STATICEcosysDynMod , only : EcosystemDyn, interpMonthlyVeg, EcosystemDyn_dealloc
!ylu end 1
#endif
#if (defined DUST)
use DUSTMod , only : DustDryDep, DustEmission
#endif
use VOCEmissionMod , only : VOCEmission
! use DryDepVelocity , only : depvel_compute !may need add later ylu
#if (defined CASA)
use CASAMod , only : Casa_ecosystemDyn
#endif
#if (defined RTM)
use RtmMod , only : Rtmriverflux
#endif
! use UrbanMod , only : UrbanAlbedo, UrbanRadiation, UrbanFluxes
use SNICARMod , only : SnowAge_grain
use aerdepMod , only : interpMonthlyAerdep
!
! !ARGUMENTS:
implicit none
logical , intent(in) :: doalb !true if time for surface albedo
!calculation
!
! !REVISION HISTORY:
! 2002.10.01 Mariana Vertenstein latest update to new data structures
!
!EOP
!
! !LOCAL VARIABLES:
! local pointers to implicit in arguments
!
integer , pointer :: clandunit(:) ! landunit index associated with each column
integer , pointer :: itypelun(:) ! landunit type
!
! !OTHER LOCAL VARIABLES:
integer :: ilx,jlx
integer :: c,g,l ! indices
integer :: ncdate ! current date
integer :: kyr ! thousand years, equals 2 at end of first year
integer :: begp, endp ! clump beginning and ending pft indices
integer :: begc, endc ! clump beginning and ending column indices
integer :: begl, endl ! clump beginning and ending landunit indices
integer :: begg, endg ! clump beginning and ending gridcell indices
type(column_type) , pointer :: cptr ! pointer to column derived subtype
! logical, external :: do_restwrite ! determine if time to write restart
real(r8), intent(in) :: nextsw_cday ! calendar day at Greenwich (1.00, ..., 365.99)
real(r8), intent(in) :: declinp1 ! declination angle (radians) for next time step
real(r8), intent(in) :: declin ! declination angle for current time step
!temp value
real(r8), pointer :: t_soisno(:,:)
t_soisno => clm3%g%l%c%ces%t_soisno
!-----------------------------------------------------------------------
! Assign local pointers to derived subtypes components (landunit-level)
itypelun => clm3%g%l%itype
! Assign local pointers to derived subtypes components (column-level)
clandunit => clm3%g%l%c%landunit
! Set pointers into derived type
cptr => clm3%g%l%c
! ============================================================================
! Calendar information for next time step
! o caldayp1 = calendar day (1.00 -> 365.99) for cosine solar zenith angle
! calday is based on Greenwich time
! o get_curr_calday in the cam time manager know about perpetual mode
! and perpetual model is only used within cam
! ============================================================================
#if (!defined CN)
! ============================================================================
! Determine weights for time interpolation of monthly vegetation data.
! This also determines whether it is time to read new monthly vegetation and
! obtain updated leaf area index [mlai1,mlai2], stem area index [msai1,msai2],
! vegetation top [mhvt1,mhvt2] and vegetation bottom [mhvb1,mhvb2]. The
! weights obtained here are used in subroutine ecosystemdyn to obtain time
! interpolated values.
! ============================================================================
if (doalb) call interpMonthlyVeg (monp1,dayp1) !STATICEcosysDynMod.F
#endif
! ============================================================================
! interpolate aerosol deposition data, and read in new monthly data if need be.
! ============================================================================
if ( (set_caerdep_from_file) .or. (set_dustdep_from_file) ) then
call interpMonthlyAerdep(monp1,dayp1)
endif
! ============================================================================
! Loop1
! ============================================================================
! ============================================================================
! Determine clump boundaries
! ============================================================================
call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) !decompMod.F
! ============================================================================
! change pft weights and compute associated heat & water fluxes
! ============================================================================
!ylu add new in clm_driver.F for CLM4 10-22-2010
do g = begg,endg
clm3%g%gwf%qflx_liq_dynbal(g) = 0._r8
clm3%g%gws%gc_liq2(g) = 0._r8
clm3%g%gws%gc_liq1(g) = 0._r8
clm3%g%gwf%qflx_ice_dynbal(g) = 0._r8
clm3%g%gws%gc_ice2(g) = 0._r8
clm3%g%gws%gc_ice1(g) = 0._r8
clm3%g%gef%eflx_dynbal(g) = 0._r8
clm3%g%ges%gc_heat2(g) = 0._r8
clm3%g%ges%gc_heat1(g) = 0._r8
enddo
!--- get initial heat,water content ---
call dynland_hwcontent( begg, endg, clm3%g%gws%gc_liq1(begg:endg), & !dynlandMod.F
clm3%g%gws%gc_ice1(begg:endg), clm3%g%ges%gc_heat1(begg:endg) )
!#if (!defined CNDV)
! if (fpftdyn /= ' ') then
! call pftdyn_interp ! change the pft weights
!
! !DESCRIPTION:
! Time interpolate dynamic landuse data to get pft weights for model time
! Note that harvest data are stored as rates (not weights) and so time interpolation is
! not necessary - the harvest rate is held constant through the year. This is consistent with
! the treatment of changing PFT weights, where interpolation of the annual endpoint weights leads to
! a constant rate of change in PFT weight through the year, with abrupt changes in the rate at
! annual boundaries. This routine is still used to get the next harvest time slice, when needed.
! This routine is also used to turn off the harvest switch when the model year runs past the end of
! the dynpft time series.
!
call CLMDebug('BeginWaterBalance')
call BeginWaterBalance(begc, endc, begp, endp, &
filter%num_nolakec, filter%nolakec, filter%num_lakec, filter%lakec, &
filter%num_hydrologyc, filter%hydrologyc)
!ylu begin 2
#if (defined CN)
!call t_startf('begcnbal')
call CLMDebug('BeginCBalance')
call BeginCBalance(begc, endc, filter%num_soilc, filter%soilc) !CNBalanceCheckMod.F
call CLMDebug('BeginNBalance')
call BeginNBalance(begc, endc, filter%num_soilc, filter%soilc) !CNBalanceCheckMod.F
! call t_stopf('begcnbal')
#endif
!Leaving out pftdyn_wbal_init and canopy water loss
!!!!!!!!
call CLMDebug('pftdyn_wbal_init')
call pftdyn_wbal_init() !pftdynMod.F
#if (defined CNDV)
! if (doalb) then ! Currently CNDV and fpftdyn /= ' ' are incompatible
call CLMDebug('Begin CNZeroFluxes')
call CNZeroFluxes_dwt() !CNSetValueMod.F
call CLMDebug('Begin pftwt_interp')
call pftwt_interp() !pftdynMod.F
call CLMDebug('Begin pftdyn_wbal')
call pftdyn_wbal( begg, endg, begc, endc, begp, endp ) !pftdynMod.F
call CLMDebug('Begin pftdyn_cnbal')
call pftdyn_cnbal() !pftdynMod.F
call CLMDebug('Begin setFilters')
call setFilters()
! end if
#else
! ============================================================================
! Update weights and reset filters if dynamic land use
! This needs to be done outside the clumps loop, but after BeginWaterBalance()
! The call to CNZeroFluxes_dwt() is needed regardless of fpftdyn
! ============================================================================
!#if (defined CN)
! call CLMDebug('Begin CNZeroFluxes')
! call CNZeroFluxes_dwt() !CNSetValueMod.F
!#endif
if (fpftdyn /= ' ') then
#if (defined CN)
call CLMDebug('Begin pftdyn_cnbal')
call pftdyn_cnbal() !pftdynMod.F
#endif
end if
#endif
!#if (defined CN)
! ============================================================================
! Update dynamic N deposition field, on albedo timestep
! currently being done outside clumps loop, but no reason why it couldn't be
! re-written to go inside.
! ============================================================================
! PET: switching CN timestep
! if (fndepdyn /= ' ') then
! call ndepdyn_interp() !ndepFileMod.F not finish, need to modify the part read nitrogen deposition data.
! end if
!#endif
!ylu end
! ============================================================================
! Initialize variables from previous time step and
! Determine canopy interception and precipitation onto ground surface.
! Determine the fraction of foliage covered by water and the fraction
! of foliage that is dry and transpiring. Initialize snow layer if the
! snow accumulation exceeds 10 mm.
! ============================================================================
!ylu add from CLM4
! call get_clump_bounds(nc, begg, endg, begl, endl, begc, endc, begp, endp)
! do c = begc,endc
! clm3%g%l%c%cps%decl(c) = declin
! end do
!ylu end
!ylu add
! initialize declination for current timestep
do c = begc,endc
clm3%g%l%c%cps%decl(c) = declin
end do
!!
call CLMDebug('DriverInit') !This module was not changed in CLM4
call DriverInit(begc, endc, begp, endp, &
filter%num_nolakec, filter%nolakec, &
filter%num_lakec, filter%lakec)
! ============================================================================
! Hydrology1
! ============================================================================
call CLMDebug('Hydrology1') !checked and modified according to CLM4
call Hydrology1(begc, endc, begp, endp, &
filter%num_nolakec, filter%nolakec, &
filter%num_nolakep, filter%nolakep)
! ============================================================================
! Surface Radiation
! ============================================================================
call CLMDebug('SurfaceRadiation') !checked and modified according to CLM4
call SurfaceRadiation(begp, endp, filter%num_nourbanp, filter%nourbanp)
!ylu add urban module from CLM4
! call CLMDebug('UrbanRadiation') ! added the new module from CLM4
! call UrbanRadiation(begl, endl, begc, endc, begp, endp, &
! filter%num_nourbanl, filter%nourbanl, &
! filter%num_urbanl, filter%urbanl, &
! filter%num_urbanc, filter%urbanc, &
! filter%num_urbanp, filter%urbanp)
! ============================================================================
! Determine leaf temperature and surface fluxes based on ground
! temperature from previous time step.
! ============================================================================
call CLMDebug('Biogeophysics1') !checked and modified according to CLM4
call Biogeophysics1(begg, endg, begc, endc, begp, endp, &
filter%num_nolakec, filter%nolakec, &
filter%num_nolakep, filter%nolakep)
! ============================================================================
! Determine bare soil or snow-covered vegetation surface temperature and fluxes
! Calculate Ground fluxes (frac_veg_nosno is either 1 or 0)
! ============================================================================
call CLMDebug('BareGroundFluxes') !checked and modified according to CLM4
call BareGroundFluxes(begp, endp, &
filter%num_nolakeurbanp, filter%nolakeurbanp)
! ============================================================================
! Determine non snow-covered vegetation surface temperature and fluxes
! Calculate canopy temperature, latent and sensible fluxes from the canopy,
! and leaf water change by evapotranspiration
! ============================================================================
!ylu add from CLM4
! call CLMDebug('UrbanFluxes') ! added the new module from CLM4
! call UrbanFluxes(begp, endp, begl, endl, begc, endc, &
! filter%num_nourbanl, filter%nourbanl, &
! filter%num_urbanl, filter%urbanl, &
! filter%num_urbanc, filter%urbanc, &
! filter%num_urbanp, filter%urbanp)
!end
call CLMDebug('CanopyFluxes') !checked and modified according to CLM4
call CanopyFluxes(begg, endg, begc, endc, begp, endp, &
filter%num_nolakep, filter%nolakep)
! ============================================================================
! Determine lake temperature and surface fluxes
! ============================================================================
call CLMDebug('BiogeophysicsLake') !checked and modified according to CLM4
call BiogeophysicsLake(begc, endc, begp, endp, &
filter%num_lakec, filter%lakec, &
filter%num_lakep, filter%lakep)
#if (defined DUST)
! Dust mobilization (C. Zender's modified codes)
call DustEmission(begp, endp, begc, endc, begl, endl, & ! added the new module from CLM4
filter%num_nolakep, filter%nolakep)
! Dust dry deposition (C. Zender's modified codes)
call DustDryDep(begp, endp) ! added the new module from CLM4
#endif
!!!!!!!!!!!!!!
! ============================================================================
! Determine VOC and DGVM Respiration if appropriate
! ============================================================================
!ylu add: VOC used in CLM4 as a defaul
!#if (defined VOC)
! VOC emission (A. Guenther's model)
! call VOCEmission(begp, endp, &
! filter%num_nolakep, filter%nolakep) !CLM3.5
call CLMDebug('Begin VOCEmission')
call VOCEmission(begp, endp, &
filter%num_soilp, filter%soilp) !CLM4 !checked and modified according to CLM4
!#endif
! ============================================================================
! Ecosystem dynamics: phenology, vegetation, soil carbon, snow fraction
! ============================================================================
!#if (defined DGVM)
! Surface biogeochemical fluxes: co2 respiration and plant production
! call DGVMRespiration(begc, endc, begp, endp, &
! filter%num_nolakec, filter%nolakec, &
! filter%num_nolakep, filter%nolakep)
! call DGVMEcosystemDyn(begp, endp, &
! filter%num_nolakep, filter%nolakep, &
! doalb, endofyr=.false.)
!#elif call CNEcosystemDyn
!#else
! call CLMDebug('EcosystemDyn')
! call EcosystemDyn(begp, endp, &
! filter%num_nolakep, filter%nolakep, &
! doalb)
!#endif
! ============================================================================
! Determine albedos for next time step
! ============================================================================
! if (doalb) then
! call CLMDebug('SurfaceAlbedo')
! call SurfaceAlbedo(begg, endg, begc, endc, begp, endp, caldayp1)
! end if
! ============================================================================
! Determine soil/snow temperatures including ground temperature and
! update surface fluxes for new ground temperature.
! ============================================================================
call CLMDebug('Biogeophysics2')
! call Biogeophysics2(begc, endc, begp, endp, &
! filter%num_nolakec, filter%nolakec, &
! filter%num_nolakep, filter%nolakep) !CLM3.5
call Biogeophysics2(begl, endl, begc, endc, begp, endp, &
filter%num_urbanl, filter%urbanl, &
filter%num_nolakec, filter%nolakec, &
filter%num_nolakep, filter%nolakep) !changed according to CLM4
! ============================================================================
! Perform averaging from PFT level to column level
! ============================================================================
call CLMDebug('pft2col') !changed according to CLM4
call pft2col(begc, endc, filter%num_nolakec, filter%nolakec)
! ============================================================================
! Vertical (column) soil and surface hydrology
! ============================================================================
call CLMDebug('Hydrology2')
!CLM4 -- ylu changed
call Hydrology2(begc, endc, begp, endp, &
filter%num_nolakec, filter%nolakec, &
filter%num_hydrologyc, filter%hydrologyc, &
filter%num_urbanc, filter%urbanc, &
filter%num_snowc, filter%snowc, &
filter%num_nosnowc, filter%nosnowc)
! call Hydrology2(begc, endc, ilx ,jlx, &
!New in 3.5
! begp, endp, &
! filter%num_nolakec, filter%nolakec, &
! filter%num_soilc, filter%soilc, &
! filter%num_snowc, filter%snowc, &
! filter%num_nosnowc, filter%nosnowc)
! ============================================================================
! Lake hydrology
! ============================================================================
call CLMDebug('HydrologyLake') !ylu modified according to CLM4
call HydrologyLake(begp, endp, &
filter%num_lakep, filter%lakep)
! ============================================================================
! Update Snow Age (needed for surface albedo calculation
! ============================================================================
!ylu add new from CLM4
! ============================================================================
! ! Fraction of soil covered by snow (Z.-L. Yang U. Texas)
! ============================================================================
do c = begc,endc
l = clandunit(c)
if (itypelun(l) == isturb) then
! Urban landunit use Bonan 1996 (LSM Technical Note)
cptr%cps%frac_sno(c) = min( cptr%cps%snowdp(c)/0.05_r8, 1._r8)
else
! snow cover fraction in Niu et al. 2007
cptr%cps%frac_sno(c) = 0.0_r8
if(cptr%cps%snowdp(c) .gt. 0.0_r8) then
cptr%cps%frac_sno(c) = tanh(cptr%cps%snowdp(c)/(2.5_r8*zlnd* &
(min(800._r8,cptr%cws%h2osno(c)/cptr%cps%snowdp(c))/100._r8)**1._r8) )
endif
end if
end do
! ============================================================================
! Snow aging routine based on Flanner and Zender (2006), Linking snowpack
! microphysics and albedo evolution, JGR, and Brun (1989), Investigation of
! wet-snow metamorphism in respect of liquid-water content, Ann. Glaciol.
! ============================================================================
! call CLMDebug('Begin SnowAge_grain')
! call SnowAge_grain(begc, endc, & !SNICARMod.F new module in CLM4 -- ylu
! filter%num_snowc, filter%snowc, &
! filter%num_nosnowc, filter%nosnowc)
call CLMDebug('SnowAge_grain')
call SnowAge_grain(begc, endc, &
filter%num_snowc, filter%snowc, &
filter%num_nosnowc, filter%nosnowc)
! call SnowAge(begc, endc)
! ============================================================================
! ! Fraction of soil covered by snow (Z.-L. Yang U. Texas)
! ============================================================================
! do c = begc,endc
! cptr%cps%frac_sno(c) = cptr%cps%snowdp(c) / (10.*zlnd + cptr%cps%snowdp(c))
! end do
!Added for CLM3.5
! ============================================================================
! Ecosystem dynamics: Uses CN, DGVM, or static parameterizations
! ============================================================================
!ylu begin 3
#if (defined CN)
! fully prognostic canopy structure and C-N biogeochemistry
! - CNDV defined: prognostic biogeography; else prescribed
! - CROP defined: crop algorithms called from within CNEcosystemDyn
#if (defined CROP)
!ylu change filter(nc) to filter
call CLMDebug('Begin CNEcosystemDyn')
call CNEcosystemDyn(begc,endc,begp,endp,filter%num_soilc,& !Checked and looks right so far --Yaqiong Lu 11/09/10
filter%soilc, filter%num_soilp, &
filter%soilp, filter%num_pcropp, &
filter%pcropp, doalb)
#else
call CNEcosystemDyn(begc,endc,begp,endp,filter%num_soilc,&
filter%soilc, filter%num_soilp, &
filter%soilp, doalb)
#endif
call CLMDebug('Begin CNAnnualUpdate')
call CNAnnualUpdate(begc,endc,begp,endp,filter%num_soilc,& !Add the new code from CLM4 --Yaqiong Lu 11/04/2010
filter%soilc, filter%num_soilp, &
filter%soilp)
!the CASA option is not currently used in the coupled model
#elif (defined CASA)
! Prescribed biogeography,
! prescribed canopy structure, some prognostic carbon fluxes
call casa_ecosystemDyn(begc, endc, begp, endp, &
filter%num_soilc, filter%soilc, &
filter%num_soilp, filter%soilp, doalb)
call EcosystemDyn(begp, endp, &
filter%num_nolakep, filter%nolakep, &
doalb)
#else
! Prescribed biogeography,
! prescribed canopy structure, some prognostic carbon fluxes
! The coupled model will use CN option, so this code is not add into our coupled model
call CLMDebug('Begin EcosystemDyn')
call EcosystemDyn(begp, endp, &
filter%num_nolakep, filter%nolakep, &
doalb)
#endif
! Dry Deposition of chemical tracers (Wesely (1998) parameterizaion)
! call depvel_compute(begp,endp)
!ylu end 3
! ============================================================================
! Check the energy and water balance
! ============================================================================
call CLMDebug('BalanceCheck') !Yaqiong Lu add this new code from CLM4
call BalanceCheck(begp, endp, begc, endc, begl, endl, begg, endg)
!ylu add
#if (defined CN)
! nstep = get_nstep()
if (nstep > 2) then
! call t_startf('cnbalchk')
call CLMDebug('CBalanceCheck')
call CBalanceCheck(begc, endc, filter%num_soilc, filter%soilc)
call CLMDebug('NBalanceCheck')
call NBalanceCheck(begc, endc, filter%num_soilc, filter%soilc)
! call t_stopf('cnbalchk')
end if
#endif
!end add
! ============================================================================
! Update accumulators
! ============================================================================
if (doalb) then
! Albedos for non-urban columns
call CLMDebug('SurfaceAlbedo') !checed and modified accoring to CLM4 --ylu
call SurfaceAlbedo(begg, endg, begc, endc, begp, endp, &
filter%num_nourbanc, filter%nourbanc, &
filter%num_nourbanp, filter%nourbanp,nextsw_cday ,declinp1)
! Albedos for urban columns
! if (filter%num_urbanl > 0) then
! call CLMDebug('UrbanAlbedo') !Yaqiong Lu add this new code from CLM4
! call UrbanAlbedo(begl, endl, begc, endc, begp, endp, &
! filter%num_urbanl, filter%urbanl, &
! filter%num_urbanc, filter%urbanc, &
! filter%num_urbanp, filter%urbanp)
! end if
end if
! call CLMDebug('updateAccFlds')
! call updateAccFlds()
! call accum_dealloc
! call filters_dealloc
#if (!defined CN)
call EcosystemDyn_dealloc
#endif
end subroutine driver
#endif