subroutine endrun call abort return end #ifdef WRF_USE_CLM module TridiagonalMod !----------------------------------------------------------------------- !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, & 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 !----------------------------------------------------------------------- !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 end subroutine globals_mod end module globals module nanMod !----------------------------------------------------------------------- !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) ! ! !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 !----------------------------------------------------------------------- !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) integer :: num_landcover_types !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(nlcat) integer,intent(in) :: nlcat num_landcover_types = nlcat ! land use type end subroutine clm_varpar_mod !------------------------------------------------------------------------------ end module clm_varpar module clm_varcon !----------------------------------------------------------------------- !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,& num_landcover_types ! ! !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 (USGS); 20 (MODIS) ! 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, allocatable :: plant(:,:) real(r8),allocatable :: cover(:,:) 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 !---------------------------------------------------------------------------- !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 !----------------------------------------------------------------------- ! MODIS vegetation 20 categories !'Evergreen Needleleaf Forest' 1 !'Evergreen Broadleaf Forest' 2 !'Deciduous Needleleaf Forest' 3 !'Deciduous Broadleaf Forest' 4 !'Mixed Forests' 5 !'Closed Shrublands' 6 !'Open Shrublands' 7 !'Woody Savannas' 8 !'Savannas' 9 !'Grasslands' 10 !'Permanent wetlands' 11 !'Croplands' 12 !'Urban and Built-Up' 13 !'cropland/natural vegetation mosaic'14 !'Snow and Ice' 15 !'Barren or Sparsely Vegetated' 16 !'Water' 17 !'Wooded Tundra' 18 !'Mixed Tundra' 19 !'Barren Tundra' 20 !----------------------------------------------------------------------- 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 allocate (plant(num_landcover_types,maxpatch_pft)) allocate (cover(num_landcover_types,maxpatch_pft)) if(num_landcover_types== 24.or. num_landcover_types==28) then ! USGS plant(:,1) = (/ 0, 15, 15, 15, 15, 15, & 14, 9, 9, 14, 7, 3, & 4, 1, 1, 0, 0, 4, & 11, 11, 2, 11, 11, 0/) cover(:,1) = (/100., 85., 85., 85., 50., 40., & 60., 80., 50., 70., 75., 50., & 95., 75., 37., 100., 100., 80., & 10., 30., 13., 20., 10., 100./) plant(:,2) = (/ 0, 0, 0, 0, 14, 3, & 13, 0, 14, 6, 0, 0, & 0, 0, 7, 0, 0, 0, & 0, 12, 3, 12, 12, 0/) cover(:,2) = (/0., 15., 15., 15., 35., 30., & 20., 20., 30., 30., 25., 50., & 5., 25., 37., 0., 0., 20., & 90., 30., 13., 20., 10., 0./) plant(:,3) = (/ 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, & 0, 0, 10, 0, 0, 0/) cover(:,3) = (/0., 0., 0., 0., 15., 30., & 20., 0., 20., 0., 0., 0., & 0., 0., 26., 0., 0., 0., & 0., 40., 24., 60., 80., 0./) plant(:,4) = (/ 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0/) cover(:,4) = (/ 0., 0., 0., 0., 0., 0., & 0., 0., 0., 0., 0., 0., & 0., 0., 0., 0., 0., 0., & 0., 0., 50., 0., 0., 0./) else if (num_landcover_types== 20.or. num_landcover_types==21) then !MODIS plant(:,1) = (/1, 4, 3, 7, 1, 9, 9, 9, 14, 14, & 0, 15, 0, 15, 0, 11, 0, 2, 11, 11/) cover(:,1) = (/75., 95.,50., 75., 37., 80., 50., 80., 70.,60.,& 100.,85.,100., 50., 100.,10., 100.,13., 20.,10./) plant(:,2) = (/0, 0, 0, 0, 7, 0, 14, 0, 6, 13, & 0, 0, 0, 14,0, 0, 0, 3, 12,12/) cover(:,2) = (/25., 5., 50.,25.,37.,20.,30.,20.,30.,20.,& 0., 15.,0., 35.,0., 90.,0., 13.,20.,10./) plant(:,3) = (/0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0,10, 0, 0/) cover(:,3) = (/0.,0.,0., 0., 26.,0., 20., 0., 0., 20.,& 0.,0.,0., 15.,0., 0., 0., 24., 60.,80./) plant(:,4) = (/0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/) cover(:,4) = (/0.,0.,0.,0.,0.,0.,0.,0., 0.,0.,& 0.,0.,0.,0.,0.,0.,0.,50.,0.,0./) else write(6,*)'CLM works only for USGS (24) and MODIS(20) land use types, ' write(6,*)'but the current number of land use types is ',num_landcover_types call endrun() end if end subroutine var_par end module clm_varcon module clm_varsur !----------------------------------------------------------------------- !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 ! ! !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 ! ! !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 !----------------------------------------------------------------------- !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 end subroutine clmtype_mod end module clmtype MODULE module_sf_clm !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 & ,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 ,xtime ,dtwrf ,dzs & ,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,nlcat, & !Optional urban CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, & CMGR_SFCDIF,CHGR_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 cmcr_urb2d,tgr_urb2d,tgrl_urb3d,smr_urb3d, & ! urban drelr_urb2d,drelb_urb2d,drelg_urb2d, & ! urban flxhumr_urb2d,flxhumb_urb2d,flxhumg_urb2d, & ! 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_sf_noahlsm, only: low_density_residential, high_density_residential, high_intensity_industrial USE module_ra_gfdleta, only: cal_mon_day 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,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 integer,intent(in) :: nlcat real,intent(in) :: dt,dx real,intent(in) :: xtime, dtwrf !fchen 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 :: nstep !fchen 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 !===Yang,2014/10/08,hydrological variable for single layer UCM=== INTEGER :: jmonth, jday REAL :: DRELR_URB REAL :: DRELB_URB REAL :: DRELG_URB REAL :: FLXHUMR_URB REAL :: FLXHUMB_URB REAL :: FLXHUMG_URB REAL :: CMCR_URB REAL :: TGR_URB REAL, DIMENSION(1:num_roof_layers) :: SMR_URB ! green roof layer moisture REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K] REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D ! 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, CMGR_URB, CHGR_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) :: CMGR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_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(nlcat) 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 nstep = nint( (xtime*60. + dtwrf) / dt) if( nstep .le. 1 ) nstep = 1 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) ! convert mixing raitio to specific humdity -- Jiming Jin 7/10/2013 forc_qxy_buf = forc_qxy(i,1,j)/(1.0+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) == low_density_residential .or. & IVGTYP(I,J) == high_density_residential .or. IVGTYP(I,J) == high_intensity_industrial ) 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) SMR_URB(K) = SMR_URB3D(I,K,J) TGRL_URB(K)= TGRL_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 TGR_URB = TGR_URB2D(I,J) CMCR_URB = CMCR_URB2D(I,J) FLXHUMR_URB = FLXHUMR_URB2D(I,J) FLXHUMB_URB = FLXHUMB_URB2D(I,J) FLXHUMG_URB = FLXHUMG_URB2D(I,J) DRELR_URB = DRELR_URB2D(I,J) DRELB_URB = DRELB_URB2D(I,J) DRELG_URB = DRELG_URB2D(I,J) 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) CMGR_URB = CMGR_SFCDIF(I,J) CHGR_URB = CHGR_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 cal_mon_day(julday,julyr,jmonth,jday) 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,CMCR_URB,TGR_URB, & ! H TGRL_URB,SMR_URB,CMGR_URB, CHGR_URB, jmonth, & ! H DRELR_URB,DRELB_URB, & ! H DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB) 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) SMR_URB3D(I,K,J) = SMR_URB(K) TGRL_URB3D(I,K,J)= TGRL_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 TGR_URB2D(I,J) =TGR_URB CMCR_URB2D(I,J)=CMCR_URB FLXHUMR_URB2D(I,J)=FLXHUMR_URB FLXHUMB_URB2D(I,J)=FLXHUMB_URB FLXHUMG_URB2D(I,J)=FLXHUMG_URB DRELR_URB2D(I,J) = DRELR_URB DRELB_URB2D(I,J) = DRELB_URB DRELG_URB2D(I,J) = DRELG_URB 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 CMGR_SFCDIF(I,J) = CMGR_URB CHGR_SFCDIF(I,J) = CHGR_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, & 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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 !------------------------------------------------------------------------------ !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 ! ! !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, & 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, & 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) ! ! !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 ) IMPLICIT NONE CHARACTER*(*), str #if (defined DEBUGCLM) print*, TRIM(str) flush(6) #endif end subroutine CLMDebug module clmtypeInitMod !----------------------------------------------------------------------- !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() ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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() ! ! !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() ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! 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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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() ! ! !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) ! 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) ! 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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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() ! ! !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() ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! !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) 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 !----------------------------------------------------------------------- !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 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 !--------------------------------------------------------------------------- !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() ! ! !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) ! ! !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) ! ! !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() ! ! !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 !----------------------------------------------------------------------- !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() ! ! !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() ! ! !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 ! 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 ! ! !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 !----------------------------------------------------------------------- !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) ! ! !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 !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 ! ! !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, & 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, & 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) ! ! !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, & 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 !----------------------------------------------------------------------- !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) ! ! !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 !------------------------------------------------------------------------------ !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, & 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) ! ! !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) ! ! !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) ! ! !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 !----------------------------------------------------------------------- !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 ) ! ! ! 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 !--------------------------------------------------------------------------- !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) ! !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 !----------------------------------------------------------------------- !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 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 module procedure p2g_1d module procedure p2g_2d end interface interface c2l module procedure c2l_1d module procedure c2l_2d end interface interface c2g 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) ! ! !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) ! ! !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) ! ! !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) ! ! !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, & 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, & 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, & 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, & 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) ! ! !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) ! ! !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, & 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, & 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) ! ! !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) ! ! !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 !----------------------------------------------------------------------- !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) ! ! !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 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 , & & 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 " ! 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) !------------------------------------------------------------------------------- ! ! 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 !----------------------------------------------------------------------- !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) ! ! !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 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) deallocate(plant) deallocate(cover) end subroutine surfrd end module surfFileMod module SNICARMod !----------------------------------------------------------------------- !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, & 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) ! ! !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 ,& 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 !----------------------------------------------------------------------- ! 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() ! ! !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) ! ! !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) 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 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 !----------------------------------------------------------------------- !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 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 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, & 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) ! ! !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) ! ! !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) ! ! !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) ! ! !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 !----------------------------------------------------------------------- !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() !#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() ! ! !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) ! ! !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 !------------------------------------------------------------------------------ !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) ! ! !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 !----------------------------------------------------------------------- !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, & 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) ! ! !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, & 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 !----------------------------------------------------------------------- !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, & 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) ! ! !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, & 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 !----------------------------------------------------------------------- !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, & 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, & 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, & 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, & 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 !----------------------------------------------------------------------- !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, & 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) ! ! !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) ! ! !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) ! ! !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) ! ! !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, & 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 !#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 () ! ! !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) ! ! !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) ! ! !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) ! ! !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 () ! 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 !----------------------------------------------------------------------- !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) ! ! !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 !----------------------------------------------------------------------- !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, & 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 !----------------------------------------------------------------------- !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, & 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 !----------------------------------------------------------------------- !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, & 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 !------------------------------------------------------------------------------ !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, & 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) ! ! !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 & ,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 ,& 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 !----------------------------------------------------------------------- !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, & 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) ! ! !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 if (abs(errsoi_col(c)) > 1.0e-2_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 !------------------------------------------------------------------------------ !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) ! ! !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) !mchen??? 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 !------------------------------------------------------------------------------ !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, & 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 !----------------------------------------------------------------------- !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, & 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 !----------------------------------------------------------------------- !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, & 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 #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, & 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 #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, & 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 #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) ! ! !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) ! ! !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) ! ! !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) ! ! !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 #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) ! ! !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) ! ! !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 #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) ! ! !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) ! ! !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 #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) ! ! !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 #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, & 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 #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) ! ! !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() ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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 #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) ! ! !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) ! ! !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 #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) ! ! !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 #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) ! ! !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) ! ! !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 #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) ! ! !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 #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 ) ! ! !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) ! ! !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) ! ! !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 #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) ! ! !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 #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) ! ! !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) ! ! !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 #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) ! ! !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 #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) #else subroutine CNPhenology (num_soilc, filter_soilc, num_soilp, filter_soilp) #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) #else subroutine CNPhenologyClimate (num_soilp, filter_soilp) #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) ! ! !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) ! ! !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) ! ! !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) ! !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) ! 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) ! * * * 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) ! ! !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) ! ! !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) ! ! !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) ! ! !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) ! ! !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 #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) ! ! !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 #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) ! ! !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) ! ! !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 #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) ! ! !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 #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) ! ! !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 () #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 & ,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 #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, & num_soilp, filter_soilp, num_pcropp, filter_pcropp, doalb) #else subroutine CNEcosystemDyn(lbc, ubc, lbp, ubp, num_soilc, filter_soilc, & 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 ,& 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 !----------------------------------------------------------------------- !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 & ,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.') !----------------------------------------------------------------------- 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 & ,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) alswvisdif = alswvisdif + 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) ! ! !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