diff --git a/components/clm/src/ED/biogeochem/EDCanopyStructureMod.F90 b/components/clm/src/ED/biogeochem/EDCanopyStructureMod.F90 index 3b8d94e6ed..f144fee89d 100755 --- a/components/clm/src/ED/biogeochem/EDCanopyStructureMod.F90 +++ b/components/clm/src/ED/biogeochem/EDCanopyStructureMod.F90 @@ -5,17 +5,19 @@ module EDCanopyStructureMod ! This is obviosuly far too complicated for it's own good and needs re-writing. ! ============================================================================ - use shr_kind_mod , only : r8 => shr_kind_r8; + use FatesConstantsMod , only : r8 => fates_r8 use FatesGlobals , only : fates_log use pftconMod , only : pftcon use EDGrowthFunctionsMod , only : c_area use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd - use EDtypesMod , only : cp_nclmax,cp_nlevcan - use EDtypesMod , only : numpft_ed + use EDTypesMod , only : nclmax + use EDTypesMod , only : nlevcan + use EDTypesMod , only : numpft_ed + use FatesGlobals , only : endrun => fates_endrun + + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg - use abortutils , only : endrun - use FatesGlobals , only : fates_log implicit none private @@ -79,7 +81,7 @@ subroutine canopy_structure( currentSite ) use EDParamsMod, only : ED_val_comp_excln, ED_val_ag_biomass use SFParamsMod, only : SF_val_cwd_frac - use EDtypesMod , only : ncwd, min_patch_area, cp_nlevcan + use EDtypesMod , only : ncwd, min_patch_area ! ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite @@ -94,10 +96,10 @@ subroutine canopy_structure( currentSite ) real(r8) :: cc_loss real(r8) :: lossarea real(r8) :: newarea - real(r8) :: arealayer(cp_nlevcan) ! Amount of plant area currently in each canopy layer - real(r8) :: sumdiff(cp_nlevcan) ! The total of the exclusion weights for all cohorts in layer z + real(r8) :: arealayer(nlevcan) ! Amount of plant area currently in each canopy layer + real(r8) :: sumdiff(nlevcan) ! The total of the exclusion weights for all cohorts in layer z real(r8) :: weight ! The amount of the total lost area that comes from this cohort - real(r8) :: sum_weights(cp_nlevcan) + real(r8) :: sum_weights(nlevcan) real(r8) :: new_total_area_check real(r8) :: missing_area, promarea,cc_gain,sumgain integer :: promswitch,lower_cohort_switch @@ -138,7 +140,7 @@ subroutine canopy_structure( currentSite ) z = z + 1 endif - currentPatch%NCL_p = min(cp_nclmax,z) ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(nclmax,z) ! Set current canopy layer occupancy indicator. do i = 1,z ! Loop around the currently occupied canopy layers. @@ -199,7 +201,7 @@ subroutine canopy_structure( currentSite ) currentCohort%dbh = currentCohort%dbh copyc%dbh = copyc%dbh !+ 0.000000000001_r8 !kill the ones which go into canopy layers that are not allowed... (default nclmax=2) - if(i+1 > cp_nclmax)then + if(i+1 > nclmax)then !put the litter from the terminated cohorts into the fragmenting pools ! write(fates_log(),*) '3rd canopy layer' do c=1,ncwd @@ -244,8 +246,8 @@ subroutine canopy_structure( currentSite ) currentCohort%canopy_layer = i + 1 !the whole cohort becomes demoted sumloss = sumloss + currentCohort%c_area - !kill the ones which go into canopy layers that are not allowed... (default cp_nclmax=2) - if(i+1 > cp_nclmax)then + !kill the ones which go into canopy layers that are not allowed... (default nclmax=2) + if(i+1 > nclmax)then !put the litter from the terminated cohorts into the fragmenting pools do c=1,ncwd @@ -292,7 +294,7 @@ subroutine canopy_structure( currentSite ) enddo !arealayer loop if(arealayer(i)-currentPatch%area > 0.00001_r8)then - write(fates_log(),*) 'lossarea problem', lossarea,sumloss,z,currentPatch%patchno,currentPatch%clm_pno + write(fates_log(),*) 'lossarea problem', lossarea,sumloss,z,currentPatch%patchno endif enddo !z @@ -317,7 +319,7 @@ subroutine canopy_structure( currentSite ) excess_area = arealayer(j)-currentPatch%area endif enddo - currentPatch%ncl_p = min(z,cp_nclmax) + currentPatch%ncl_p = min(z,nclmax) enddo !is there still excess area in any layer? @@ -492,7 +494,7 @@ subroutine canopy_structure( currentSite ) if(currentPatch%area-arealayer(i) < 0.000001_r8)then !write(fates_log(),*) 'gainarea problem',sumgain,arealayer(i),currentPatch%area,z, & - !currentPatch%patchno,currentPatch%clm_pno,currentPatch%area - arealayer(i),i,missing_area,count_mi + !currentPatch%patchno,currentPatch%area - arealayer(i),i,missing_area,count_mi endif if(promswitch == 1)then ! write(fates_log(),*) 'z loop',arealayer(1:3),currentPatch%patchno,z @@ -519,7 +521,7 @@ subroutine canopy_structure( currentSite ) endif endif enddo - currentPatch%ncl_p = min(z,cp_nclmax) + currentPatch%ncl_p = min(z,nclmax) if(promswitch == 1)then ! write(fates_log(),*) 'missingarea loop',arealayer(1:3),currentPatch%patchno,missing_area,z endif @@ -530,7 +532,7 @@ subroutine canopy_structure( currentSite ) call terminate_cohorts(currentPatch) if(promswitch == 1)then - !write(fates_log(),*) 'going into cohort check',currentPatch%clm_pno + !write(fates_log(),*) 'going into cohort check' endif ! ----------- Check cohort area ------------------------------! do i = 1,z @@ -592,7 +594,6 @@ subroutine canopy_spread( currentSite ) ! Calculates the spatial spread of tree canopies based on canopy closure. ! ! !USES: - use EDTypesMod , only : cp_nlevcan use EDParamsMod , only : ED_val_maxspread, ED_val_minspread ! ! !ARGUMENTS @@ -601,7 +602,7 @@ subroutine canopy_spread( currentSite ) ! !LOCAL VARIABLES: type (ed_cohort_type), pointer :: currentCohort type (ed_patch_type) , pointer :: currentPatch - real(r8) :: arealayer(cp_nlevcan) ! Amount of canopy in each layer. + real(r8) :: arealayer(nlevcan) ! Amount of canopy in each layer. real(r8) :: inc ! Arbitrary daily incremental change in canopy area integer :: z !---------------------------------------------------------------------- @@ -624,7 +625,7 @@ subroutine canopy_spread( currentSite ) enddo !If the canopy area is approaching closure, squash the tree canopies and make them taller and thinner - do z = 1,cp_nclmax + do z = 1,nclmax if(arealayer(z)/currentPatch%area > 0.9_r8)then currentPatch%spread(z) = currentPatch%spread(z) - inc @@ -659,6 +660,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use FatesInterfaceMod , only : bc_in_type use EDPatchDynamicsMod , only : set_patchno + use EDPatchDYnamicsMod , only : set_root_fraction use EDCohortDynamicsMod , only : size_and_type_class_index use EDGrowthFunctionsMod , only : tree_lai, c_area use EDEcophysConType , only : EDecophyscon @@ -698,7 +700,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do while(associated(currentPatch)) - call currentPatch%set_root_fraction(bc_in(s)%depth_gl) + call set_root_fraction(currentPatch,bc_in(s)%depth_gl) !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 @@ -772,7 +774,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! !USES: use EDGrowthFunctionsMod , only : tree_lai, tree_sai, c_area - use EDtypesMod , only : area, dinc_ed, hitemax, numpft_ed, n_hite_bins + use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins use EDEcophysConType , only : EDecophyscon ! @@ -848,7 +850,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft),currentCohort%NV) currentPatch%lai = currentPatch%lai +currentCohort%lai - do L = 1,cp_nclmax-1 + do L = 1,nclmax-1 if(currentCohort%canopy_layer == L)then currentPatch%canopy_layer_lai(L) = currentPatch%canopy_layer_lai(L) + currentCohort%lai + & currentCohort%sai @@ -1101,10 +1103,10 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) /currentPatch%tlai_profile(L,ft,iv) enddo - currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 - currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: cp_nlevcan) = 0._r8 + currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 + currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 + currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 + currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevcan) = 0._r8 enddo enddo @@ -1162,7 +1164,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) do L = 1,currentPatch%NCL_p do ft = 1,numpft_ed if(currentPatch%present(L,FT) > 1)then - write(fates_log(), *) 'ED: present issue',currentPatch%clm_pno,L,ft,currentPatch%present(L,FT) + write(fates_log(), *) 'ED: present issue',L,ft,currentPatch%present(L,FT) currentPatch%present(L,ft) = 1 endif enddo @@ -1189,7 +1191,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceMod , only : bc_out_type - use ColumnType , only : col ! THIS MUST BE REMOVED WITH CLM_PNO ! ! !ARGUMENTS @@ -1213,8 +1214,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) do while(associated(currentPatch)) ifp = ifp+1 - currentPatch%clm_pno = ifp + col%patchi(c) ! THIS IS SLOWLY BEING REMOVED - if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area diff --git a/components/clm/src/ED/biogeochem/EDCohortDynamicsMod.F90 b/components/clm/src/ED/biogeochem/EDCohortDynamicsMod.F90 index 2237553ccd..d2fd8c421f 100755 --- a/components/clm/src/ED/biogeochem/EDCohortDynamicsMod.F90 +++ b/components/clm/src/ED/biogeochem/EDCohortDynamicsMod.F90 @@ -4,20 +4,24 @@ module EDCohortDynamicsMod ! Cohort stuctures in ED. ! ! !USES: - use abortutils , only : endrun + use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log - use FatesGlobals , only : freq_day + use FatesInterfaceMod , only : hlm_freq_day use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int - use shr_log_mod , only : errMsg => shr_log_errMsg use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon use EDGrowthFunctionsMod , only : c_area, tree_lai use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use EDTypesMod , only : fusetol, cp_nclmax - use EDtypesMod , only : ncwd, maxcohortsperpatch - use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA - use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath + use EDTypesMod , only : fusetol + use EDTypesMod , only : nclmax + use EDTypesMod , only : ncwd + use EDTypesMod , only : maxCohortsPerPatch + use EDTypesMod , only : sclass_ed,nlevsclass_ed,AREA + use EDTypesMod , only : min_npm2, min_nppatch + use EDTypesMod , only : min_n_safemath + ! CIME globals + use shr_log_mod , only : errMsg => shr_log_errMsg ! implicit none private @@ -223,7 +227,6 @@ subroutine allocate_live_biomass(cc_p,mode) ! Use different proportions if the leaves are on vs off if(leaves_off_switch==0)then - new_bl = currentcohort%balive*leaf_frac new_br = pftcon%froot_leaf(ft) * (currentcohort%balive + currentcohort%laimemory) * leaf_frac @@ -236,12 +239,12 @@ subroutine allocate_live_biomass(cc_p,mode) if(mode==1)then currentcohort%npp_leaf = currentcohort%npp_leaf + & - max(0.0_r8,new_bl - currentcohort%bl) / freq_day + max(0.0_r8,new_bl - currentcohort%bl) / hlm_freq_day currentcohort%npp_froot = currentcohort%npp_froot + & - max(0._r8,new_br - currentcohort%br) / freq_day + max(0._r8,new_br - currentcohort%br) / hlm_freq_day - currentcohort%npp_bsw = max(0.0_r8, new_bsw - currentcohort%bsw)/freq_day + currentcohort%npp_bsw = max(0.0_r8, new_bsw - currentcohort%bsw)/hlm_freq_day currentcohort%npp_bdead = currentCohort%dbdeaddt @@ -274,9 +277,9 @@ subroutine allocate_live_biomass(cc_p,mode) if(mode==1)then currentcohort%npp_froot = currentcohort%npp_froot + & - max(0.0_r8,new_br-currentcohort%br)/freq_day + max(0.0_r8,new_br-currentcohort%br)/hlm_freq_day - currentcohort%npp_bsw = max(0.0_r8, new_bsw-currentcohort%bsw)/freq_day + currentcohort%npp_bsw = max(0.0_r8, new_bsw-currentcohort%bsw)/hlm_freq_day currentcohort%npp_bdead = currentCohort%dbdeaddt @@ -530,7 +533,7 @@ subroutine terminate_cohorts( patchptr ) endif ! In the third canopy layer - if (currentCohort%canopy_layer > cp_nclmax ) then + if (currentCohort%canopy_layer > nclmax ) then terminate = 1 if ( DEBUG ) then write(fates_log(),*) 'terminating cohorts 2', currentCohort%canopy_layer @@ -602,7 +605,7 @@ subroutine fuse_cohorts(patchptr) ! Join similar cohorts to reduce total number ! ! !USES: - use EDTypesMod , only : cp_nlevcan + use EDTypesMod , only : nlevcan ! ! !ARGUMENTS type (ed_patch_type), intent(inout), target :: patchptr @@ -754,7 +757,7 @@ subroutine fuse_cohorts(patchptr) currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn - do i=1, cp_nlevcan + do i=1, nlevcan if (currentCohort%year_net_uptake(i) == 999._r8 .or. nextc%year_net_uptake(i) == 999._r8) then currentCohort%year_net_uptake(i) = min(nextc%year_net_uptake(i),currentCohort%year_net_uptake(i)) else diff --git a/components/clm/src/ED/biogeochem/EDGrowthFunctionsMod.F90 b/components/clm/src/ED/biogeochem/EDGrowthFunctionsMod.F90 index 12a46c79b1..cd330f1c8b 100755 --- a/components/clm/src/ED/biogeochem/EDGrowthFunctionsMod.F90 +++ b/components/clm/src/ED/biogeochem/EDGrowthFunctionsMod.F90 @@ -6,11 +6,11 @@ module EDGrowthFunctionsMod ! At present, there is only a single allocation trajectory. ! ============================================================================ - use shr_kind_mod , only : r8 => shr_kind_r8 + use FatesConstantsMod, only : r8 => fates_r8 use FatesGlobals , only : fates_log use pftconMod , only : pftcon use EDEcophysContype , only : EDecophyscon - use EDTypesMod , only : ed_cohort_type, cp_nlevcan, dinc_ed + use EDTypesMod , only : ed_cohort_type, nlevcan, dinc_ed implicit none private @@ -159,10 +159,10 @@ real(r8) function tree_lai( cohort_in ) cohort_in%treelai = tree_lai ! here, if the LAI exceeeds the maximum size of the possible array, then we have no way of accomodating it - ! at the moments cp_nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a + ! at the moments nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a ! huge error - if(cohort_in%treelai > cp_nlevcan*dinc_ed)then - write(fates_log(),*) 'too much lai' , cohort_in%treelai , cohort_in%pft , cp_nlevcan * dinc_ed + if(cohort_in%treelai > nlevcan*dinc_ed)then + write(fates_log(),*) 'too much lai' , cohort_in%treelai , cohort_in%pft , nlevcan * dinc_ed endif return @@ -196,10 +196,10 @@ real(r8) function tree_sai( cohort_in ) cohort_in%treesai = tree_sai ! here, if the LAI exceeeds the maximum size of the possible array, then we have no way of accomodating it - ! at the moments cp_nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a + ! at the moments nlevcan default is 40, which is very large, so exceeding this would clearly illustrate a ! huge error - if(cohort_in%treesai > cp_nlevcan*dinc_ed)then - write(fates_log(),*) 'too much sai' , cohort_in%treesai , cohort_in%pft , cp_nlevcan * dinc_ed + if(cohort_in%treesai > nlevcan*dinc_ed)then + write(fates_log(),*) 'too much sai' , cohort_in%treesai , cohort_in%pft , nlevcan * dinc_ed endif return diff --git a/components/clm/src/ED/biogeochem/EDPatchDynamicsMod.F90 b/components/clm/src/ED/biogeochem/EDPatchDynamicsMod.F90 index df283d6c54..b18279c06e 100755 --- a/components/clm/src/ED/biogeochem/EDPatchDynamicsMod.F90 +++ b/components/clm/src/ED/biogeochem/EDPatchDynamicsMod.F90 @@ -3,16 +3,26 @@ module EDPatchDynamicsMod ! ============================================================================ ! Controls formation, creation, fusing and termination of patch level processes. ! ============================================================================ - - use shr_kind_mod , only : r8 => shr_kind_r8; - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use clm_varctl , only : iulog - use FatesGlobals , only : freq_day + + use FatesGlobals , only : fates_log + use FatesInterfaceMod , only : hlm_freq_day use pftconMod , only : pftcon use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort - use EDtypesMod , only : ncwd, n_dbh_bins, ntol, numpft_ed, area, dbhmax, maxPatchesPerCol + use EDtypesMod , only : ncwd, n_dbh_bins, ntol, area, dbhmax + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : maxPatchesPerSite use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type - use EDTypesMod , only : min_patch_area, cp_numlevgrnd, cp_numSWb + use EDTypesMod , only : min_patch_area + use EDTypesMod , only : nclmax + use FatesInterfaceMod , only : hlm_numlevgrnd + use FatesInterfaceMod , only : hlm_numlevsoil + use FatesInterfaceMod , only : hlm_numSWb + use FatesGlobals , only : endrun => fates_endrun + use FatesConstantsMod , only : r8 => fates_r8 + + ! CIME globals + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! implicit none private @@ -26,6 +36,7 @@ module EDPatchDynamicsMod public :: disturbance_rates public :: check_patch_area public :: set_patchno + public :: set_root_fraction private:: fuse_2_patches @@ -85,7 +96,7 @@ subroutine disturbance_rates( site_in) if(currentCohort%canopy_layer == 1)then currentPatch%disturbance_rates(1) = currentPatch%disturbance_rates(1) + & - min(1.0_r8,currentCohort%dmort)*freq_day*currentCohort%c_area/currentPatch%area + min(1.0_r8,currentCohort%dmort)*hlm_freq_day*currentCohort%c_area/currentPatch%area endif @@ -99,7 +110,7 @@ subroutine disturbance_rates( site_in) currentPatch%disturbance_rates(2) = min(0.99_r8,currentPatch%disturbance_rates(2) + currentPatch%frac_burnt) if (currentPatch%disturbance_rates(2) > 0.98_r8)then - write(iulog,*) 'very high fire areas',currentPatch%disturbance_rates(2),currentPatch%frac_burnt + write(fates_log(),*) 'very high fire areas',currentPatch%disturbance_rates(2),currentPatch%frac_burnt endif !Only use larger of two natural disturbance modes WHY? @@ -168,7 +179,7 @@ subroutine spawn_patches( currentSite ) ! 10) Area checked, and patchno recalculated. ! ! !USES: - use EDTypesMod , only : cp_nclmax + use EDParamsMod , only : ED_val_maxspread, ED_val_understorey_death use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts ! @@ -191,7 +202,7 @@ subroutine spawn_patches( currentSite ) real(r8) :: leaf_litter_local(numpft_ed) ! initial value of leaf litter. KgC/m2 real(r8) :: cwd_ag_local(ncwd) ! initial value of above ground coarse woody debris. KgC/m2 real(r8) :: cwd_bg_local(ncwd) ! initial value of below ground coarse woody debris. KgC/m2 - real(r8) :: spread_local(cp_nclmax) ! initial value of canopy spread parameter.no units + real(r8) :: spread_local(nclmax) ! initial value of canopy spread parameter.no units !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -219,7 +230,7 @@ subroutine spawn_patches( currentSite ) cwd_bg_local = 0.0_r8 leaf_litter_local = 0.0_r8 root_litter_local = 0.0_r8 - spread_local(1:cp_nclmax) = ED_val_maxspread + spread_local(1:nclmax) = ED_val_maxspread age = 0.0_r8 allocate(new_patch) @@ -271,7 +282,7 @@ subroutine spawn_patches( currentSite ) ! because this is the part of the original patch where no trees have actually fallen ! The diagnostic cmort,bmort and hmort rates have already been saved - currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * freq_day)) + currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * hlm_freq_day)) nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. nc%cmort = nan ! The mortality diagnostics are set to nan because the cohort should dissappear @@ -298,7 +309,7 @@ subroutine spawn_patches( currentSite ) ! so with the number density must come the effective mortality rates. nc%fmort = 0.0_r8 ! Should had also been zero in the donor - nc%imort = ED_val_understorey_death/freq_day ! This was zero in the donor + nc%imort = ED_val_understorey_death/hlm_freq_day ! This was zero in the donor nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort nc%bmort = currentCohort%bmort @@ -336,7 +347,7 @@ subroutine spawn_patches( currentSite ) ! loss of individual from fire in new patch. nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) - nc%fmort = currentCohort%fire_mort/freq_day + nc%fmort = currentCohort%fire_mort/hlm_freq_day nc%imort = 0.0_r8 nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort @@ -433,7 +444,7 @@ subroutine check_patch_area( currentSite ) areatot = areatot + currentPatch%area currentPatch => currentPatch%younger if (( areatot - area ) > 0._r8 ) then - write(iulog,*) 'trimming patch area - is too big' , areatot-area + write(fates_log(),*) 'trimming patch area - is too big' , areatot-area currentSite%oldest_patch%area = currentSite%oldest_patch%area - (areatot - area) endif enddo @@ -716,7 +727,7 @@ subroutine mortality_litter_fluxes(cp_target, new_patch_target, patch_site_aread !currentCohort%dmort = mortality_rates(currentCohort) !the disturbance calculations are done with the previous n, c_area and d_mort. So it's probably & !not right to recalcualte dmort here. - canopy_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * freq_day) + canopy_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * hlm_freq_day) currentPatch%canopy_mortality_woody_litter = currentPatch%canopy_mortality_woody_litter + & canopy_dead*(currentCohort%bdead+currentCohort%bsw) @@ -808,16 +819,16 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ ! !LOCAL VARIABLES: !--------------------------------------------------------------------- - allocate(new_patch%tr_soil_dir(cp_numSWb)) - allocate(new_patch%tr_soil_dif(cp_numSWb)) - allocate(new_patch%tr_soil_dir_dif(cp_numSWb)) - allocate(new_patch%fab(cp_numSWb)) - allocate(new_patch%fabd(cp_numSWb)) - allocate(new_patch%fabi(cp_numSWb)) - allocate(new_patch%sabs_dir(cp_numSWb)) - allocate(new_patch%sabs_dif(cp_numSWb)) - allocate(new_patch%rootfr_ft(numpft_ed,cp_numlevgrnd)) - allocate(new_patch%rootr_ft(numpft_ed,cp_numlevgrnd)) + allocate(new_patch%tr_soil_dir(hlm_numSWb)) + allocate(new_patch%tr_soil_dif(hlm_numSWb)) + allocate(new_patch%tr_soil_dir_dif(hlm_numSWb)) + allocate(new_patch%fab(hlm_numSWb)) + allocate(new_patch%fabd(hlm_numSWb)) + allocate(new_patch%fabi(hlm_numSWb)) + allocate(new_patch%sabs_dir(hlm_numSWb)) + allocate(new_patch%sabs_dif(hlm_numSWb)) + allocate(new_patch%rootfr_ft(numpft_ed,hlm_numlevgrnd)) + allocate(new_patch%rootr_ft(numpft_ed,hlm_numlevgrnd)) call zero_patch(new_patch) !The nan value in here is not working?? @@ -879,7 +890,6 @@ subroutine zero_patch(cp_p) ! (this needs to be two seperate routines, one for nan & one for zero ! ! !USES: - use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) ! ! !ARGUMENTS: type(ed_patch_type), intent(inout), target :: cp_p @@ -897,7 +907,6 @@ subroutine zero_patch(cp_p) currentPatch%siteptr => null() currentPatch%patchno = 999 - currentPatch%clm_pno = 999 currentPatch%age = nan currentPatch%age_class = 1 @@ -1018,7 +1027,7 @@ subroutine fuse_patches( csite ) !--------------------------------------------------------------------- !maxpatch = 4 - maxpatch = maxPatchesPerCol + maxpatch = maxPatchesPerSite currentSite => csite @@ -1058,7 +1067,7 @@ subroutine fuse_patches( csite ) do while(associated(tpp)) if(.not.associated(currentPatch))then - write(iulog,*) 'ED: issue with currentPatch' + write(fates_log(),*) 'ED: issue with currentPatch' endif if(associated(tpp).and.associated(currentPatch))then @@ -1100,7 +1109,7 @@ subroutine fuse_patches( csite ) call sort_cohorts(tpp) currentPatch => tmpptr else - ! write(iulog,*) 'patches not fused' + ! write(fates_log(),*) 'patches not fused' endif endif !are both patches associated? endif !are these different patches? @@ -1336,15 +1345,17 @@ subroutine terminate_patches(cs_pnt) ! Do not force the fusion of the youngest patch to its neighbour. ! This is only really meant for very old patches. if(associated(currentPatch%older) )then - write(iulog,*) 'fusing to older patch because this one is too small',currentPatch%area, currentPatch%lai, & + write(fates_log(),*) 'fusing to older patch because this one is too small',& + currentPatch%area, currentPatch%lai, & currentPatch%older%area,currentPatch%older%lai call fuse_2_patches(currentPatch%older, currentPatch) - write(iulog,*) 'after fusion to older patch',currentPatch%area + write(fates_log(),*) 'after fusion to older patch',currentPatch%area else - write(iulog,*) 'fusing to younger patch because oldest one is too small',currentPatch%area, currentPatch%lai + write(fates_log(),*) 'fusing to younger patch because oldest one is too small',& + currentPatch%area, currentPatch%lai tmpptr => currentPatch%younger call fuse_2_patches(currentPatch, currentPatch%younger) - write(iulog,*) 'after fusion to younger patch' + write(fates_log(),*) 'after fusion to younger patch' currentPatch => tmpptr endif endif @@ -1361,7 +1372,7 @@ subroutine terminate_patches(cs_pnt) areatot = areatot + currentPatch%area currentPatch => currentPatch%younger if((areatot-area) > 0.0000001_r8)then - write(iulog,*) 'ED: areatot too large. end terminate', areatot + write(fates_log(),*) 'ED: areatot too large. end terminate', areatot endif enddo @@ -1457,7 +1468,8 @@ subroutine patch_pft_size_profile(cp_pnt) do j = 1,N_DBH_BINS if((currentCohort%dbh > mind(j)) .AND. (currentCohort%dbh <= maxd(j)))then - currentPatch%pft_agb_profile(currentCohort%pft,j) = currentPatch%pft_agb_profile(currentCohort%pft,j) + & + currentPatch%pft_agb_profile(currentCohort%pft,j) = & + currentPatch%pft_agb_profile(currentCohort%pft,j) + & currentCohort%bdead*currentCohort%n/currentPatch%area endif @@ -1469,7 +1481,7 @@ subroutine patch_pft_size_profile(cp_pnt) end subroutine patch_pft_size_profile - ! ============================================================================ + ! ===================================================================================== function countPatches( bounds, nsites, sites ) result ( totNumPatches ) ! ! !DESCRIPTION: @@ -1477,7 +1489,6 @@ function countPatches( bounds, nsites, sites ) result ( totNumPatches ) ! ! !USES: use decompMod , only : bounds_type - use abortutils , only : endrun use EDTypesMod , only : ed_site_type ! ! !ARGUMENTS: @@ -1503,4 +1514,39 @@ function countPatches( bounds, nsites, sites ) result ( totNumPatches ) end function countPatches + ! ==================================================================================== + + subroutine set_root_fraction( cpatch , depth_gl ) + ! + ! !DESCRIPTION: + ! Calculates the fractions of the root biomass in each layer for each pft. + ! + ! !USES: + use pftconMod , only : pftcon + ! + ! !ARGUMENTS + type(ed_patch_type),intent(inout), target :: cpatch + real(r8),intent(in) :: depth_gl(0:hlm_numlevgrnd) + ! + ! !LOCAL VARIABLES: + integer :: lev,p,c,ft + !---------------------------------------------------------------------- + + do ft = 1,numpft_ed + do lev = 1, hlm_numlevgrnd + cpatch%rootfr_ft(ft,lev) = 0._r8 + enddo + + do lev = 1, hlm_numlevsoil-1 + cpatch%rootfr_ft(ft,lev) = .5_r8*( & + exp(-pftcon%roota_par(ft) * depth_gl(lev-1)) & + + exp(-pftcon%rootb_par(ft) * depth_gl(lev-1)) & + - exp(-pftcon%roota_par(ft) * depth_gl(lev)) & + - exp(-pftcon%rootb_par(ft) * depth_gl(lev))) + end do + end do + + end subroutine set_root_fraction + + end module EDPatchDynamicsMod diff --git a/components/clm/src/ED/biogeochem/EDPhysiologyMod.F90 b/components/clm/src/ED/biogeochem/EDPhysiologyMod.F90 index 430da23a4b..2d78b27817 100755 --- a/components/clm/src/ED/biogeochem/EDPhysiologyMod.F90 +++ b/components/clm/src/ED/biogeochem/EDPhysiologyMod.F90 @@ -7,24 +7,28 @@ module EDPhysiologyMod ! ============================================================================ use FatesGlobals, only : fates_log - use FatesGlobals, only : days_per_year - use FatesGlobals, only : model_day - use FatesGlobals, only : freq_day - use FatesGlobals, only : day_of_year + use FatesInterfaceMod, only : hlm_days_per_year + use FatesInterfaceMod, only : hlm_model_day + use FatesInterfaceMod, only : hlm_freq_day + use FatesInterfaceMod, only : hlm_day_of_year use FatesConstantsMod, only : r8 => fates_r8 - use pftconMod , only : pftcon - use EDEcophysContype , only : EDecophyscon + use pftconMod , only : pftcon + use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod, only : bc_in_type use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts - use EDTypesMod , only : dg_sf, dinc_ed, external_recruitment - use EDTypesMod , only : ncwd, cp_nlevcan, numpft_ed, senes + use EDTypesMod , only : numWaterMem + use EDTypesMod , only : dg_sf, dinc_ed + use EDTypesMod , only : external_recruitment + use EDTypesMod , only : ncwd + use EDTypesMod , only : nlevcan + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : senes use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use shr_log_mod , only : errMsg => shr_log_errMsg - use abortutils , only : endrun use FatesGlobals , only : fates_log - + use FatesGlobals , only : endrun => fates_endrun implicit none @@ -179,13 +183,13 @@ subroutine trim_canopy( currentSite ) trimmed = 0 currentCohort%treelai = tree_lai(currentCohort) currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) - if (currentCohort%nv > cp_nlevcan)then - write(fates_log(),*) 'nv > cp_nlevcan',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & + if (currentCohort%nv > nlevcan)then + write(fates_log(),*) 'nv > nlevcan',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & currentCohort%c_area,currentCohort%n,currentCohort%bl endif !Leaf cost vs netuptake for each leaf layer. - do z = 1,cp_nlevcan + do z = 1,nlevcan if (currentCohort%year_net_uptake(z) /= 999._r8)then !there was activity this year in this leaf layer. !Leaf Cost kgC/m2/year-1 !decidous costs. @@ -299,7 +303,7 @@ subroutine phenology( currentSite, bc_in ) ncolddayslim = 5 cold_t = 7.5_r8 ! ed_ph_coldtemp - t = day_of_year + t = hlm_day_of_year temp_in_C = bc_in%t_veg24_si - tfrz !-----------------Cold Phenology--------------------! @@ -349,7 +353,7 @@ subroutine phenology( currentSite, bc_in ) endif - timesinceleafoff = model_day - currentSite%leafoffdate + timesinceleafoff = hlm_model_day - currentSite%leafoffdate !LEAF ON: COLD DECIDUOUS. Needs to !1) have exceeded the growing degree day threshold !2) The leaves should not be on already @@ -365,7 +369,7 @@ subroutine phenology( currentSite, bc_in ) endif !status endif !GDD - timesinceleafon = model_day - currentSite%leafondate + timesinceleafon = hlm_model_day - currentSite%leafondate !LEAF OFF: COLD THRESHOLD @@ -379,7 +383,7 @@ subroutine phenology( currentSite, bc_in ) if (timesinceleafon > mindayson)then if (currentSite%status == 2)then currentSite%status = 1 !alter status of site to 'leaves on' - currentSite%leafoffdate = model_day !record leaf off date + currentSite%leafoffdate = hlm_model_day !record leaf off date if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif @@ -389,7 +393,7 @@ subroutine phenology( currentSite, bc_in ) if(timesinceleafoff > 400)then !remove leaves after a whole year when there is no 'off' period. if(currentSite%status == 2)then currentSite%status = 1 !alter status of site to 'leaves on' - currentSite%leafoffdate = model_day !record leaf off date + currentSite%leafoffdate = hlm_model_day !record leaf off date if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif @@ -422,10 +426,11 @@ subroutine phenology( currentSite, bc_in ) ! distinction actually matter??).... !Accumulate surface water memory of last 10 days. - currentSite%water_memory(1) = bc_in%h2osoi_vol_si !waterstate_inst%h2osoi_vol_col(coli,1) - do i = 1,9 !shift memory along one - currentSite%water_memory(11-i) = currentSite%water_memory(10-i) + + do i = 1,numWaterMem-1 !shift memory along one + currentSite%water_memory(numWaterMem+1-i) = currentSite%water_memory(numWaterMem-i) enddo + currentSite%water_memory(1) = bc_in%h2osoi_vol_si !waterstate_inst%h2osoi_vol_col(coli,1) !In drought phenology, we often need to force the leaves to stay on or off as moisture fluctuates... timesincedleafoff = 0 @@ -453,7 +458,9 @@ subroutine phenology( currentSite, bc_in ) !Here, we used a window of oppurtunity to determine if we are close to the time when then leaves came on last year if ((t >= currentSite%dleafondate - 30.and.t <= currentSite%dleafondate + 30).or.(t > 360 - 15.and. & currentSite%dleafondate < 15))then ! are we in the window? - if (sum(currentSite%water_memory(1:10)/10._r8) >= drought_threshold.and.currentSite%dstatus == 1.and.t >= 10)then + ! TODO: CHANGE THIS MATH, MOVE THE DENOMENATOR OUTSIDE OF THE SUM (rgk 01-2017) + if (sum(currentSite%water_memory(1:numWaterMem)/dble(numWaterMem)) & + >= drought_threshold.and.currentSite%dstatus == 1.and.t >= 10)then ! leave some minimum time between leaf off and leaf on to prevent 'flickering'. if (timesincedleafoff > off_time)then currentSite%dstatus = 2 !alter status of site to 'leaves on' @@ -645,7 +652,7 @@ subroutine seeds_in( currentSite, cp_pnt ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - if (EXTERNAL_RECRUITMENT == 1) then !external seed rain - needed to prevent extinction + if (external_recruitment == 1) then !external seed rain - needed to prevent extinction do p = 1,numpft_ed currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + & EDecophyscon%seed_rain(p) !KgC/m2/year @@ -774,9 +781,9 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! convert from kgC/indiv/day into kgC/indiv/year ! TODO: CONVERT DAYS_PER_YEAR TO DBLE (HOLDING FOR B4B COMPARISONS, RGK-01-2017) - currentCohort%npp_acc_hold = currentCohort%npp_acc * days_per_year - currentCohort%gpp_acc_hold = currentCohort%gpp_acc * days_per_year - currentCohort%resp_acc_hold = currentCohort%resp_acc * days_per_year + currentCohort%npp_acc_hold = currentCohort%npp_acc * hlm_days_per_year + currentCohort%gpp_acc_hold = currentCohort%gpp_acc * hlm_days_per_year + currentCohort%resp_acc_hold = currentCohort%resp_acc * hlm_days_per_year currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n @@ -948,7 +955,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! prevent negative leaf pool (but not negative store pool). This is also a numerical error prevention, ! but it shouldn't happen actually... - if (-1.0_r8*currentCohort%dbalivedt * freq_day > currentCohort%balive*0.99)then + if (-1.0_r8*currentCohort%dbalivedt * hlm_freq_day > currentCohort%balive*0.99)then write(fates_log(),*) 'using non-neg leaf mass cap',currentCohort%balive , currentCohort%dbalivedt,currentCohort%dbstoredt, & currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%dbstoredt + currentCohort%dbalivedt @@ -1003,7 +1010,7 @@ subroutine recruitment( t, currentSite, currentPatch ) + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite) temp_cohort%bstore = EDecophyscon%cushion(ft)*(temp_cohort%balive/ (1.0_r8 + pftcon%froot_leaf(ft) & + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite)) - temp_cohort%n = currentPatch%area * currentPatch%seed_germination(ft)*freq_day & + temp_cohort%n = currentPatch%area * currentPatch%seed_germination(ft)*hlm_freq_day & / (temp_cohort%bdead+temp_cohort%balive+temp_cohort%bstore) if (t == 1)then @@ -1080,7 +1087,7 @@ subroutine CWD_Input( currentPatch) currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & currentCohort%root_md * currentCohort%n/currentPatch%area !turnover currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & - currentCohort%leaf_litter * currentCohort%n/currentPatch%area/freq_day + currentCohort%leaf_litter * currentCohort%n/currentPatch%area/hlm_freq_day !daily leaf loss needs to be scaled up to the annual scale here. @@ -1099,7 +1106,7 @@ subroutine CWD_Input( currentPatch) dead_n = -1.0_r8 * currentCohort%dndt / currentPatch%area currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & - (currentCohort%bl+currentCohort%leaf_litter/freq_day)* dead_n + (currentCohort%bl+currentCohort%leaf_litter/hlm_freq_day)* dead_n currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & (currentCohort%br+currentCohort%bstore) * dead_n @@ -1252,13 +1259,13 @@ subroutine cwd_out( currentSite, currentPatch, bc_in ) !add up carbon going into fragmenting pools currentSite%flux_out = currentSite%flux_out + sum(currentPatch%leaf_litter_out) * & - currentPatch%area *freq_day!kgC/site/day + currentPatch%area *hlm_freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%root_litter_out) * & - currentPatch%area *freq_day!kgC/site/day + currentPatch%area *hlm_freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_ag_out) * & - currentPatch%area *freq_day!kgC/site/day + currentPatch%area *hlm_freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_bg_out) * & - currentPatch%area *freq_day!kgC/site/day + currentPatch%area *hlm_freq_day!kgC/site/day end subroutine cwd_out @@ -1281,18 +1288,19 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. - use EDTypesMod, only : AREA, numpft_ed, cp_numlevdecomp_full, cp_numlevdecomp + use EDTypesMod, only : AREA + use EDTypesMod, only : numpft_ed + use FatesInterfaceMod, only : hlm_numlevdecomp_full + use FatesInterfaceMod, only : hlm_numlevdecomp use SoilBiogeochemVerticalProfileMod, only: surfprof_exp - - !use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig - use pftconMod, only : pftcon use FatesConstantsMod, only : sec_per_day use clm_varcon, only : zisoi, dzsoi_decomp, zsoi use EDParamsMod, only : ED_val_ag_biomass use FatesInterfaceMod, only : bc_in_type, bc_out_type use clm_varctl, only : use_vertsoilc - use abortutils , only : endrun + use FatesGlobals, only : endrun => fates_endrun + ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, ! pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi @@ -1315,9 +1323,9 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) integer :: begp,endp integer :: begc,endc !bounds !------------------------------------------------------------------------ - real(r8) :: cinput_rootfr(1:numpft_ed, 1:cp_numlevdecomp_full) ! column by pft root fraction used for calculating inputs - real(r8) :: croot_prof_perpatch(1:cp_numlevdecomp_full) - real(r8) :: surface_prof(1:cp_numlevdecomp_full) + real(r8) :: cinput_rootfr(1:numpft_ed, 1:hlm_numlevdecomp_full) ! column by pft root fraction used for calculating inputs + real(r8) :: croot_prof_perpatch(1:hlm_numlevdecomp_full) + real(r8) :: surface_prof(1:hlm_numlevdecomp_full) integer :: ft real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot @@ -1341,10 +1349,10 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! Doing so will be answer changing though so perhaps easiest to do this in steps. integer, parameter :: rooting_profile_varindex_water = 1 - real(r8) :: leaf_prof(1:nsites, 1:cp_numlevdecomp) - real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:cp_numlevdecomp) - real(r8) :: croot_prof(1:nsites, 1:cp_numlevdecomp) - real(r8) :: stem_prof(1:nsites, 1:cp_numlevdecomp) + real(r8) :: leaf_prof(1:nsites, 1:hlm_numlevdecomp) + real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:hlm_numlevdecomp) + real(r8) :: croot_prof(1:nsites, 1:hlm_numlevdecomp) + real(r8) :: stem_prof(1:nsites, 1:hlm_numlevdecomp) ! INTERF-TODO: THESE PARAMETERS WERE ORIGINALLY SET BY params_inst% ! THEY NEED THEIR OWN ENTRIES IN THE PARAMETER FILE (RGK) @@ -1374,7 +1382,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) surface_prof(:) = 0._r8 - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp surface_prof(j) = exp(-surfprof_exp * zsoi(j)) / dzsoi_decomp(j) end do @@ -1391,14 +1399,14 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) if ( .not. pftspecific_rootingprofile ) then ! define rooting profile from exponential parameters do ft = 1, numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp cinput_rootfr(ft,j) = exp(-rootprof_exp * zsoi(j)) / dzsoi_decomp(j) end do end do else ! use beta distribution parameter from Jackson et al., 1996 do ft = 1, numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp cinput_rootfr(ft,j) = ( pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j-1)*100._r8) - & pftcon%rootprof_beta(ft, rooting_profile_varindex_water) ** (zisoi(j)*100._r8) ) & / dzsoi_decomp(j) @@ -1407,7 +1415,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) endif else do ft = 1,numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp ! use standard CLM root fraction profiles; cinput_rootfr(ft,j) = ( .5_r8*( & exp(-pftcon%roota_par(ft) * zisoi(j-1)) & @@ -1428,11 +1436,11 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do surface_prof_tot = 0._r8 ! - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) surface_prof_tot = surface_prof_tot + surface_prof(j) * dzsoi_decomp(j) end do do ft = 1,numpft_ed - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(ft,j) * dzsoi_decomp(j) end do end do @@ -1442,7 +1450,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (rootfr_tot(ft) > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) froot_prof(s,ft,j) = cinput_rootfr(ft,j) / rootfr_tot(ft) end do else @@ -1455,7 +1463,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (surface_prof_tot > 0._r8) ) then ! where there is not permafrost extending to the surface, integrate the profiles over the active layer ! this is equivalent to integrating over all soil layers outside of permafrost regions - do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), cp_numlevdecomp) + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) ! set all surface processes to shallower profile leaf_prof(s,j) = surface_prof(j)/ surface_prof_tot stem_prof(s,j) = surface_prof(j)/ surface_prof_tot @@ -1464,7 +1472,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! if fully frozen, or no roots, put everything in the top layer leaf_prof(s,1) = 1._r8/dzsoi_decomp(1) stem_prof(s,1) = 1._r8/dzsoi_decomp(1) - do j = 2, cp_numlevdecomp + do j = 2, hlm_numlevdecomp leaf_prof(s,j) = 0._r8 stem_prof(s,j) = 0._r8 end do @@ -1485,7 +1493,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! check the leaf and stem profiles leaf_prof_sum = 0._r8 stem_prof_sum = 0._r8 - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp leaf_prof_sum = leaf_prof_sum + leaf_prof(s,j) * dzsoi_decomp(j) stem_prof_sum = stem_prof_sum + stem_prof(s,j) * dzsoi_decomp(j) end do @@ -1497,24 +1505,24 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) write(fates_log(), *) 'stem_prof: ', stem_prof(s,:) write(fates_log(), *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col write(fates_log(), *) 'dzsoi_decomp: ', dzsoi_decomp - call endrun() + call endrun(msg=errMsg(sourcefile, __LINE__)) endif ! now check each fine root profile do ft = 1,numpft_ed froot_prof_sum = 0._r8 - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp froot_prof_sum = froot_prof_sum + froot_prof(s,ft,j) * dzsoi_decomp(j) end do if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then write(fates_log(), *) 'profile sums: ', froot_prof_sum - call endrun() + call endrun(msg=errMsg(sourcefile, __LINE__)) endif end do end do ! zero the site-level C input variables do s = 1, nsites - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp bc_out(s)%FATES_c_to_litr_lab_c_col(j) = 0._r8 bc_out(s)%FATES_c_to_litr_cel_c_col(j) = 0._r8 bc_out(s)%FATES_c_to_litr_lig_c_col(j) = 0._r8 @@ -1550,14 +1558,14 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) end do ! - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp ! zero this for each patch croot_prof_perpatch(j) = 0._r8 end do ! if ( biomass_bg_tot .gt. 0._r8) then do ft = 1,numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(s,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot end do end do @@ -1567,7 +1575,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp croot_prof(s, j) = croot_prof(s, j) + croot_prof_perpatch(j) * currentPatch%area / AREA end do ! @@ -1584,7 +1592,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! ! ! CWD pools fragmenting into decomposing litter pools. do ci = 1, ncwd - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & currentpatch%CWD_AG_out(ci) * cwd_fcel * currentpatch%area/AREA * stem_prof(s,j) bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & @@ -1599,7 +1607,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! leaf and fine root pools. do ft = 1,numpft_ed - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & currentpatch%leaf_litter_out(ft) * pftcon%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & @@ -1631,19 +1639,18 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do ! do sites(s) do s = 1, nsites - do j = 1, cp_numlevdecomp + do j = 1, hlm_numlevdecomp ! time unit conversion bc_out(s)%FATES_c_to_litr_lab_c_col(j)=bc_out(s)%FATES_c_to_litr_lab_c_col(j) * mass_convert / time_convert bc_out(s)%FATES_c_to_litr_cel_c_col(j)=bc_out(s)%FATES_c_to_litr_cel_c_col(j) * mass_convert / time_convert bc_out(s)%FATES_c_to_litr_lig_c_col(j)=bc_out(s)%FATES_c_to_litr_lig_c_col(j) * mass_convert / time_convert - end do end do ! write(fates_log(),*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c ! write_col(fates_log(),*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c ! write_col(fates_log(),*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c - ! write_col(fates_log(),*)'cdk cp_numlevdecomp_full, bounds%begc, bounds%endc: ', cp_numlevdecomp_full, bounds%begc, bounds%endc + ! write_col(fates_log(),*)'cdk hlm_numlevdecomp_full, bounds%begc, bounds%endc: ', hlm_numlevdecomp_full, bounds%begc, bounds%endc ! write(fates_log(),*)'cdk leaf_prof: ', leaf_prof ! write(fates_log(),*)'cdk stem_prof: ', stem_prof ! write(fates_log(),*)'cdk froot_prof: ', froot_prof diff --git a/components/clm/src/ED/biogeochem/EDSharedParamsMod.F90 b/components/clm/src/ED/biogeochem/EDSharedParamsMod.F90 index c4111c124f..d6d7d7cb40 100644 --- a/components/clm/src/ED/biogeochem/EDSharedParamsMod.F90 +++ b/components/clm/src/ED/biogeochem/EDSharedParamsMod.F90 @@ -28,7 +28,7 @@ module EDSharedParamsMod subroutine EDParamsReadShared(ncid) ! use ncdio_pio , only : file_desc_t,ncd_io - use abortutils , only : endrun + use FatesGlobals, only : endrun => fates_endrun use shr_log_mod , only : errMsg => shr_log_errMsg ! type(file_desc_t),intent(inout) :: ncid ! pio netCDF file id diff --git a/components/clm/src/ED/biogeophys/EDAccumulateFluxesMod.F90 b/components/clm/src/ED/biogeophys/EDAccumulateFluxesMod.F90 index bd2437c92f..f782a21979 100644 --- a/components/clm/src/ED/biogeophys/EDAccumulateFluxesMod.F90 +++ b/components/clm/src/ED/biogeophys/EDAccumulateFluxesMod.F90 @@ -9,8 +9,10 @@ module EDAccumulateFluxesMod ! Rosie Fisher. March 2014. ! ! !USES: - use abortutils, only : endrun + use FatesGlobals, only : fates_endrun + use FatesGlobals, only : fates_log use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesConstantsMod , only : r8 => fates_r8 implicit none private ! @@ -32,12 +34,10 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! see above ! ! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceMod , only : bc_in_type,bc_out_type - use, intrinsic :: IEEE_ARITHMETIC ! ! !ARGUMENTS @@ -73,9 +73,11 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day if ( DEBUG ) then - write(iulog,*) 'EDAccumFlux 64 ',ccohort%npp_tstep - write(iulog,*) 'EDAccumFlux 66 ',ccohort%gpp_tstep - write(iulog,*) 'EDAccumFlux 67 ',ccohort%resp_tstep + + write(fates_log(),*) 'EDAccumFlux 64 ',ccohort%npp_tstep + write(fates_log(),*) 'EDAccumFlux 66 ',ccohort%gpp_tstep + write(fates_log(),*) 'EDAccumFlux 67 ',ccohort%resp_tstep + endif ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep diff --git a/components/clm/src/ED/biogeophys/EDBtranMod.F90 b/components/clm/src/ED/biogeophys/EDBtranMod.F90 index 8283a4d52d..d44da0d1c8 100644 --- a/components/clm/src/ED/biogeophys/EDBtranMod.F90 +++ b/components/clm/src/ED/biogeophys/EDBtranMod.F90 @@ -6,16 +6,16 @@ module EDBtranMod ! ------------------------------------------------------------------------------------ use pftconMod , only : pftcon - use clm_varcon , only : tfrz + use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm use EDTypesMod , only : ed_site_type, & ed_patch_type, & ed_cohort_type, & - numpft_ed, & - cp_numlevgrnd + numpft_ed + use FatesInterfaceMod , only : hlm_numlevgrnd use shr_kind_mod , only : r8 => shr_kind_r8 use FatesInterfaceMod , only : bc_in_type, & bc_out_type - use clm_varctl , only : iulog !INTERF-TODO: THIS SHOULD BE MOVED + use FatesGlobals , only : fates_log ! implicit none @@ -63,7 +63,7 @@ subroutine get_active_suction_layers(nsites, sites, bc_in, bc_out) do s = 1,nsites if (bc_in(s)%filter_btran) then - do j = 1,cp_numlevgrnd + do j = 1,hlm_numlevgrnd bc_out(s)%active_suction_gl(j) = check_layer_water( bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) end do else @@ -128,7 +128,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) do ft = 1,numpft_ed cpatch%btran_ft(ft) = 0.0_r8 - do j = 1,cp_numlevgrnd + do j = 1,hlm_numlevgrnd ! Calculations are only relevant where liquid water exists ! see clm_fates%wrap_btran for calculation with CLM/ALM @@ -155,7 +155,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) end do !j ! Normalize root resistances to get layer contribution to ET - do j = 1,cp_numlevgrnd + do j = 1,hlm_numlevgrnd if (cpatch%btran_ft(ft) > 0.0_r8) then cpatch%rootr_ft(ft,j) = cpatch%rootr_ft(ft,j)/cpatch%btran_ft(ft) else @@ -179,7 +179,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) ! pass the host a total transpiration for the patch. This needs rootr to be ! distributed over the soil layers. - do j = 1,cp_numlevgrnd + do j = 1,hlm_numlevgrnd bc_out(s)%rootr_pagl(ifp,j) = 0._r8 do ft = 1,numpft_ed if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail @@ -206,9 +206,10 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) ! While the in-pft root profiles summed to unity, averaging them weighted ! by conductance, or not, will break sum to unity. Thus, re-normalize. - temprootr = sum(bc_out(s)%rootr_pagl(ifp,1:cp_numlevgrnd)) + temprootr = sum(bc_out(s)%rootr_pagl(ifp,1:hlm_numlevgrnd)) if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then - do j = 1,cp_numlevgrnd + write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs) + do j = 1,hlm_numlevgrnd bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr enddo end if @@ -301,7 +302,7 @@ end subroutine btran_ed ! weighted_swp = weighted_swp/totestevap ! ! weight SWP for the total evaporation ! else -! write(iulog,*) 'empty soil', totestevap +! write(fates_log(),*) 'empty soil', totestevap ! ! error check ! weighted_swp = minlwp ! end if diff --git a/components/clm/src/ED/biogeophys/EDSurfaceAlbedoMod.F90 b/components/clm/src/ED/biogeophys/EDSurfaceAlbedoMod.F90 index d76695916c..130b093da0 100644 --- a/components/clm/src/ED/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/components/clm/src/ED/biogeophys/EDSurfaceAlbedoMod.F90 @@ -10,19 +10,23 @@ module EDSurfaceRadiationMod #include "shr_assert.h" - use EDtypesMod , only : ed_patch_type, ed_site_type - use EDtypesMod , only : numpft_ed - use EDtypesMod , only : maxPatchesPerCol - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - use FatesInterfaceMod , only : bc_in_type, & - bc_out_type - use EDTypesMod , only : cp_numSWb, & ! Actual number of SW radiation bands - cp_maxSWb, & ! maximum number of SW bands (for scratch) - cp_nclmax ! control parameter, number of SW bands + use EDTypesMod , only : ed_patch_type, ed_site_type + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : maxPatchesPerSite + use FatesConstantsMod , only : r8 => fates_r8 + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + use FatesInterfaceMod , only : hlm_numSWb + use EDTypesMod , only : maxSWb + use EDTypesMod , only : nclmax + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : nlevcan use EDCanopyStructureMod, only: calc_areaindex - + use FatesGlobals , only : fates_log + ! CIME globals + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private @@ -30,8 +34,9 @@ module EDSurfaceRadiationMod public :: ED_SunShadeFracs logical :: DEBUG = .false. ! for debugging this module + - real(r8), public :: albice(cp_maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) ! INTERF-TODO: THIS NEEDS SOME CONSISTENCY AND SHOULD BE SET IN THE INTERFACE @@ -45,9 +50,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! ! !USES: - use clm_varctl , only : iulog use pftconMod , only : pftcon - use EDtypesMod , only : ed_patch_type, numpft_ed, cp_nlevcan + use EDtypesMod , only : ed_patch_type use EDTypesMod , only : ed_site_type @@ -70,31 +74,31 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) real(r8) :: sb real(r8) :: error ! Error check real(r8) :: down_rad, up_rad ! Iterative solution do Dif_dn and Dif_up - real(r8) :: ftweight(cp_nclmax,numpft_ed,cp_nlevcan) + real(r8) :: ftweight(nclmax,numpft_ed,nlevcan) real(r8) :: k_dir(numpft_ed) ! Direct beam extinction coefficient - real(r8) :: tr_dir_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of direct beam radiation through a single layer - real(r8) :: tr_dif_z(cp_nclmax,numpft_ed,cp_nlevcan) ! Exponential transmittance of diffuse radiation through a single layer - real(r8) :: forc_dir(maxPatchesPerCol,cp_maxSWb) - real(r8) :: forc_dif(maxPatchesPerCol,cp_maxSWb) - real(r8) :: weighted_dir_tr(cp_nclmax) - real(r8) :: weighted_fsun(cp_nclmax) - real(r8) :: weighted_dif_ratio(cp_nclmax,cp_maxSWb) - real(r8) :: weighted_dif_down(cp_nclmax) - real(r8) :: weighted_dif_up(cp_nclmax) - real(r8) :: refl_dif(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Term for diffuse radiation reflected by laye - real(r8) :: tran_dif(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Term for diffuse radiation transmitted by layer - real(r8) :: dif_ratio(cp_nclmax,numpft_ed,cp_nlevcan,cp_maxSWb) ! Ratio of upward to forward diffuse fluxes - real(r8) :: Dif_dn(cp_nclmax,numpft_ed,cp_nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - real(r8) :: Dif_up(cp_nclmax,numpft_ed,cp_nlevcan) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) - real(r8) :: lai_change(cp_nclmax,numpft_ed,cp_nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - real(r8) :: f_not_abs(numpft_ed,cp_maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. - real(r8) :: Abs_dir_z(numpft_ed,cp_nlevcan) - real(r8) :: Abs_dif_z(numpft_ed,cp_nlevcan) - real(r8) :: abs_rad(cp_maxSWb) !radiation absorbed by soil + real(r8) :: tr_dir_z(nclmax,numpft_ed,nlevcan) ! Exponential transmittance of direct beam radiation through a single layer + real(r8) :: tr_dif_z(nclmax,numpft_ed,nlevcan) ! Exponential transmittance of diffuse radiation through a single layer + real(r8) :: forc_dir(maxPatchesPerSite,maxSWb) + real(r8) :: forc_dif(maxPatchesPerSite,maxSWb) + real(r8) :: weighted_dir_tr(nclmax) + real(r8) :: weighted_fsun(nclmax) + real(r8) :: weighted_dif_ratio(nclmax,maxSWb) + real(r8) :: weighted_dif_down(nclmax) + real(r8) :: weighted_dif_up(nclmax) + real(r8) :: refl_dif(nclmax,numpft_ed,nlevcan,maxSWb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(nclmax,numpft_ed,nlevcan,maxSWb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(nclmax,numpft_ed,nlevcan,maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: Dif_dn(nclmax,numpft_ed,nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: Dif_up(nclmax,numpft_ed,nlevcan) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) + real(r8) :: lai_change(nclmax,numpft_ed,nlevcan) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: f_not_abs(numpft_ed,maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. + real(r8) :: Abs_dir_z(numpft_ed,nlevcan) + real(r8) :: Abs_dif_z(numpft_ed,nlevcan) + real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil real(r8) :: tr_soili ! Radiation transmitted to the soil surface. real(r8) :: tr_soild ! Radiation transmitted to the soil surface. - real(r8) :: phi1b(maxPatchesPerCol,numpft_ed) ! Radiation transmitted to the soil surface. - real(r8) :: phi2b(maxPatchesPerCol,numpft_ed) + real(r8) :: phi1b(maxPatchesPerSite,numpft_ed) ! Radiation transmitted to the soil surface. + real(r8) :: phi2b(maxPatchesPerSite,numpft_ed) real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) real(r8) :: angle @@ -107,8 +111,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) integer :: fp,iv,s ! array indices integer :: ib ! waveband number real(r8) :: cosz ! 0.001 <= coszen <= 1.000 - real(r8) :: chil(maxPatchesPerCol) ! -0.4 <= xl <= 0.6 - real(r8) :: gdir(maxPatchesPerCol) ! leaf projection in solar direction (0 to 1) + real(r8) :: chil(maxPatchesPerSite) ! -0.4 <= xl <= 0.6 + real(r8) :: gdir(maxPatchesPerSite) ! leaf projection in solar direction (0 to 1) !----------------------------------------------------------------------- @@ -177,7 +181,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - do ib = 1,cp_numSWb + do ib = 1,hlm_numSWb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 @@ -187,7 +191,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) else ! Is this pft/canopy layer combination present in this patch? - do L = 1,cp_nclmax + do L = 1,nclmax do ft = 1,numpft_ed currentPatch%present(L,ft) = 0 do iv = 1, currentPatch%nrad(L,ft) @@ -200,7 +204,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) end do !L do radtype = 1,2 !do this once for one unit of diffuse, and once for one unit of direct radiation - do ib = 1,cp_numSWb + do ib = 1,hlm_numSWb if (radtype == 1) then ! Set the hypothetical driving radiation. We do this once for a single unit of direct and ! once for a single unit of diffuse radiation. @@ -223,10 +227,10 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) end do !ft1 end do !L if (sum(ftweight(1,:,1))<0.999_r8)then - write(iulog,*) 'canopy not full',ftweight(1,:,1) + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) endif if (sum(ftweight(1,:,1))>1.0001_r8)then - write(iulog,*) 'canopy too full',ftweight(1,:,1) + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) endif !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! @@ -249,7 +253,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) weighted_dir_tr(L) = 0.0_r8 weighted_fsun(L) = 0._r8 - weighted_dif_ratio(L,1:cp_numSWb) = 0._r8 + weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's do ft =1,numpft_ed if (currentPatch%present(L,ft) == 1)then !only do calculation if there are the appropriate leaves. @@ -292,7 +296,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) endif if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then - write(iulog,*) 'lower layer has more coverage. This is wrong' , & + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) endif @@ -389,7 +393,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! Iterative solution do scattering !==============================================================================! - do ib = 1,cp_numSWb !vis, nir + do ib = 1,hlm_numSWb !vis, nir !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! ! Leaf scattering coefficient and terms do diffuse radiation reflected ! and transmitted by a layer @@ -431,12 +435,12 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) !instance where the first layer ftweight is used a proxy for the whole column. FTWA - end do!cp_numSWb + end do!hlm_numSWb endif ! currentPatch%present end do!ft end do!L - do ib = 1,cp_numSWb + do ib = 1,hlm_numSWb Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 do L = 1, currentPatch%NCL_p !work down from the top of the canopy. @@ -692,8 +696,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) do iv = 1, currentPatch%nrad(L,ft) if (radtype==1) then if ( DEBUG ) then - write(iulog,*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(iulog,*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & currentPatch%fabd_sun_z(L,ft,iv) endif currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & @@ -708,7 +712,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) currentPatch%f_sun(L,ft,iv) endif if ( DEBUG ) then - write(iulog,*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & currentPatch%fabd_sun_z(L,ft,iv) endif end do @@ -786,22 +790,22 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) (1.0_r8-bc_in(s)%albgr_dir_rb(ib)) + & currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) if ( abs(error) > 0.0001)then - write(iulog,*)'dir ground absorption error',ifp,s,error,currentPatch%sabs_dir(ib), & + write(fates_log(),*)'dir ground absorption error',ifp,s,error,currentPatch%sabs_dir(ib), & currentPatch%tr_soil_dir(ib)* & (1.0_r8-bc_in(s)%albgr_dir_rb(ib)),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) - write(iulog,*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & (1.0_r8-bc_in(s)%albgr_dir_rb(ib)),currentPatch%lai do ft =1,3 iv = currentPatch%nrad(1,ft) + 1 - write(iulog,*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) end do end if else if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & (1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) > 0.0001)then - write(iulog,*)'dif ground absorption error',ifp,s,currentPatch%sabs_dif(ib) , & + write(fates_log(),*)'dif ground absorption error',ifp,s,currentPatch%sabs_dif(ib) , & (currentPatch%tr_soil_dif(ib)* & (1.0_r8-bc_in(s)%albgr_dif_rb(ib))),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) endif @@ -827,22 +831,22 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) enddo enddo if (lai_change(1,2,1).gt.0.0.and.lai_change(1,2,2).gt.0.0)then - ! write(iulog,*) 'lai_change(1,2,12)',lai_change(1,2,1:4) + ! write(fates_log(),*) 'lai_change(1,2,12)',lai_change(1,2,1:4) endif if (lai_change(1,2,2).gt.0.0.and.lai_change(1,2,3).gt.0.0)then - ! write(iulog,*) ' lai_change (1,2,23)',lai_change(1,2,1:4) + ! write(fates_log(),*) ' lai_change (1,2,23)',lai_change(1,2,1:4) endif if (lai_change(1,1,3).gt.0.0.and.lai_change(1,1,2).gt.0.0)then ! NO-OP - ! write(iulog,*) 'first layer of lai_change 2 3',lai_change(1,1,1:3) + ! write(fates_log(),*) 'first layer of lai_change 2 3',lai_change(1,1,1:3) endif if (lai_change(1,1,3).gt.0.0.and.lai_change(1,1,4).gt.0.0)then ! NO-OP - ! write(iulog,*) 'first layer of lai_change 3 4',lai_change(1,1,1:4) + ! write(fates_log(),*) 'first layer of lai_change 3 4',lai_change(1,1,1:4) endif if (lai_change(1,1,4).gt.0.0.and.lai_change(1,1,5).gt.0.0)then ! NO-OP - ! write(iulog,*) 'first layer of lai_change 4 5',lai_change(1,1,1:5) + ! write(fates_log(),*) 'first layer of lai_change 4 5',lai_change(1,1,1:5) endif if (radtype == 1)then @@ -858,15 +862,15 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! will deal with them for now. end if if (abs(error) > 0.15_r8)then - write(iulog,*) 'Large Dir Radn consvn error',error ,ifp,ib - write(iulog,*) 'diags', bc_out(s)%albd_parb(ifp,ib), bc_out(s)%ftdd_parb(ifp,ib), & + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ifp,ib + write(fates_log(),*) 'diags', bc_out(s)%albd_parb(ifp,ib), bc_out(s)%ftdd_parb(ifp,ib), & bc_out(s)%ftid_parb(ifp,ib), bc_out(s)%fabd_parb(ifp,ib) - write(iulog,*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) - write(iulog,*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) - write(iulog,*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) - write(iulog,*) 'ftweight',ftweight(1,1:2,1:4) - write(iulog,*) 'cp',currentPatch%area, currentPatch%patchno - write(iulog,*) 'bc_in(s)%albgr_dir_rb(ib)',bc_in(s)%albgr_dir_rb(ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'ftweight',ftweight(1,1:2,1:4) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'bc_in(s)%albgr_dir_rb(ib)',bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + error end if @@ -877,19 +881,19 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) end if if (abs(error) > 0.15_r8)then - write(iulog,*) '>5% Dif Radn consvn error',error ,ifp,ib - write(iulog,*) 'diags', bc_out(s)%albi_parb(ifp,ib), bc_out(s)%ftii_parb(ifp,ib), & + write(fates_log(),*) '>5% Dif Radn consvn error',error ,ifp,ib + write(fates_log(),*) 'diags', bc_out(s)%albi_parb(ifp,ib), bc_out(s)%ftii_parb(ifp,ib), & bc_out(s)%fabi_parb(ifp,ib) - write(iulog,*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) - write(iulog,*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) - write(iulog,*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) - write(iulog,*) 'ftweight',ftweight(currentpatch%ncl_p,1:2,1:4) - write(iulog,*) 'cp',currentPatch%area, currentPatch%patchno - write(iulog,*) 'bc_in(s)%albgr_dif_rb(ib)',bc_in(s)%albgr_dif_rb(ib) - write(iulog,*) 'rhol',rhol(1:2,:) - write(iulog,*) 'ftw',sum(ftweight(1,:,1)),ftweight(1,1:2,1) - write(iulog,*) 'present',currentPatch%present(1,1:2) - write(iulog,*) 'CAP',currentPatch%canopy_area_profile(1,1:2,1) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'bc_in(s)%albgr_dif_rb(ib)',bc_in(s)%albgr_dif_rb(ib) + write(fates_log(),*) 'rhol',rhol(1:2,:) + write(fates_log(),*) 'ftw',sum(ftweight(1,:,1)),ftweight(1,1:2,1) + write(fates_log(),*) 'present',currentPatch%present(1,1:2) + write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:2,1) bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + error end if @@ -903,12 +907,12 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) endif if (abs(error) > 0.00000001_r8)then - write(iulog,*) 'there is still error after correction',error ,ifp,ib + write(fates_log(),*) 'there is still error after correction',error ,ifp,ib end if end if - end do !cp_numSWb + end do !hlm_numSWb enddo ! rad-type endif ! is there vegetation? @@ -926,8 +930,6 @@ end subroutine ED_Norman_Radiation subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) - use clm_varctl , only : iulog - implicit none ! Arguments @@ -958,7 +960,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) ifp=ifp+1 - if( DEBUG ) write(iulog,*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft_ed + if( DEBUG ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft_ed ! zero out various datas cpatch%ed_parsun_z(:,:,:) = 0._r8 @@ -981,7 +983,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) do CL = 1, cpatch%NCL_p do FT = 1,numpft_ed - if( DEBUG ) write(iulog,*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) + if( DEBUG ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. @@ -991,8 +993,8 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & cpatch%f_sun(CL,ft,iv) - if ( DEBUG ) write(iulog,*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) - if ( DEBUG ) write(iulog,*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & (1._r8 - cpatch%f_sun(CL,ft,iv)) @@ -1013,7 +1015,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) endif if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(iulog,*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & cpatch%lai,sunlai,shalai endif @@ -1026,34 +1028,34 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo ! are canopy integrated so that layer values equal big leaf values. - if ( DEBUG ) write(iulog,*) 'edsurfRad 645 ',cpatch%NCL_p,numpft_ed + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft_ed do CL = 1, cpatch%NCL_p do FT = 1,numpft_ed - if ( DEBUG ) write(iulog,*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) do iv = 1, cpatch%nrad(CL,ft) if ( DEBUG ) then - write(iulog,*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(iulog,*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) - write(iulog,*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) - write(iulog,*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) - write(iulog,*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) endif cpatch%ed_parsun_z(CL,ft,iv) = & bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) - if ( DEBUG )write(iulog,*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) + if ( DEBUG )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) cpatch%ed_parsha_z(CL,ft,iv) = & bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) - if ( DEBUG ) write(iulog,*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) end do !iv end do !FT @@ -1092,7 +1094,7 @@ end subroutine ED_SunShadeFracs ! g = gridcell(p) ! errsol = (fsa(p) + fsr(p) - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2))) ! if(abs(errsol) > 0.1_r8)then -! write(iulog,*) 'sol error in surf rad',p,g, errsol +! write(fates_log(),*) 'sol error in surf rad',p,g, errsol ! endif ! end do ! return diff --git a/components/clm/src/ED/biogeophys/FatesPlantRespPhotosynthMod.F90 b/components/clm/src/ED/biogeophys/FatesPlantRespPhotosynthMod.F90 index 73f995df4d..6dd2592c24 100644 --- a/components/clm/src/ED/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/components/clm/src/ED/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -20,12 +20,17 @@ module FATESPlantRespPhotosynthMod ! !USES: - use abortutils, only : endrun + use FatesGlobals, only : endrun => fates_endrun use FatesGlobals, only : fates_log use FatesConstantsMod, only : r8 => fates_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg use EDTypesMod, only : use_fates_plant_hydro + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : nlevcan + use EDTypesMod, only : nclmax + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private @@ -66,10 +71,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type - use EDTypesMod , only : numpft_ed - use EDTypesMod , only : cp_numlevsoil - use EDTypesMod , only : cp_nlevcan - use EDTypesMod , only : cp_nclmax + use FatesInterfaceMod , only : hlm_numlevsoil use EDEcophysContype , only : EDecophyscon use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : bc_out_type @@ -80,6 +82,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use FatesConstantsMod, only : rgas => rgas_J_K_kmol use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesParameterDerivedMod, only : param_derived + use EDPatchDynamicsMod, only: set_root_fraction ! ARGUMENTS: @@ -113,17 +116,17 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ----------------------------------------------------------------------------------- ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this - real(r8) :: lmr_z(cp_nlevcan,mxpft,cp_nclmax) + real(r8) :: lmr_z(nlevcan,mxpft,nclmax) ! stomatal resistance s/m - real(r8) :: rs_z(cp_nlevcan,mxpft,cp_nclmax) + real(r8) :: rs_z(nlevcan,mxpft,nclmax) ! net leaf photosynthesis averaged over sun and shade leaves. (umol CO2/m**2/s) - real(r8) :: anet_av_z(cp_nlevcan,mxpft,cp_nclmax) + real(r8) :: anet_av_z(nlevcan,mxpft,nclmax) ! Mask used to determine which leaf-layer biophysical rates have been ! used already - logical :: rate_mask_z(cp_nlevcan,mxpft,cp_nclmax) + logical :: rate_mask_z(nlevcan,mxpft,nclmax) real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation ! (umol co2/m**2/s) @@ -291,7 +294,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) end do !ft - call currentPatch%set_root_fraction(bc_in(s)%depth_gl) + call set_root_fraction(currentPatch,bc_in(s)%depth_gl) ! ------------------------------------------------------------------------ ! Part VI: Loop over all leaf layers. @@ -541,7 +544,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Fine Root MR (kgC/plant/s) ! ------------------------------------------------------------------ currentCohort%froot_mr = 0._r8 - do j = 1,cp_numlevsoil + do j = 1,hlm_numlevsoil tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%froot_mr = currentCohort%froot_mr + & froot_n * base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) @@ -551,7 +554,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ------------------------------------------------------------------ if (woody(ft) == 1) then currentCohort%livecroot_mr = 0._r8 - do j = 1,cp_numlevsoil + do j = 1,hlm_numlevsoil ! Soil temperature used to adjust base rate of MR tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%livecroot_mr = currentCohort%livecroot_mr + & @@ -1310,8 +1313,7 @@ subroutine UpdateCanopyNCanNRadPresent(currentPatch) ! profile). ! --------------------------------------------------------------------------------- - use EDTypesMod , only : cp_nclmax - use EDTypesMOd , only : numpft_ed + use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type @@ -1347,7 +1349,7 @@ subroutine UpdateCanopyNCanNRadPresent(currentPatch) currentPatch%nrad = currentPatch%ncan ! Now loop through and identify which layer and pft combo has scattering elements - do cl = 1,cp_nclmax + do cl = 1,nclmax do ft = 1,numpft_ed currentPatch%present(cl,ft) = 0 do iv = 1, currentPatch%nrad(cl,ft); diff --git a/components/clm/src/ED/fire/SFMainMod.F90 b/components/clm/src/ED/fire/SFMainMod.F90 index b6ff07c79a..7c715deafa 100755 --- a/components/clm/src/ED/fire/SFMainMod.F90 +++ b/components/clm/src/ED/fire/SFMainMod.F90 @@ -7,8 +7,8 @@ module SFMainMod use FatesConstantsMod , only : r8 => fates_r8 -! use spmdMod , only : masterproc - use EDTypesMod , only : cp_masterproc ! 1= master process, 0=not master process + use FatesInterfaceMod , only : hlm_masterproc ! 1= master process, 0=not master process + use EDTypesMod , only : numWaterMem use FatesGlobals , only : fates_log use FatesInterfaceMod , only : bc_in_type @@ -184,15 +184,15 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac = 0.0_r8 if(write_sf == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter - if ( cp_masterproc == 1 ) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) - if ( cp_masterproc == 1 ) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass - if ( cp_masterproc == 1 ) write(fates_log(),*) ' sum fuel', currentPatch%sum_fuel + if ( hlm_masterproc == 1 ) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter + if ( hlm_masterproc == 1 ) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) + if ( hlm_masterproc == 1 ) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass + if ( hlm_masterproc == 1 ) write(fates_log(),*) ' sum fuel', currentPatch%sum_fuel endif currentPatch%sum_fuel = sum(currentPatch%leaf_litter) + sum(currentPatch%CWD_AG) + currentPatch%livegrass if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area endif ! =============================================== ! Average moisture, bulk density, surface area-volume and moisture extinction of fuel @@ -204,9 +204,9 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac(dg_sf+1:tr_sf) = currentPatch%CWD_AG / currentPatch%sum_fuel if(write_sf == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel endif currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel @@ -215,14 +215,14 @@ subroutine charecteristics_of_fuel ( currentSite ) !Equation 6 in Thonicke et al. 2010. fuel_moisture(dg_sf+1:tr_sf) = exp(-1.0_r8 * SF_val_alpha_FMC(dg_sf+1:tr_sf) * currentSite%acc_NI) if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac - if ( cp_masterproc == 1 ) write(fates_log(),*) 'fm ',fuel_moisture - if ( cp_masterproc == 1 ) write(fates_log(),*) 'csa ',currentSite%acc_NI - if ( cp_masterproc == 1 ) write(fates_log(),*) 'sfv ',SF_val_alpha_FMC + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'fm ',fuel_moisture + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'csa ',currentSite%acc_NI + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'sfv ',SF_val_alpha_FMC endif ! FIX(RF,032414): needs refactoring. ! average water content !is this the correct metric? - timeav_swc = sum(currentSite%water_memory(1:10)) / 10._r8 + timeav_swc = sum(currentSite%water_memory(1:numWaterMem)) / dble(numWaterMem) ! Equation B2 in Thonicke et al. 2010 fuel_moisture(lg_sf) = max(0.0_r8, 10.0_r8/9._r8 * timeav_swc - 1.0_r8/9.0_r8) @@ -232,7 +232,7 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_mef = sum(currentPatch%fuel_frac(dg_sf:lb_sf) * MEF(dg_sf:lb_sf)) currentPatch%fuel_eff_moist = sum(currentPatch%fuel_frac(dg_sf:lb_sf) * fuel_moisture(dg_sf:lb_sf)) if(write_sf == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ff4 ',currentPatch%fuel_eff_moist + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ff4 ',currentPatch%fuel_eff_moist endif ! Add on properties of live grass multiplied by grass fraction. (6) currentPatch%fuel_bulkd = currentPatch%fuel_bulkd + currentPatch%fuel_frac(lg_sf) * SF_val_FBD(lg_sf) @@ -259,14 +259,14 @@ subroutine charecteristics_of_fuel ( currentSite ) if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'no litter fuel at all',currentPatch%patchno, & + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'no litter fuel at all',currentPatch%patchno, & currentPatch%sum_fuel,sum(currentPatch%cwd_ag), & sum(currentPatch%cwd_bg),sum(currentPatch%leaf_litter) endif currentPatch%fuel_sav = sum(SF_val_SAV(1:ncwd+2))/(ncwd+2) ! make average sav to avoid crashing code. - if ( cp_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' ! FIX(SPM,032414) refactor...should not have 0 fuel unless everything is burnt ! off. @@ -282,7 +282,7 @@ subroutine charecteristics_of_fuel ( currentSite ) ! FIX(SPM,032414) refactor... if(write_SF == 1.and.currentPatch%fuel_sav <= 0.0_r8.or.currentPatch%fuel_bulkd <= & 0.0_r8.or.currentPatch%fuel_mef <= 0.0_r8.or.currentPatch%fuel_eff_moist <= 0.0_r8)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' endif currentPatch => currentPatch%younger @@ -321,7 +321,7 @@ subroutine wind_effect ( currentSite, bc_in) wind = bc_in%wind24_pa(iofp) * sec_per_min ! Convert to m/min for SPITFIRE units. if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'wind24', wind + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'wind24', wind endif ! --- influence of wind speed, corrected for surface roughness---- ! --- averaged over the whole grid cell to prevent extreme divergence @@ -360,7 +360,7 @@ subroutine wind_effect ( currentSite, bc_in) grass_fraction = min(grass_fraction,1.0_r8-tree_fraction) bare_fraction = 1.0 - tree_fraction - grass_fraction if(write_sf == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction endif currentPatch=>currentSite%oldest_patch; @@ -410,18 +410,18 @@ subroutine rate_of_spread ( currentSite ) currentPatch%sum_fuel = currentPatch%sum_fuel * (1.0_r8 - SF_val_miner_total) !net of minerals ! ----start spreading--- - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - SF_val_part_dens ',SF_val_part_dens + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - SF_val_part_dens ',SF_val_part_dens beta = (currentPatch%fuel_bulkd / 0.45_r8) / SF_val_part_dens ! Equation A6 in Thonicke et al. 2010 beta_op = 0.200395_r8 *(currentPatch%fuel_sav**(-0.8189_r8)) - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op bet = beta/beta_op if(write_sf == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist endif ! ---heat of pre-ignition--- ! Equation A4 in Thonicke et al. 2010 @@ -439,11 +439,11 @@ subroutine rate_of_spread ( currentSite ) ! Equation A5 in Thonicke et al. 2010 if (DEBUG) then - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - c ',c - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - b ',b - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet - if ( cp_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - e ',e + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - c ',c + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - b ',b + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet + if ( hlm_masterproc == 1 .and.DEBUG) write(fates_log(),*) 'SF - e ',e endif ! convert from m/min to ft/min for Rothermel ROS eqn @@ -605,7 +605,7 @@ subroutine fire_intensity ( currentSite ) W = currentPatch%TFC_ROS / 0.45_r8 !kgC/m2 to kgbiomass/m2 currentPatch%FI = SF_val_fuel_energy * W * ROS !kj/m/s, or kW/m if(write_sf == 1)then - if( cp_masterproc == 1 ) write(fates_log(),*) 'fire_intensity',currentPatch%fi,W,currentPatch%ROS_front + if( hlm_masterproc == 1 ) write(fates_log(),*) 'fire_intensity',currentPatch%fi,W,currentPatch%ROS_front endif !'decide_fire' subroutine shortened and put in here... if (currentPatch%FI >= fire_threshold) then ! 50kW/m is the threshold for a self-sustaining fire @@ -616,7 +616,7 @@ subroutine fire_intensity ( currentSite ) ! Equation 14 in Thonicke et al. 2010 currentPatch%FD = SF_val_max_durat / (1.0_r8 + SF_val_max_durat * exp(SF_val_durat_slope*d_FDI)) if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'fire duration minutes',currentPatch%fd + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'fire duration minutes',currentPatch%fd endif !equation 15 in Arora and Boer CTEM model.Average fire is 1 day long. !currentPatch%FD = 60.0_r8 * 24.0_r8 !no minutes in a day @@ -703,19 +703,19 @@ subroutine area_burnt ( currentSite ) currentPatch%AB = size_of_fire * currentPatch%nf if (currentPatch%AB > gridarea*currentPatch%area/area) then !all of patch burnt. - if ( cp_masterproc == 1 ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & currentPatch%area/area,currentPatch%ab,currentPatch%area/area*gridarea - if ( cp_masterproc == 1 ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & currentPatch%NF,currentPatch%FI,size_of_fire - if ( cp_masterproc == 1 ) write(fates_log(),*) 'litter', & + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'litter', & currentPatch%sum_fuel,currentPatch%CWD_AG,currentPatch%leaf_litter ! turn km2 into m2. work out total area burnt. currentPatch%AB = currentPatch%area * gridarea/AREA endif currentPatch%frac_burnt = currentPatch%AB / (gridarea*currentPatch%area/area) if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt endif endif endif! fire @@ -772,7 +772,7 @@ subroutine crown_scorching ( currentSite ) currentCohort%bdead))*currentCohort%n)/tree_ag_biomass !equation 16 in Thonicke et al. 2010 if(write_SF == 1)then - if ( cp_masterproc == 1 ) write(fates_log(),*) 'currentPatch%SH',currentPatch%SH,f_ag_bmass + if ( hlm_masterproc == 1 ) write(fates_log(),*) 'currentPatch%SH',currentPatch%SH,f_ag_bmass endif !2/3 Byram (1959) currentPatch%SH = currentPatch%SH + f_ag_bmass * SF_val_alpha_SH * (currentPatch%FI**0.667_r8) diff --git a/components/clm/src/ED/fire/SFParamsMod.F90 b/components/clm/src/ED/fire/SFParamsMod.F90 index 3caa526a01..978ac5f9a2 100644 --- a/components/clm/src/ED/fire/SFParamsMod.F90 +++ b/components/clm/src/ED/fire/SFParamsMod.F90 @@ -2,7 +2,7 @@ module SFParamsMod ! ! module that deals with reading the SF parameter file ! - use shr_kind_mod , only: r8 => shr_kind_r8 + use FatesConstantsMod , only: r8 => fates_r8 use EDtypesMod , only: NLSC,NFSC,NCWD implicit none diff --git a/components/clm/src/ED/main/EDInitMod.F90 b/components/clm/src/ED/main/EDInitMod.F90 index 76bc5ed9b2..952e486333 100755 --- a/components/clm/src/ED/main/EDInitMod.F90 +++ b/components/clm/src/ED/main/EDInitMod.F90 @@ -5,8 +5,8 @@ module EDInitMod ! ============================================================================ use FatesConstantsMod , only : r8 => fates_r8 - use abortutils , only : endrun - use EDTypesMod , only : cp_nclmax + use FatesGlobals , only : endrun => fates_endrun + use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log use clm_varctl , only : use_ed_spit_fire use clm_time_manager , only : is_restart @@ -16,8 +16,10 @@ module EDInitMod use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDPatchDynamicsMod , only : create_patch use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area - use EDTypesMod , only : cohorts_per_col, ncwd, numpft_ed - + use EDTypesMod , only : ncwd + use EDTypesMod , only : nuMWaterMem + use EDTypesMod , only : numpft_ed + implicit none private @@ -144,7 +146,7 @@ subroutine set_site_properties( nsites, sites) sites(s)%ED_GDD_site = GDD if ( .not. is_restart() ) then - sites(s)%water_memory(1:10) = watermem + sites(s)%water_memory(1:numWaterMem) = watermem end if sites(s)%status = stat @@ -178,7 +180,7 @@ subroutine init_patches( nsites, sites) integer :: s real(r8) :: cwd_ag_local(ncwd) real(r8) :: cwd_bg_local(ncwd) - real(r8) :: spread_local(cp_nclmax) + real(r8) :: spread_local(nclmax) real(r8) :: leaf_litter_local(numpft_ed) real(r8) :: root_litter_local(numpft_ed) real(r8) :: age !notional age of this patch diff --git a/components/clm/src/ED/main/EDMainMod.F90 b/components/clm/src/ED/main/EDMainMod.F90 index 2bddac71cf..d06ff59218 100755 --- a/components/clm/src/ED/main/EDMainMod.F90 +++ b/components/clm/src/ED/main/EDMainMod.F90 @@ -7,23 +7,34 @@ module EDMainMod use shr_kind_mod , only : r8 => shr_kind_r8 use FatesGlobals , only : fates_log - use FatesGlobals , only : freq_day - use FatesGlobals , only : day_of_year - use FatesGlobals , only : days_per_year - use FatesGlobals , only : current_year - use FatesGlobals , only : current_month - use FatesGlobals , only : current_day - use atm2lndType , only : atm2lnd_type - use SoilStateType , only : soilstate_type - use TemperatureType , only : temperature_type - use EDCohortDynamicsMod , only : allocate_live_biomass, terminate_cohorts, fuse_cohorts, sort_cohorts, count_cohorts - use EDPatchDynamicsMod , only : disturbance_rates, fuse_patches, spawn_patches, terminate_patches - use EDPhysiologyMod , only : canopy_derivs, non_canopy_derivs, phenology, recruitment, trim_canopy + use FatesInterfaceMod , only : hlm_freq_day + use FatesInterfaceMod , only : hlm_day_of_year + use FatesInterfaceMod , only : hlm_days_per_year + use FatesInterfaceMod , only : hlm_current_year + use FatesInterfaceMod , only : hlm_current_month + use FatesInterfaceMod , only : hlm_current_day + use EDCohortDynamicsMod , only : allocate_live_biomass + use EDCohortDynamicsMod , only : terminate_cohorts + use EDCohortDynamicsMod , only : fuse_cohorts + use EDCohortDynamicsMod , only : sort_cohorts + use EDCohortDynamicsMod , only : count_cohorts + use EDPatchDynamicsMod , only : disturbance_rates + use EDPatchDynamicsMod , only : fuse_patches + use EDPatchDynamicsMod , only : spawn_patches + use EDPatchDynamicsMod , only : terminate_patches + use EDPhysiologyMod , only : canopy_derivs + use EDPhysiologyMod , only : non_canopy_derivs + use EDPhysiologyMod , only : phenology + use EDPhysiologyMod , only : recruitment + use EDPhysiologyMod , only : trim_canopy use SFMainMod , only : fire_model - use EDtypesMod , only : ncwd, numpft_ed - use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use EDtypesMod , only : ncwd + use EDTypesMod , only : numpft_ed + use EDtypesMod , only : ed_site_type + use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : ed_cohort_type use FatesInterfaceMod , only : bc_in_type - use EDTypesMod , only : cp_masterproc + use FatesInterfaceMod , only : hlm_masterproc implicit none @@ -60,8 +71,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) type(ed_patch_type), pointer :: currentPatch !----------------------------------------------------------------------- - if ( cp_masterproc==1 ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& - current_year,'-',current_month,'-',current_day + if ( hlm_masterproc==1 ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& + hlm_current_year,'-',hlm_current_month,'-',hlm_current_day !************************************************************************** ! Fire, growth, biogeochemistry. @@ -171,7 +182,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) do while(associated(currentPatch)) - currentPatch%age = currentPatch%age + freq_day + currentPatch%age = currentPatch%age + hlm_freq_day ! FIX(SPM,032414) valgrind 'Conditional jump or move depends on uninitialised value' if( currentPatch%age < 0._r8 )then write(fates_log(),*) 'negative patch age?',currentPatch%age, & @@ -189,17 +200,17 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) do while(associated(currentCohort)) cohort_biomass_store = (currentCohort%balive+currentCohort%bdead+currentCohort%bstore) - currentCohort%dbh = max(small_no,currentCohort%dbh + currentCohort%ddbhdt * freq_day ) - currentCohort%balive = currentCohort%balive + currentCohort%dbalivedt * freq_day - currentCohort%bdead = max(small_no,currentCohort%bdead + currentCohort%dbdeaddt * freq_day ) + currentCohort%dbh = max(small_no,currentCohort%dbh + currentCohort%ddbhdt * hlm_freq_day ) + currentCohort%balive = currentCohort%balive + currentCohort%dbalivedt * hlm_freq_day + currentCohort%bdead = max(small_no,currentCohort%bdead + currentCohort%dbdeaddt * hlm_freq_day ) if ( DEBUG ) then write(fates_log(),*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & - currentCohort%dbstoredt,freq_day + currentCohort%dbstoredt,hlm_freq_day end if - currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * freq_day + currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * hlm_freq_day if ( DEBUG ) then write(fates_log(),*) 'EDMainMod dbstoredt II ',currentCohort%bstore, & - currentCohort%dbstoredt,freq_day + currentCohort%dbstoredt,hlm_freq_day end if if( (currentCohort%balive+currentCohort%bdead+currentCohort%bstore)*currentCohort%n<0._r8)then @@ -207,10 +218,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) currentCohort%bdead,currentCohort%bstore endif - if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+freq_day*(currentCohort%md+ & + if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+hlm_freq_day*(currentCohort%md+ & currentCohort%seed_prod)-cohort_biomass_store)-currentCohort%npp_acc) > 1e-8_r8)then write(fates_log(),*) 'issue with c balance in integration', abs(currentCohort%balive+currentCohort%bdead+ & - currentCohort%bstore+freq_day* & + currentCohort%bstore+hlm_freq_day* & (currentCohort%md+currentCohort%seed_prod)-cohort_biomass_store-currentCohort%npp_acc) endif @@ -225,23 +236,19 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) enddo - if ( DEBUG ) then - write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno - endif - call non_canopy_derivs( currentSite, currentPatch, bc_in) !update state variables simultaneously according to derivatives for this time period. ! first update the litter variables that are tracked at the patch level do c = 1,ncwd - currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + currentPatch%dcwd_ag_dt(c)* freq_day - currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + currentPatch%dcwd_bg_dt(c)* freq_day + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + currentPatch%dcwd_ag_dt(c)* hlm_freq_day + currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + currentPatch%dcwd_bg_dt(c)* hlm_freq_day enddo do ft = 1,numpft_ed - currentPatch%leaf_litter(ft) = currentPatch%leaf_litter(ft) + currentPatch%dleaf_litter_dt(ft)* freq_day - currentPatch%root_litter(ft) = currentPatch%root_litter(ft) + currentPatch%droot_litter_dt(ft)* freq_day + currentPatch%leaf_litter(ft) = currentPatch%leaf_litter(ft) + currentPatch%dleaf_litter_dt(ft)* hlm_freq_day + currentPatch%root_litter(ft) = currentPatch%root_litter(ft) + currentPatch%droot_litter_dt(ft)* hlm_freq_day enddo do c = 1,ncwd @@ -265,7 +272,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) endif if(currentPatch%root_litter(ft) currentPatch%shortest do while(associated(currentCohort)) - currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * freq_day ) + currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * hlm_freq_day ) currentCohort => currentCohort%taller enddo @@ -286,7 +293,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) ! at the site level, update the seed bank mass do ft = 1,numpft_ed - currentSite%seed_bank(ft) = currentSite%seed_bank(ft) + currentSite%dseed_dt(ft)*freq_day + currentSite%seed_bank(ft) = currentSite%seed_bank(ft) + currentSite%dseed_dt(ft)*hlm_freq_day enddo ! Check for negative values. Write out warning to show carbon balance. @@ -359,7 +366,7 @@ subroutine ed_update_site( currentSite, bc_in ) ! FIX(RF,032414). This needs to be monthly, not annual ! If this is the second to last day of the year, then perform trimming - if( day_of_year == days_per_year-1) then + if( hlm_day_of_year == hlm_days_per_year-1) then write(fates_log(),*) 'calling trim canopy' call trim_canopy(currentSite) diff --git a/components/clm/src/ED/main/EDPftvarcon.F90 b/components/clm/src/ED/main/EDPftvarcon.F90 index 475ee7b1bb..0961e71adb 100644 --- a/components/clm/src/ED/main/EDPftvarcon.F90 +++ b/components/clm/src/ED/main/EDPftvarcon.F90 @@ -58,7 +58,7 @@ subroutine EDpftconrd( ncid ) ! ! !USES: use ncdio_pio , only : file_desc_t, ncd_io - use abortutils , only : endrun + use FatesGlobals, only : endrun => fates_endrun ! ! !ARGUMENTS: implicit none diff --git a/components/clm/src/ED/main/EDTypesMod.F90 b/components/clm/src/ED/main/EDTypesMod.F90 index 2470c8775e..75197a68eb 100755 --- a/components/clm/src/ED/main/EDTypesMod.F90 +++ b/components/clm/src/ED/main/EDTypesMod.F90 @@ -1,48 +1,48 @@ module EDTypesMod - use shr_kind_mod , only : r8 => shr_kind_r8; - use decompMod , only : bounds_type - use clm_varpar , only : nlevgrnd, mxpft - use domainMod , only : domain_type - use shr_sys_mod , only : shr_sys_flush + use FatesConstantsMod , only : r8 => fates_r8 + use clm_varpar , only : mxpft + implicit none save - !SWITCHES THAT ARE READ IN - integer RESTART ! restart flag, 1= read initial system state 0 = bare ground - - ! MODEL PARAMETERS - real(r8) :: timestep_secs ! subdaily timestep in seconds (e.g. 1800 or 3600) - - real(r8), parameter :: AREA = 10000.0_r8 ! Notional area of simulated forest m2 - integer doy - - integer, parameter :: invalidValue = -9999 ! invalid value for gcells, - ! cohorts, and patches + integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site + integer, parameter :: maxCohortsPerPatch = 160 ! maximum number of cohorts to live on a patch + integer, parameter :: nclmax = 2 ! Maximum number of canopy layers + integer, parameter :: nlevcan = 40 ! number of leaf layers in canopy layer + integer, parameter :: maxpft = 10 ! maximum number of PFTs allowed + ! the parameter file may determine that fewer + ! are used, but this helps allocate scratch + ! space and output arrays. + + integer, parameter :: numpft_ed = 2 ! number of PFTs used in ED. - ! for setting number of patches per gridcell and number of cohorts per patch - ! for I/O and converting to a vector + ! TODO: we use this cp_maxSWb only because we have a static array (size=2) of + ! land-ice abledo for vis and nir. This should be a parameter, which would + ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) + integer, parameter :: maxSWb = 2 ! maximum number of broad-bands in the + ! shortwave spectrum cp_numSWb <= cp_maxSWb + ! this is just for scratch-array purposes + ! if cp_numSWb is larger than this value + ! simply bump this number up as needed - integer, parameter :: maxPatchesPerCol = 10 ! - integer, parameter :: maxCohortsPerPatch = 160 ! - integer, parameter :: cohorts_per_col = 1600 ! This is the max number of individual items one can store per + ! Module switches (this will be read in one day) + ! This variable only exists now to serve as a place holder + !!!!!!!!!! THIS SHOULD NOT BE SET TO TRUE !!!!!!!!!!!!!!!!! + logical, parameter :: use_fates_plant_hydro = .false. - ! each grid cell and effects the striding in the ED restart - ! data as some fields are arrays where each array is - ! associated with one cohort + ! MODEL PARAMETERS + real(r8), parameter :: AREA = 10000.0_r8 ! Notional area of simulated forest m2 integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var ! BIOLOGY/BIOGEOCHEMISTRY - integer , parameter :: INTERNAL_RECRUITMENT = 1 ! internal recruitment fla 1=yes - integer , parameter :: EXTERNAL_RECRUITMENT = 0 ! external recruitment flag 1=yes + integer , parameter :: external_recruitment = 0 ! external recruitment flag 1=yes integer , parameter :: SENES = 10 ! Window of time over which we track temp for cold sensecence (days) real(r8), parameter :: DINC_ED = 1.0_r8 ! size of LAI bins. integer , parameter :: N_DIST_TYPES = 2 ! number of disturbance types (mortality, fire) - integer , parameter :: numpft_ed = 2 ! number of PFTs used in ED. - integer , parameter :: maxPft = 79 ! max number of PFTs potentially used by CLM - + ! SPITFIRE integer , parameter :: NLSC = 6 ! number carbon compartments in above ground litter array @@ -70,9 +70,11 @@ module EDTypesMod real(r8), parameter :: min_npm2 = 1.0d-5 ! minimum cohort number density per m2 before termination real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination real(r8), parameter :: min_nppatch = 1.0d-8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) - real(r8), parameter :: min_n_safemath = 1.0d-15 ! in some cases, we want to immediately remove super small - ! number densities of cohorts to prevent FPEs, this is usually - ! just relevant in the first day after recruitment + + ! in some cases, we want to immediately remove super small + ! number densities of cohorts to prevent FPEs, this is usually + ! just relevant in the first day after recruitment + real(r8), parameter :: min_n_safemath = 1.0E-15_r8 character*4 yearchar @@ -99,7 +101,8 @@ module EDTypesMod ! Number of ways to die ! (background,hydraulic,carbon,impact,fire) - character(len = 10), parameter,dimension(5) :: char_list = (/"background","hydraulic ","carbon ","impact ","fire "/) + character(len = 10), parameter,dimension(nlevmclass_ed) :: char_list = & + (/"background","hydraulic ","carbon ","impact ","fire "/) ! These vectors are used for history output mapping @@ -112,59 +115,6 @@ module EDTypesMod real(r8), allocatable :: levage_ed(:) integer , allocatable :: levpft_ed(:) - - ! Control Parameters (cp_) - ! ------------------------------------------------------------------------------------- - - ! These parameters are dictated by FATES internals - - integer, parameter :: cp_nclmax = 2 ! Maximum number of canopy layers - - integer, parameter :: cp_nlevcan = 40 ! number of leaf layers in canopy layer - - integer, parameter :: cp_maxSWb = 2 ! maximum number of broad-bands in the - ! shortwave spectrum cp_numSWb <= cp_maxSWb - ! this is just for scratch-array purposes - ! if cp_numSWb is larger than this value - ! simply bump this number up as needed - ! These parameters are dictated by the host model or driver - - integer :: cp_numSWb ! Number of broad-bands in the short-wave radiation - ! specturm to track - ! (typically 2 as a default, VIS/NIR, in ED variants <2016) - - integer :: cp_numlevgrnd ! Number of ground layers - integer :: cp_numlevsoil ! Number of soil layers - - ! Number of GROUND layers for the purposes of biogeochemistry; can be either 1 - ! or the total number of soil layers (includes bedrock) - integer :: cp_numlevdecomp_full - - ! Number of SOIL layers for the purposes of biogeochemistry; can be either 1 - ! or the total number of soil layers - integer :: cp_numlevdecomp - - ! This character string passed by the HLM is used during the processing of IO - ! data, so that FATES knows which IO variables it should prepare. For instance - ! ATS, ALM and CLM will only want variables specficially packaged for them. - ! This string will dictate which filter is enacted. - character(len=16) :: cp_hlm_name - - ! This value can be flushed to history diagnostics, such that the - ! HLM will interpret that the value should not be included in the average. - real(r8) :: cp_hio_ignore_val - - - ! Is this the master processor, typically useful for knowing if - ! the current machine should be printing out messages to the logs or terminals - ! 1 = TRUE (is master) 0 = FALSE (is not master) - integer :: cp_masterproc - - - ! Module switches (this will be read in one day) - ! This variable only exists now to serve as a place holder - !!!!!!!!!! THIS SHOULD NOT BE SET TO TRUE !!!!!!!!!!!!!!!!! - logical,parameter :: use_fates_plant_hydro = .false. !************************************ !** COHORT type structure ** @@ -253,8 +203,8 @@ module EDTypesMod real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/day real(r8) :: npp_store ! NPP into storage: KgC/indiv/day - real(r8) :: ts_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/s - real(r8) :: year_net_uptake(cp_nlevcan) ! Net uptake of leaf layers: kgC/m2/year + real(r8) :: ts_net_uptake(nlevcan) ! Net uptake of leaf layers: kgC/m2/s + real(r8) :: year_net_uptake(nlevcan) ! Net uptake of leaf layers: kgC/m2/year ! RESPIRATION COMPONENTS real(r8) :: rdark ! Dark respiration: kgC/indiv/s @@ -325,9 +275,6 @@ module EDTypesMod !INDICES integer :: patchno ! unique number given to each new patch created for tracking - ! INTERF-TODO: THIS VARIABLE SHOULD BE REMOVED - integer :: clm_pno ! clm patch number (index of p vector) - ! PATCH INFO real(r8) :: age ! average patch age: years integer :: age_class ! age class of the patch for history binning purposes @@ -336,42 +283,42 @@ module EDTypesMod integer :: ncl_p ! Number of occupied canopy layers ! LEAF ORGANIZATION - real(r8) :: spread(cp_nclmax) ! dynamic ratio of dbh to canopy area: cm/m2 + real(r8) :: spread(nclmax) ! dynamic ratio of dbh to canopy area: cm/m2 real(r8) :: pft_agb_profile(numpft_ed,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 - real(r8) :: canopy_layer_lai(cp_nclmax) ! lai that is shading this canopy layer: m2/m2 + real(r8) :: canopy_layer_lai(nclmax) ! lai that is shading this canopy layer: m2/m2 real(r8) :: total_canopy_area ! area that is covered by vegetation : m2 real(r8) :: total_tree_area ! area that is covered by woody vegetation : m2 real(r8) :: canopy_area ! area that is covered by vegetation : m2 (is this different to total_canopy_area? real(r8) :: bare_frac_area ! bare soil in this patch expressed as a fraction of the total soil surface. real(r8) :: lai ! leaf area index of patch - real(r8) :: tlai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: elai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: tsai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: esai_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 - real(r8) :: layer_height_profile(cp_nclmax,numpft_ed,cp_nlevcan) - real(r8) :: canopy_area_profile(cp_nclmax,numpft_ed,cp_nlevcan) ! fraction of canopy in each canopy + real(r8) :: tlai_profile(nclmax,numpft_ed,nlevcan) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: elai_profile(nclmax,numpft_ed,nlevcan) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: tsai_profile(nclmax,numpft_ed,nlevcan) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: esai_profile(nclmax,numpft_ed,nlevcan) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: layer_height_profile(nclmax,numpft_ed,nlevcan) + real(r8) :: canopy_area_profile(nclmax,numpft_ed,nlevcan) ! fraction of canopy in each canopy ! layer, pft, and leaf layer:- - integer :: present(cp_nclmax,numpft_ed) ! is there any of this pft in this canopy layer? - integer :: nrad(cp_nclmax,numpft_ed) ! number of exposed leaf layers for each canopy layer and pft - integer :: ncan(cp_nclmax,numpft_ed) ! number of total leaf layers for each canopy layer and pft + integer :: present(nclmax,numpft_ed) ! is there any of this pft in this canopy layer? + integer :: nrad(nclmax,numpft_ed) ! number of exposed leaf layers for each canopy layer and pft + integer :: ncan(nclmax,numpft_ed) ! number of total leaf layers for each canopy layer and pft !RADIATION FLUXES - real(r8) :: fabd_sun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! sun fraction of direct light absorbed by each canopy + real(r8) :: fabd_sun_z(nclmax,numpft_ed,nlevcan) ! sun fraction of direct light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: fabd_sha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! shade fraction of direct light absorbed by each canopy + real(r8) :: fabd_sha_z(nclmax,numpft_ed,nlevcan) ! shade fraction of direct light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: fabi_sun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! sun fraction of indirect light absorbed by each canopy + real(r8) :: fabi_sun_z(nclmax,numpft_ed,nlevcan) ! sun fraction of indirect light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: fabi_sha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! shade fraction of indirect light absorbed by each canopy + real(r8) :: fabi_sha_z(nclmax,numpft_ed,nlevcan) ! shade fraction of indirect light absorbed by each canopy ! layer, pft, and leaf layer:- - real(r8) :: ed_laisun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! amount of LAI in the sun in each canopy layer, + real(r8) :: ed_laisun_z(nclmax,numpft_ed,nlevcan) ! amount of LAI in the sun in each canopy layer, ! pft, and leaf layer. m2/m2 - real(r8) :: ed_laisha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! amount of LAI in the shade in each canopy layer, - real(r8) :: ed_parsun_z(cp_nclmax,numpft_ed,cp_nlevcan) ! PAR absorbed in the sun in each canopy layer, - real(r8) :: ed_parsha_z(cp_nclmax,numpft_ed,cp_nlevcan) ! PAR absorbed in the shade in each canopy layer, - real(r8) :: f_sun(cp_nclmax,numpft_ed,cp_nlevcan) ! fraction of leaves in the sun in each canopy layer, pft, + real(r8) :: ed_laisha_z(nclmax,numpft_ed,nlevcan) ! amount of LAI in the shade in each canopy layer, + real(r8) :: ed_parsun_z(nclmax,numpft_ed,nlevcan) ! PAR absorbed in the sun in each canopy layer, + real(r8) :: ed_parsha_z(nclmax,numpft_ed,nlevcan) ! PAR absorbed in the shade in each canopy layer, + real(r8) :: f_sun(nclmax,numpft_ed,nlevcan) ! fraction of leaves in the sun in each canopy layer, pft, ! and leaf layer. m2/m2 real(r8),allocatable :: tr_soil_dir(:) ! fraction of incoming direct radiation that (cm_numSWb) @@ -393,7 +340,10 @@ module EDTypesMod real(r8) :: seed_germination(numpft_ed) ! germination rate of seed pool in KgC/m2/year ! PHOTOSYNTHESIS - real(r8) :: psn_z(cp_nclmax,numpft_ed,cp_nlevcan) ! carbon assimilation in each canopy layer, pft, and leaf layer. umolC/m2/s + + real(r8) :: psn_z(nclmax,numpft_ed,nlevcan) ! carbon assimilation in each canopy layer, pft, and leaf layer. umolC/m2/s +! real(r8) :: gpp ! total patch gpp: KgC/m2/year +! real(r8) :: npp ! total patch npp: KgC/m2/year ! ROOTS real(r8), allocatable :: rootfr_ft(:,:) ! root fraction of each PFT in each soil layer:- @@ -441,13 +391,13 @@ module EDTypesMod real(r8) :: fuel_frac(ncwd+2) ! fraction of each litter class in the ros_fuel:-. real(r8) :: livegrass ! total aboveground grass biomass in patch. KgC/m2 real(r8) :: fuel_bulkd ! average fuel bulk density of the ground fuel - ! (incl. live grasses. omits 1000hr fuels). KgC/m3 + ! (incl. live grasses. omits 1000hr fuels). KgC/m3 real(r8) :: fuel_sav ! average surface area to volume ratio of the ground fuel - ! (incl. live grasses. omits 1000hr fuels). + ! (incl. live grasses. omits 1000hr fuels). real(r8) :: fuel_mef ! average moisture of extinction factor - ! of the ground fuel (incl. live grasses. omits 1000hr fuels). + ! of the ground fuel (incl. live grasses. omits 1000hr fuels). real(r8) :: fuel_eff_moist ! effective avearage fuel moisture content of the ground fuel - ! (incl. live grasses. omits 1000hr fuels) + ! (incl. live grasses. omits 1000hr fuels) real(r8) :: litter_moisture(ncwd+2) ! FIRE SPREAD @@ -469,8 +419,6 @@ module EDTypesMod contains - procedure, public :: set_root_fraction - end type ed_patch_type !************************************ @@ -540,7 +488,7 @@ module EDTypesMod integer :: leafoffdate ! doy of leaf off:- integer :: dleafondate ! doy of leaf on drought:- integer :: dleafoffdate ! doy of leaf on drought:- - real(r8) :: water_memory(10) ! last 10 days of soil moisture memory... + real(r8) :: water_memory(numWaterMem) ! last 10 days of soil moisture memory... !SEED BANK real(r8) :: seed_bank(numpft_ed) ! seed pool in KgC/m2/year @@ -557,20 +505,6 @@ module EDTypesMod end type ed_site_type - !************************************ - !** Userdata type structure ** - !************************************ - -! type userdata -! integer :: cohort_number ! Counts up the number of cohorts which have been made. -! integer :: n_sub ! num of substeps in year -! real(r8) :: deltat ! fraction of year used for each timestep (1/N_SUB) -! integer :: time_period ! Within year timestep (1:N_SUB) day of year -! integer :: restart_year ! Which year of simulation are we starting in? -! end type userdata -! type(userdata), public, target :: udata ! THIS WAS NOT THREADSAFE - !-------------------------------------------------------------------------------------! - public :: ed_hist_scpfmaps contains @@ -585,7 +519,7 @@ subroutine ed_hist_scpfmaps integer :: i integer :: isc integer :: ipft - + allocate( levsclass_ed(1:nlevsclass_ed )) allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) allocate(scls_levscpf_ed(1:nlevsclass_ed*mxpft)) @@ -616,77 +550,6 @@ subroutine ed_hist_scpfmaps end subroutine ed_hist_scpfmaps - !-------------------------------------------------------------------------------------! - function map_clmpatch_to_edpatch(site, clmpatch_number) result(edpatch_pointer) - ! - ! !ARGUMENTS - type(ed_site_type), intent(in), target :: site - integer, intent(in) :: clmpatch_number - ! - ! !LOCAL VARIABLES: - type(ed_patch_type), pointer :: edpatch_pointer - !---------------------------------------------------------------------- - - ! There is a one-to-one mapping between edpatches and clmpatches. To obtain - ! this mapping - the following is computed elsewhere in the code base - ! (1) what is the weight respective to the column of clmpatch? - ! dynEDMod determines this via the following logic - ! if (clm_patch%is_veg(p) .or. clm_patch%is_bareground(p)) then - ! clm_patch%wtcol(p) = clm_patch%wt_ed(p) - ! else - ! clm_patch%wtcol(p) = 0.0_r8 - ! end if - ! (2) is the clmpatch active? - ! subgridWeightsMod uses the following logic (in routine is_active_p) to determine if - ! clmpatch_number is active ( this is a shortened version of the logic to capture - ! only the essential parts relevent here) - ! if (clmpatch%wtcol(p) > 0._r8) is_active_p = .true. - - edpatch_pointer => site%oldest_patch - do while ( clmpatch_number /= edpatch_pointer%clm_pno ) - edpatch_pointer => edpatch_pointer%younger - end do - - end function map_clmpatch_to_edpatch - - !-------------------------------------------------------------------------------------! - subroutine set_root_fraction( this , depth_gl) - ! - ! !DESCRIPTION: - ! Calculates the fractions of the root biomass in each layer for each pft. - ! - ! !USES: - use PatchType , only : clmpatch => patch - use pftconMod , only : pftcon - ! - ! !ARGUMENTS - class(ed_patch_type) :: this - real(r8),intent(in) :: depth_gl(0:cp_numlevgrnd) - ! - ! !LOCAL VARIABLES: - integer :: lev,p,c,ft - !---------------------------------------------------------------------- - - do ft = 1,numpft_ed - do lev = 1, cp_numlevgrnd - this%rootfr_ft(ft,lev) = 0._r8 - enddo - - do lev = 1, cp_numlevsoil-1 - this%rootfr_ft(ft,lev) = .5_r8*( & - exp(-pftcon%roota_par(ft) * depth_gl(lev-1)) & - + exp(-pftcon%rootb_par(ft) * depth_gl(lev-1)) & - - exp(-pftcon%roota_par(ft) * depth_gl(lev)) & - - exp(-pftcon%rootb_par(ft) * depth_gl(lev))) - end do - end do - - end subroutine set_root_fraction - - - ! ===================================================================================== - - end module EDTypesMod diff --git a/components/clm/src/ED/main/EDVecCohortType.F90 b/components/clm/src/ED/main/EDVecCohortType.F90 deleted file mode 100644 index feefd13502..0000000000 --- a/components/clm/src/ED/main/EDVecCohortType.F90 +++ /dev/null @@ -1,42 +0,0 @@ -module EDVecCohortType - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! cohortype. mimics CLM vector subgrid types. For now this holds ED data that is - ! necessary in the rest of CLM - ! - ! !USES: - - ! !PUBLIC TYPES: - implicit none - public - ! - type, public :: ed_vec_cohort_type - integer :: cohorts_per_column - integer , pointer :: column(:) !index into column level quantities - contains - procedure, public :: Init - end type ed_vec_cohort_type - - type(ed_vec_cohort_type), public :: ed_vec_cohort - !------------------------------------------------------------------------ - -contains - - !------------------------------------------------------------------------ - subroutine Init(this, beg, end) - ! - ! !USES: - ! - ! !ARGUMENTS: - class(ed_vec_cohort_type) :: this - integer, intent(in) :: beg, end - !------------------------------------------------------------------------ - - ! FIX(SPM,032414) pull this out and put in own ED source - - allocate(this%column(beg:end)) - - end subroutine Init - -end module EDVecCohortType diff --git a/components/clm/src/ED/main/FatesConstantsMod.F90 b/components/clm/src/ED/main/FatesConstantsMod.F90 index bf1f7e562f..9a9896d206 100644 --- a/components/clm/src/ED/main/FatesConstantsMod.F90 +++ b/components/clm/src/ED/main/FatesConstantsMod.F90 @@ -68,6 +68,4 @@ module FatesConstantsMod ! PI real(fates_r8), parameter :: pi_const = 3.14159265359_fates_r8 - - end module FatesConstantsMod diff --git a/components/clm/src/ED/main/FatesGlobals.F90 b/components/clm/src/ED/main/FatesGlobals.F90 index 0b4e11e7f3..3d4d561c7a 100644 --- a/components/clm/src/ED/main/FatesGlobals.F90 +++ b/components/clm/src/ED/main/FatesGlobals.F90 @@ -8,36 +8,20 @@ module FatesGlobals implicit none - - public :: FatesGlobalsInit public :: fates_log public :: fates_global_verbose - public :: SetFatesTime - - ! ------------------------------------------------------------------------------------- - ! Timing Variables - ! It is assumed that all of the sites on a given machine will be synchronous. - ! It is also assumed that the HLM will control time. - ! ------------------------------------------------------------------------------------- - integer, protected :: current_year ! Current year - integer, protected :: current_month ! month of year - integer, protected :: current_day ! day of month - integer, protected :: current_tod ! time of day (seconds past 0Z) - integer, protected :: current_date ! time of day (seconds past 0Z) - integer, protected :: reference_date ! YYYYMMDD - real(r8), protected :: model_day ! elapsed days between current date and reference - integer, protected :: day_of_year ! The integer day of the year - integer, protected :: days_per_year ! The HLM controls time, some HLMs may include a leap - real(r8), protected :: freq_day ! fraction of year for daily time-step (1/days_per_year) - ! this is a frequency integer, private :: fates_log_ logical, private :: fates_global_verbose_ contains - subroutine FatesGlobalsInit(log_unit, global_verbose) + + + ! ===================================================================================== + + subroutine FatesGlobalsInit(log_unit,global_verbose) implicit none @@ -49,6 +33,8 @@ subroutine FatesGlobalsInit(log_unit, global_verbose) end subroutine FatesGlobalsInit + ! ===================================================================================== + integer function fates_log() fates_log = fates_log_ end function fates_log @@ -57,39 +43,28 @@ logical function fates_global_verbose() fates_global_verbose = fates_global_verbose_ end function fates_global_verbose - ! ===================================================================================== + subroutine fates_endrun(msg) + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Abort the model for abnormal termination + ! This subroutine was derived from CLM's + ! endrun_vanilla() in abortutils.F90 + ! + use shr_sys_mod , only: shr_sys_abort + ! + ! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: msg ! string to be printed + !----------------------------------------------------------------------- - subroutine SetFatesTime(current_year_in, current_month_in, & - current_day_in, current_tod_in, & - current_date_in, reference_date_in, & - model_day_in, day_of_year_in, & - days_per_year_in, freq_day_in) - - ! This subroutine should be called directly from the HLM - - integer, intent(in) :: current_year_in - integer, intent(in) :: current_month_in - integer, intent(in) :: current_day_in - integer, intent(in) :: current_tod_in - integer, intent(in) :: current_date_in - integer, intent(in) :: reference_date_in - real(r8), intent(in) :: model_day_in - integer, intent(in) :: day_of_year_in - integer, intent(in) :: days_per_year_in - real(r8), intent(in) :: freq_day_in - - current_year = current_year_in - current_month = current_month_in - current_day = current_day_in - current_tod = current_tod_in - current_date = current_date_in - reference_date = reference_date_in - model_day = model_day_in - day_of_year = day_of_year_in - days_per_year = days_per_year_in - freq_day = freq_day_in - - end subroutine SetFatesTime + write(fates_log(),*)'ENDRUN:', msg + call shr_sys_abort() + + end subroutine fates_endrun + + ! ===================================================================================== + end module FatesGlobals diff --git a/components/clm/src/ED/main/FatesHistoryInterfaceMod.F90 b/components/clm/src/ED/main/FatesHistoryInterfaceMod.F90 index 568b9950d4..ba467e177a 100644 --- a/components/clm/src/ED/main/FatesHistoryInterfaceMod.F90 +++ b/components/clm/src/ED/main/FatesHistoryInterfaceMod.F90 @@ -8,7 +8,7 @@ module FatesHistoryInterfaceMod use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesHistoryVariableType, only : fates_history_variable_type - use EDTypesMod , only : cp_hio_ignore_val + use FatesInterfaceMod, only : hlm_hio_ignore_val ! FIXME(bja, 2016-10) need to remove CLM dependancy use pftconMod , only : pftcon @@ -531,8 +531,8 @@ end subroutine flush_hvars subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype, & hlms, flushval, upfreq, ivar, initialize, index) - use FatesUtilsMod, only : check_hlm_list - use EDTypesMod, only : cp_hlm_name + use FatesUtilsMod, only : check_hlm_list + use FatesInterfaceMod, only : hlm_name implicit none @@ -562,7 +562,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype logical :: write_var - write_var = check_hlm_list(trim(hlms), trim(cp_hlm_name)) + write_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( write_var ) then ivar = ivar+1 index = ivar @@ -1698,52 +1698,52 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='NEP', units='gC/m^2/s', & long='net ecosystem production', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_fire_c_to_atm_si ) call this%set_history_var(vname='NBP', units='gC/m^2/s', & long='net biosphere production', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nbp_si ) call this%set_history_var(vname='TOTECOSYSC', units='gC/m^2', & long='total ecosystem carbon', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_totecosysc_si ) call this%set_history_var(vname='CBALANCE_ERROR_ED', units='gC/m^2/s', & long='total carbon balance error on ED side', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_fates_si ) call this%set_history_var(vname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & long='total carbon balance error on HLMs BGC side', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_bgc_si ) call this%set_history_var(vname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & long='total carbon balance error total', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_tot_si ) call this%set_history_var(vname='BIOMASS_STOCK_COL', units='gC/m^2', & long='total ED biomass carbon at the column level', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_biomass_stock_si ) call this%set_history_var(vname='ED_LITTER_STOCK_COL', units='gC/m^2', & long='total ED litter carbon at the column level', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_litter_stock_si ) call this%set_history_var(vname='CWD_STOCK_COL', units='gC/m^2', & long='total CWD carbon at the column level', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=cp_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cwd_stock_si ) diff --git a/components/clm/src/ED/main/FatesInterfaceMod.F90 b/components/clm/src/ED/main/FatesInterfaceMod.F90 index 272bbfbc38..79279454d7 100644 --- a/components/clm/src/ED/main/FatesInterfaceMod.F90 +++ b/components/clm/src/ED/main/FatesInterfaceMod.F90 @@ -9,24 +9,118 @@ module FatesInterfaceMod ! which is allocated by thread ! ------------------------------------------------------------------------------------ - use EDtypesMod , only : ed_site_type - use EDtypesMod , only : maxPatchesPerCol - use EDtypesMod , only : cp_nclmax - use EDtypesMod , only : cp_numSWb - use EDtypesMod , only : cp_numlevgrnd - use EDtypesMod , only : cp_maxSWb - use EDtypesMod , only : cp_numlevdecomp - use EDtypesMod , only : cp_numlevdecomp_full - use EDtypesMod , only : cp_hlm_name - use EDtypesMod , only : cp_hio_ignore_val - use EDtypesMod , only : cp_numlevsoil - use EDtypesMod , only : cp_masterproc - use FatesConstantsMod , only : r8 => fates_r8 + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : maxPatchesPerSite + use EDTypesMod , only : maxCohortsPerPatch + use EDTypesMod , only : maxSWb + use EDTypesMod , only : nclmax + use EDTypesMod , only : nlevcan + use EDTypesMod , only : numpft_ed + use FatesConstantsMod , only : r8 => fates_r8 + use FatesGlobals , only : fates_global_verbose + use FatesGlobals , only : fates_log + implicit none + public :: FatesInterfaceInit + public :: set_fates_ctrlparms + public :: SetFatesTime + public :: set_fates_global_elements + + ! ------------------------------------------------------------------------------------- + ! Parameters that are dictated by the Host Land Model + ! THESE ARE NOT DYNAMIC. SHOULD BE SET ONCE DURING INTIALIZATION. + ! ------------------------------------------------------------------------------------- + + + integer, protected :: hlm_numSWb ! Number of broad-bands in the short-wave radiation + ! specturm to track + ! (typically 2 as a default, VIS/NIR, in ED variants <2016) + + integer, protected :: hlm_numlevgrnd ! Number of ground layers + integer, protected :: hlm_numlevsoil ! Number of soil layers + + + integer, protected :: hlm_numlevdecomp_full ! Number of GROUND layers for the purposes + ! of biogeochemistry; can be either 1 + ! or the total number of soil layers + ! (includes bedrock) + + + integer, protected :: hlm_numlevdecomp ! Number of SOIL layers for the purposes of + ! biogeochemistry; can be either 1 or the total + ! number of soil layers + + + character(len=16), protected :: hlm_name ! This character string passed by the HLM + ! is used during the processing of IO data, + ! so that FATES knows which IO variables it + ! should prepare. For instance + ! ATS, ALM and CLM will only want variables + ! specficially packaged for them. + ! This string sets which filter is enacted. + + + real(r8), protected :: hlm_hio_ignore_val ! This value can be flushed to history + ! diagnostics, such that the + ! HLM will interpret that the value should not + ! be included in the average. + + integer, protected :: hlm_masterproc ! Is this the master processor, typically useful + ! for knowing if the current machine should be + ! printing out messages to the logs or terminals + ! 1 = TRUE (is master) 0 = FALSE (is not master) + + + ! ------------------------------------------------------------------------------------- + ! Parameters that are dictated by FATES and known to be required knowledge + ! needed by the HLMs + ! ------------------------------------------------------------------------------------- + + ! Variables mostly used for dimensioning host land model (HLM) array spaces + + integer, protected :: fates_maxElementsPerPatch ! maxElementsPerPatch is the value that is ultimately + ! used to set the size of the largest arrays necessary + ! in things like restart files (probably hosted by the + ! HLM). The size of these arrays are not a parameter + ! because it is simply the maximum of several different + ! dimensions. It is possible that this would be the + ! maximum number of cohorts per patch, but + ! but it could be other things. + + integer, protected :: fates_maxElementsPerSite ! This is the max number of individual items one can store per + ! each grid cell and effects the striding in the ED restart + ! data as some fields are arrays where each array is + ! associated with one cohort + + + + ! ------------------------------------------------------------------------------------ + ! DYNAMIC BOUNDARY CONDITIONS ! ------------------------------------------------------------------------------------ - ! Notes on types + + + ! ------------------------------------------------------------------------------------- + ! Scalar Timing Variables + ! It is assumed that all of the sites on a given machine will be synchronous. + ! It is also assumed that the HLM will control time. + ! ------------------------------------------------------------------------------------- + integer, protected :: hlm_current_year ! Current year + integer, protected :: hlm_current_month ! month of year + integer, protected :: hlm_current_day ! day of month + integer, protected :: hlm_current_tod ! time of day (seconds past 0Z) + integer, protected :: hlm_current_date ! time of day (seconds past 0Z) + integer, protected :: hlm_reference_date ! YYYYMMDD + real(r8), protected :: hlm_model_day ! elapsed days between current date and ref + integer, protected :: hlm_day_of_year ! The integer day of the year + integer, protected :: hlm_days_per_year ! The HLM controls time, some HLMs may + ! include a leap + real(r8), protected :: hlm_freq_day ! fraction of year for daily time-step + ! (1/days_per_year_, this is a frequency + + ! ------------------------------------------------------------------------------------- + ! Structured Boundary Conditions (SITE/PATCH SCALE) ! For floating point arrays, it is sometimes the convention to define the arrays as ! POINTER instead of ALLOCATABLE. This usually achieves the same result with subtle ! differences. POINTER arrays can point to scalar values, discontinuous array slices @@ -38,8 +132,9 @@ module FatesInterfaceMod ! _pa means patch dimensions ! _rb means radiation band ! ------------------------------------------------------------------------------------ - - + + + type, public :: bc_in_type @@ -317,14 +412,13 @@ module FatesInterfaceMod end type fates_interface_type - public :: FatesInterfaceInit - public :: set_fates_ctrlparms + contains ! ==================================================================================== - subroutine FatesInterfaceInit(log_unit, global_verbose) + subroutine FatesInterfaceInit(log_unit,global_verbose) use FatesGlobals, only : FatesGlobalsInit @@ -333,7 +427,7 @@ subroutine FatesInterfaceInit(log_unit, global_verbose) integer, intent(in) :: log_unit logical, intent(in) :: global_verbose - call FatesGlobalsInit(log_unit, global_verbose) + call FatesGlobalsInit(log_unit,global_verbose) end subroutine FatesInterfaceInit @@ -373,46 +467,46 @@ subroutine allocate_bcin(bc_in) ! Allocate input boundaries ! Vegetation Dynamics - allocate(bc_in%t_veg24_pa(maxPatchesPerCol)) + allocate(bc_in%t_veg24_pa(maxPatchesPerSite)) - allocate(bc_in%wind24_pa(maxPatchesPerCol)) - allocate(bc_in%relhumid24_pa(maxPatchesPerCol)) - allocate(bc_in%precip24_pa(maxPatchesPerCol)) + allocate(bc_in%wind24_pa(maxPatchesPerSite)) + allocate(bc_in%relhumid24_pa(maxPatchesPerSite)) + allocate(bc_in%precip24_pa(maxPatchesPerSite)) ! Radiation - allocate(bc_in%solad_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_in%solai_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_in%solad_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_in%solai_parb(maxPatchesPerSite,hlm_numSWb)) ! Hydrology - allocate(bc_in%smp_gl(cp_numlevgrnd)) - allocate(bc_in%eff_porosity_gl(cp_numlevgrnd)) - allocate(bc_in%watsat_gl(cp_numlevgrnd)) - allocate(bc_in%tempk_gl(cp_numlevgrnd)) - allocate(bc_in%h2o_liqvol_gl(cp_numlevgrnd)) + allocate(bc_in%smp_gl(hlm_numlevgrnd)) + allocate(bc_in%eff_porosity_gl(hlm_numlevgrnd)) + allocate(bc_in%watsat_gl(hlm_numlevgrnd)) + allocate(bc_in%tempk_gl(hlm_numlevgrnd)) + allocate(bc_in%h2o_liqvol_gl(hlm_numlevgrnd)) ! Photosynthesis - allocate(bc_in%filter_photo_pa(maxPatchesPerCol)) - allocate(bc_in%dayl_factor_pa(maxPatchesPerCol)) - allocate(bc_in%esat_tv_pa(maxPatchesPerCol)) - allocate(bc_in%eair_pa(maxPatchesPerCol)) - allocate(bc_in%oair_pa(maxPatchesPerCol)) - allocate(bc_in%cair_pa(maxPatchesPerCol)) - allocate(bc_in%rb_pa(maxPatchesPerCol)) - allocate(bc_in%t_veg_pa(maxPatchesPerCol)) - allocate(bc_in%tgcm_pa(maxPatchesPerCol)) - allocate(bc_in%t_soisno_gl(cp_numlevgrnd)) + allocate(bc_in%filter_photo_pa(maxPatchesPerSite)) + allocate(bc_in%dayl_factor_pa(maxPatchesPerSite)) + allocate(bc_in%esat_tv_pa(maxPatchesPerSite)) + allocate(bc_in%eair_pa(maxPatchesPerSite)) + allocate(bc_in%oair_pa(maxPatchesPerSite)) + allocate(bc_in%cair_pa(maxPatchesPerSite)) + allocate(bc_in%rb_pa(maxPatchesPerSite)) + allocate(bc_in%t_veg_pa(maxPatchesPerSite)) + allocate(bc_in%tgcm_pa(maxPatchesPerSite)) + allocate(bc_in%t_soisno_gl(hlm_numlevgrnd)) ! Canopy Radiation - allocate(bc_in%filter_vegzen_pa(maxPatchesPerCol)) - allocate(bc_in%coszen_pa(maxPatchesPerCol)) - allocate(bc_in%albgr_dir_rb(cp_numSWb)) - allocate(bc_in%albgr_dif_rb(cp_numSWb)) + allocate(bc_in%filter_vegzen_pa(maxPatchesPerSite)) + allocate(bc_in%coszen_pa(maxPatchesPerSite)) + allocate(bc_in%albgr_dir_rb(hlm_numSWb)) + allocate(bc_in%albgr_dif_rb(hlm_numSWb)) ! Carbon Balance Checking ! (snow-depth and snow fraction are site level and not vectors) ! Ground layer structure - allocate(bc_in%depth_gl(0:cp_numlevgrnd)) + allocate(bc_in%depth_gl(0:hlm_numlevgrnd)) return end subroutine allocate_bcin @@ -428,43 +522,43 @@ subroutine allocate_bcout(bc_out) ! Radiation - allocate(bc_out%fsun_pa(maxPatchesPerCol)) - allocate(bc_out%laisun_pa(maxPatchesPerCol)) - allocate(bc_out%laisha_pa(maxPatchesPerCol)) + allocate(bc_out%fsun_pa(maxPatchesPerSite)) + allocate(bc_out%laisun_pa(maxPatchesPerSite)) + allocate(bc_out%laisha_pa(maxPatchesPerSite)) ! Hydrology - allocate(bc_out%active_suction_gl(cp_numlevgrnd)) - allocate(bc_out%rootr_pagl(maxPatchesPerCol,cp_numlevgrnd)) - allocate(bc_out%btran_pa(maxPatchesPerCol)) + allocate(bc_out%active_suction_gl(hlm_numlevgrnd)) + allocate(bc_out%rootr_pagl(maxPatchesPerSite,hlm_numlevgrnd)) + allocate(bc_out%btran_pa(maxPatchesPerSite)) ! Photosynthesis - allocate(bc_out%rssun_pa(maxPatchesPerCol)) - allocate(bc_out%rssha_pa(maxPatchesPerCol)) + allocate(bc_out%rssun_pa(maxPatchesPerSite)) + allocate(bc_out%rssha_pa(maxPatchesPerSite)) ! Canopy Radiation - allocate(bc_out%albd_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%albi_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%fabd_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%fabi_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%ftdd_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%ftid_parb(maxPatchesPerCol,cp_numSWb)) - allocate(bc_out%ftii_parb(maxPatchesPerCol,cp_numSWb)) + allocate(bc_out%albd_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%albi_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%fabd_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%fabi_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%ftdd_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%ftid_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%ftii_parb(maxPatchesPerSite,hlm_numSWb)) ! biogeochemistry - allocate(bc_out%FATES_c_to_litr_lab_c_col(cp_numlevdecomp_full)) - allocate(bc_out%FATES_c_to_litr_cel_c_col(cp_numlevdecomp_full)) - allocate(bc_out%FATES_c_to_litr_lig_c_col(cp_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_lab_c_col(hlm_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_cel_c_col(hlm_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_lig_c_col(hlm_numlevdecomp_full)) ! Canopy Structure - allocate(bc_out%elai_pa(maxPatchesPerCol)) - allocate(bc_out%esai_pa(maxPatchesPerCol)) - allocate(bc_out%tlai_pa(maxPatchesPerCol)) - allocate(bc_out%tsai_pa(maxPatchesPerCol)) - allocate(bc_out%htop_pa(maxPatchesPerCol)) - allocate(bc_out%hbot_pa(maxPatchesPerCol)) - allocate(bc_out%canopy_fraction_pa(maxPatchesPerCol)) - allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerCol)) + allocate(bc_out%elai_pa(maxPatchesPerSite)) + allocate(bc_out%esai_pa(maxPatchesPerSite)) + allocate(bc_out%tlai_pa(maxPatchesPerSite)) + allocate(bc_out%tsai_pa(maxPatchesPerSite)) + allocate(bc_out%htop_pa(maxPatchesPerSite)) + allocate(bc_out%hbot_pa(maxPatchesPerSite)) + allocate(bc_out%canopy_fraction_pa(maxPatchesPerSite)) + allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerSite)) return @@ -540,13 +634,76 @@ subroutine zero_bcs(this,s) return end subroutine zero_bcs - - ! ==================================================================================== - subroutine set_fates_ctrlparms(tag,ival,rval,cval) + + ! =================================================================================== + + subroutine set_fates_global_elements(use_fates) + implicit none + + logical,intent(in) :: use_fates ! Is fates turned on? + + if (use_fates) then + + fates_maxElementsPerPatch = max(maxCohortsPerPatch, & + numpft_ed * nclmax * nlevcan) + + fates_maxElementsPerSite = maxPatchesPerSite * fates_maxElementsPerPatch + + else + ! If we are not using FATES, the cohort dimension is still + ! going to be initialized, lets set it to the smallest value + ! possible so that the dimensioning info takes up little space + + fates_maxElementsPerPatch = 1 + + fates_maxElementsPerSite = 1 + + + end if + + + end subroutine set_fates_global_elements + + ! =================================================================================== + + subroutine SetFatesTime(current_year_in, current_month_in, & + current_day_in, current_tod_in, & + current_date_in, reference_date_in, & + model_day_in, day_of_year_in, & + days_per_year_in, freq_day_in) + + ! This subroutine should be called directly from the HLM + + integer, intent(in) :: current_year_in + integer, intent(in) :: current_month_in + integer, intent(in) :: current_day_in + integer, intent(in) :: current_tod_in + integer, intent(in) :: current_date_in + integer, intent(in) :: reference_date_in + real(r8), intent(in) :: model_day_in + integer, intent(in) :: day_of_year_in + integer, intent(in) :: days_per_year_in + real(r8), intent(in) :: freq_day_in + + hlm_current_year = current_year_in + hlm_current_month = current_month_in + hlm_current_day = current_day_in + hlm_current_tod = current_tod_in + hlm_current_date = current_date_in + hlm_reference_date = reference_date_in + hlm_model_day = model_day_in + hlm_day_of_year = day_of_year_in + hlm_days_per_year = days_per_year_in + hlm_freq_day = freq_day_in + + end subroutine SetFatesTime + + ! ==================================================================================== + + subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! --------------------------------------------------------------------------------- - ! INTERF-TODO: NEED ALLOWANCES FOR REAL AND CHARACTER ARGS.. ! Certain model control parameters and dimensions used by FATES are dictated by ! the the driver or the host mode. To see which parameters should be filled here ! please also look at the ctrl_parms_type in FATESTYpeMod, in the section listing @@ -568,8 +725,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! RGK-2016 ! --------------------------------------------------------------------------------- - use FatesGlobals, only : fates_log, fates_global_verbose - ! Arguments integer, optional, intent(in) :: ival real(r8), optional, intent(in) :: rval @@ -587,18 +742,18 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if (fates_global_verbose()) then write(fates_log(), *) 'Flushing FATES control parameters prior to transfer from host' end if - cp_numSwb = unset_int - cp_numlevgrnd = unset_int - cp_numlevsoil = unset_int - cp_numlevdecomp_full = unset_int - cp_numlevdecomp = unset_int - cp_hlm_name = 'unset' - cp_hio_ignore_val = unset_double - cp_masterproc = unset_int + hlm_numSwb = unset_int + hlm_numlevgrnd = unset_int + hlm_numlevsoil = unset_int + hlm_numlevdecomp_full = unset_int + hlm_numlevdecomp = unset_int + hlm_name = 'unset' + hlm_hio_ignore_val = unset_double + hlm_masterproc = unset_int case('check_allset') - if(cp_numSWb .eq. unset_int) then + if(hlm_numSWb .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: num_sw_rad_bbands' end if @@ -606,28 +761,28 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(cp_masterproc .eq. unset_int) then + if(hlm_masterproc .eq. unset_int) then if (fates_global_verbose()) then - write(fates_log(), *) 'FATES parameter unset: cp_masterproc' + write(fates_log(), *) 'FATES parameter unset: hlm_masterproc' end if ! INTERF-TODO: FATES NEEDS INTERNAL end_run ! end_run('MESSAGE') end if - if(cp_numSWb > cp_maxSWb) then + if(hlm_numSWb > maxSWb) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' - write(fates_log(), *) 'for some scratch-space, cp_maxSWb' + write(fates_log(), *) 'for some scratch-space, maxSWb' write(fates_log(), *) 'it defaults to 2, but can be increased as needed' write(fates_log(), *) 'your driver or host model is intending to drive' - write(fates_log(), *) 'FATES with:',cp_numSWb,' bands.' - write(fates_log(), *) 'please increase cp_maxSWb in EDTypes to match' + write(fates_log(), *) 'FATES with:',hlm_numSWb,' bands.' + write(fates_log(), *) 'please increase maxSWb in EDTypes to match' write(fates_log(), *) 'or exceed this value' end if ! end_run('MESSAGE') end if - if(cp_numlevgrnd .eq. unset_int) then + if(hlm_numlevgrnd .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' end if @@ -635,7 +790,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(cp_numlevsoil .eq. unset_int) then + if(hlm_numlevsoil .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' end if @@ -643,7 +798,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(cp_numlevdecomp_full .eq. unset_int) then + if(hlm_numlevdecomp_full .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp_full' end if @@ -651,7 +806,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(cp_numlevdecomp .eq. unset_int) then + if(hlm_numlevdecomp .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp' end if @@ -659,7 +814,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if(trim(cp_hlm_name) .eq. 'unset') then + if(trim(hlm_name) .eq. 'unset') then if (fates_global_verbose()) then write(fates_log(),*) 'FATES dimension/parameter unset: hlm_name' end if @@ -667,7 +822,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if - if( abs(cp_hio_ignore_val-unset_double)<1e-10 ) then + if( abs(hlm_hio_ignore_val-unset_double)<1e-10 ) then if (fates_global_verbose()) then write(fates_log(),*) 'FATES dimension/parameter unset: hio_ignore' end if @@ -686,37 +841,37 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) select case (trim(tag)) case('masterproc') - cp_masterproc = ival + hlm_masterproc = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering masterproc = ',ival,' to FATES' end if case('num_sw_bbands') - cp_numSwb = ival + hlm_numSwb = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_sw_bbands = ',ival,' to FATES' end if case('num_lev_ground') - cp_numlevgrnd = ival + hlm_numlevgrnd = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' end if case('num_lev_soil') - cp_numlevsoil = ival + hlm_numlevsoil = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' end if case('num_levdecomp_full') - cp_numlevdecomp_full = ival + hlm_numlevdecomp_full = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_levdecomp_full = ',ival,' to FATES' end if case('num_levdecomp') - cp_numlevdecomp = ival + hlm_numlevdecomp = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_levdecomp = ',ival,' to FATES' end if @@ -733,7 +888,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if(present(rval))then select case (trim(tag)) case ('hio_ignore_val') - cp_hio_ignore_val = rval + hlm_hio_ignore_val = rval if (fates_global_verbose()) then write(fates_log(),*) 'Transfering hio_ignore_val = ',rval,' to FATES' end if @@ -749,7 +904,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) select case (trim(tag)) case('hlm_name') - cp_hlm_name = trim(cval) + hlm_name = trim(cval) if (fates_global_verbose()) then write(fates_log(),*) 'Transfering the HLM name = ',trim(cval) end if @@ -768,5 +923,4 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end subroutine set_fates_ctrlparms - end module FatesInterfaceMod diff --git a/components/clm/src/ED/main/FatesRestartInterfaceMod.F90 b/components/clm/src/ED/main/FatesRestartInterfaceMod.F90 index 18b77bc6cf..6f903da993 100644 --- a/components/clm/src/ED/main/FatesRestartInterfaceMod.F90 +++ b/components/clm/src/ED/main/FatesRestartInterfaceMod.F90 @@ -6,14 +6,14 @@ module FatesRestartInterfaceMod use FatesConstantsMod , only : fates_short_string_length use FatesConstantsMod , only : fates_long_string_length use FatesGlobals , only : fates_log - + use FatesGlobals , only : endrun => fates_endrun use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type - ! TO BE REMOVED WHEN ERROR HANDLINE IS ADDED (rgk 11-2016) + ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg - use abortutils , only : endrun + implicit none @@ -854,7 +854,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & hlms,initialize,ivar,index) use FatesUtilsMod, only : check_hlm_list - use EDTypesMod, only : cp_hlm_name + use FatesInterfaceMod, only : hlm_name ! arguments class(fates_restart_interface_type) :: this @@ -879,7 +879,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & logical :: use_var - use_var = check_hlm_list(trim(hlms), trim(cp_hlm_name)) + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( use_var ) then @@ -905,14 +905,13 @@ end subroutine set_restart_var subroutine set_restart_vectors(this,nc,nsites,sites) - use EDTypesMod, only : cp_nclmax - use EDTypesMod, only : cp_nlevcan - use EDTypesMod, only : maxCohortsPerPatch + use EDTypesMod, only : nclmax + use EDTypesMod, only : nlevcan + use FatesInterfaceMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numpft_ed use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type - use EDTypesMod, only : cohorts_per_col use EDTypesMod, only : ncwd use EDTypesMod, only : numWaterMem @@ -1148,7 +1147,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) if ( DEBUG ) then write(fates_log(),*) 'offsetNumCohorts III ' & - ,io_idx_co,cohorts_per_col, cohortsperpatch + ,io_idx_co,cohortsperpatch endif ! ! deal with patch level fields of arrays here @@ -1169,18 +1168,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_cwd = io_idx_pa_cwd + 1 end do - do i = 1,cp_nclmax ! cp_nclmax currently 2 + do i = 1,nclmax ! nclmax currently 2 rio_spread_pacl(io_idx_pa_cl) = cpatch%spread(i) io_idx_pa_cl = io_idx_pa_cl + 1 end do if ( DEBUG ) write(fates_log(),*) 'CLTV io_idx_pa_sunz 1 ',io_idx_pa_sunz - if ( DEBUG ) write(fates_log(),*) 'CLTV 1186 ',cp_nlevcan,numpft_ed,cp_nclmax + if ( DEBUG ) write(fates_log(),*) 'CLTV 1186 ',nlevcan,numpft_ed,nclmax - do k = 1,cp_nlevcan ! cp_nlevcan currently 40 + do k = 1,nlevcan ! nlevcan currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,cp_nclmax ! cp_nclmax currently 2 + do i = 1,nclmax ! nclmax currently 2 rio_fsun_paclftls(io_idx_pa_sunz) = cpatch%f_sun(i,j,k) rio_fabd_sun_z_paclftls(io_idx_pa_sunz) = cpatch%fabd_sun_z(i,j,k) rio_fabi_sun_z_paclftls(io_idx_pa_sunz) = cpatch%fabi_sun_z(i,j,k) @@ -1196,10 +1195,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch - io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch ! reset counters so that they are all advanced evenly. Currently - ! the offset is 10, the max of numpft_ed, ncwd, cp_nclmax, + ! the offset is 10, the max of numpft_ed, ncwd, nclmax, ! io_idx_si_wmem and the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st @@ -1209,7 +1208,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) if ( DEBUG ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st - write(fates_log(),*) 'CLTV cohorts_per_col ', cohorts_per_col write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if @@ -1275,9 +1273,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : ncwd - use EDTypesMod, only : cp_nlevcan - use EDTypesMod, only : cp_nclmax - use EDTypesMod, only : maxCohortsPerPatch + use EDTypesMod, only : nlevcan + use EDTypesMod, only : nclmax + use FatesInterfaceMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numpft_ed use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch @@ -1300,7 +1298,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) type(ed_cohort_type), allocatable :: temp_cohort real(r8) :: cwd_ag_local(ncwd) real(r8) :: cwd_bg_local(ncwd) - real(r8) :: spread_local(cp_nclmax) + real(r8) :: spread_local(nclmax) real(r8) :: leaf_litter_local(numpft_ed) real(r8) :: root_litter_local(numpft_ed) real(r8) :: patch_age @@ -1453,7 +1451,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites ) endif - io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch enddo ! ends loop over idx_pa @@ -1471,10 +1469,9 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ed_patch_type use EDTypesMod, only : numpft_ed use EDTypesMod, only : ncwd - use EDTypesMod, only : cp_nlevcan - use EDTypesMod, only : cp_nclmax - use EDTypesMod, only : maxCohortsPerPatch - use EDTypesMod, only : cohorts_per_col + use EDTypesMod, only : nlevcan + use EDTypesMod, only : nclmax + use FatesInterfaceMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numWaterMem ! !ARGUMENTS: @@ -1699,7 +1696,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( DEBUG ) then write(fates_log(),*) 'CVTL III ' & - ,io_idx_co,cohorts_per_col, cohortsperpatch + ,io_idx_co,cohortsperpatch endif ! ! deal with patch level fields of arrays here @@ -1721,16 +1718,16 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_cwd = io_idx_pa_cwd + 1 enddo - do i = 1,cp_nclmax ! cp_nclmax currently 2 + do i = 1,nclmax ! nclmax currently 2 cpatch%spread(i) = rio_spread_pacl(io_idx_pa_cl) io_idx_pa_cl = io_idx_pa_cl + 1 enddo if ( DEBUG ) write(fates_log(),*) 'CVTL io_idx_pa_sunz 1 ',io_idx_pa_sunz - do k = 1,cp_nlevcan ! cp_nlevcan currently 40 + do k = 1,nlevcan ! nlevcan currently 40 do j = 1,numpft_ed ! numpft_ed currently 2 - do i = 1,cp_nclmax ! cp_nclmax currently 2 + do i = 1,nclmax ! nclmax currently 2 cpatch%f_sun(i,j,k) = rio_fsun_paclftls(io_idx_pa_sunz) cpatch%fabd_sun_z(i,j,k) = rio_fabd_sun_z_paclftls(io_idx_pa_sunz) cpatch%fabi_sun_z(i,j,k) = rio_fabi_sun_z_paclftls(io_idx_pa_sunz) @@ -1746,7 +1743,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - io_idx_co_1st = io_idx_co_1st + maxCohortsPerPatch + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st @@ -1757,7 +1754,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( DEBUG ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st - write(fates_log(),*) 'CVTL cohorts_per_col ', cohorts_per_col write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts end if diff --git a/components/clm/src/main/clm_initializeMod.F90 b/components/clm/src/main/clm_initializeMod.F90 index 1c54d2596b..7545c2425b 100644 --- a/components/clm/src/main/clm_initializeMod.F90 +++ b/components/clm/src/main/clm_initializeMod.F90 @@ -22,7 +22,8 @@ module clm_initializeMod use PatchType , only : patch ! instance use reweightMod , only : reweight_wrapup use filterMod , only : allocFilters, filter - use EDVecCohortType , only : ed_vec_cohort ! instance, used for domain decomp + use FatesInterfaceMod, only : set_fates_global_elements + use clm_instMod ! implicit none @@ -177,6 +178,22 @@ subroutine initialize1( ) call surfrd_get_data(begg, endg, ldomain, fsurdat) + ! ------------------------------------------------------------------------ + ! Ask Fates to evaluate its own dimensioning needs. + ! This determines the total amount of space it requires in its largest + ! dimension. We are currently calling that the "cohort" dimension, but + ! it is really a utility dimension that captures the models largest + ! size need. + ! Sets: + ! fates_maxElementsPerPatch + ! fates_maxElementsPerSite (where a site is roughly equivalent to a column) + ! + ! (Note: fates_maxELementsPerSite is the critical variable used by CLM + ! to allocate space) + ! ------------------------------------------------------------------------ + + call set_fates_global_elements(use_ed) + ! ------------------------------------------------------------------------ ! Determine decomposition of subgrid scale landunits, columns, patches ! ------------------------------------------------------------------------ @@ -197,11 +214,6 @@ subroutine initialize1( ) call col%Init (bounds_proc%begc, bounds_proc%endc) call patch%Init(bounds_proc%begp, bounds_proc%endp) - if ( use_ed ) then - ! INTERF-TODO: THIS GUY NEEDS TO BE MOVED TO THE INTERFACE - call ed_vec_cohort%Init(bounds_proc%begCohort,bounds_proc%endCohort) - end if - ! Build hierarchy and topological info for derived types ! This is needed here for the following call to decompInit_glcp diff --git a/components/clm/src/main/clm_instMod.F90 b/components/clm/src/main/clm_instMod.F90 index 5c321eec47..309e620e96 100644 --- a/components/clm/src/main/clm_instMod.F90 +++ b/components/clm/src/main/clm_instMod.F90 @@ -395,17 +395,10 @@ subroutine clm_instInit(bounds) call crop_inst%Init(bounds) end if - ! NOTE (MV, 10-24-2014): because ed_allsites is currently passed as arguments to - ! biogeophys routines in the present implementation - it needs to be allocated - - ! if use_ed is not set, then this will not contain any significant memory - ! if use_ed is true, then the actual memory for all of the ED data structures - ! is allocated in the call to EDInitMod - called from clm_initialize - ! NOTE (SPM, 10-27-2015) ... check on deallocation of ed_allsites_inst - ! NOTE (RGK, 04-25-2016) : Updating names, ED is now part of FATES - ! Incrementally changing to ED names to FATES - - call clm_fates%Init(bounds,use_ed) - call clm_fates%init_allocate() + + ! Initialize the Functionaly Assembled Terrestrial Ecosystem Simulator (FATES) + ! + call clm_fates%Init(bounds) deallocate (h2osno_col) deallocate (snow_depth_col) diff --git a/components/clm/src/main/decompInitMod.F90 b/components/clm/src/main/decompInitMod.F90 index e1ff624243..430621d25a 100644 --- a/components/clm/src/main/decompInitMod.F90 +++ b/components/clm/src/main/decompInitMod.F90 @@ -16,11 +16,11 @@ module decompInitMod use GridcellType , only : grc use LandunitType , only : lun use ColumnType , only : col - use PatchType , only : patch - use EDVecCohortType , only : ed_vec_cohort + use PatchType , only : patch use glcBehaviorMod , only : glc_behavior_type use decompMod use mct_mod + use FatesInterfaceMod, only : fates_maxElementsPerSite ! ! !PUBLIC TYPES: implicit none @@ -726,12 +726,14 @@ subroutine decompInit_glcp(lns,lni,lnj,glc_behavior) call mct_gsMap_init(gsmap_patch_gdc2glo, gindex, mpicom, comp_id, locsize, globsize) deallocate(gindex) + ! FATES gsmap for the cohort/element vector + if ( use_ed ) then - ! ED cohort gsMap allocate(gindex(begCohort:endCohort)) ioff(:) = 0 + ci = begc do coi = begCohort,endCohort - ci = ed_vec_cohort%column(coi) ! function call to get column for this cohort idx + if ( mod(coi, fates_maxElementsPerSite ) == 0 ) ci = ci + 1 gi = col%gridcell(ci) ! convert column into gridcell gindex(coi) = coStart(gi) + ioff(gi) ioff(gi) = ioff(gi) + 1 diff --git a/components/clm/src/main/initGridCellsMod.F90 b/components/clm/src/main/initGridCellsMod.F90 index 8e54576bb9..608fd265f0 100644 --- a/components/clm/src/main/initGridCellsMod.F90 +++ b/components/clm/src/main/initGridCellsMod.F90 @@ -37,7 +37,6 @@ module initGridCellsMod public initGridcells ! initialize sub-grid gridcell mapping ! ! !PRIVATE MEMBER FUNCTIONS: - private set_cohort_decomp private set_landunit_veg_compete private set_landunit_wet_ice_lake private set_landunit_ice_mec @@ -189,11 +188,6 @@ subroutine initGridcells(glc_behavior) end do endif - if ( use_ed ) then - ! cohort decomp - call set_cohort_decomp( bounds_clump=bounds_clump ) - end if - ! Ensure that we have set the expected number of patchs, cols and landunits for this clump SHR_ASSERT(li == bounds_clump%endl, errMsg(sourcefile, __LINE__)) SHR_ASSERT(ci == bounds_clump%endc, errMsg(sourcefile, __LINE__)) @@ -227,33 +221,6 @@ subroutine initGridcells(glc_behavior) end subroutine initGridcells - !------------------------------------------------------------------------ - subroutine set_cohort_decomp ( bounds_clump ) - ! - ! !DESCRIPTION: - ! Set gridcell decomposition for cohorts - ! - use EDTypesMod , only : cohorts_per_col - use EDVecCohortType , only : ed_vec_cohort - ! - ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds_clump - ! - ! !LOCAL VARIABLES: - integer c, ci - !------------------------------------------------------------------------ - - ci = bounds_clump%begc - - do c = bounds_clump%begCohort, bounds_clump%endCohort - - ed_vec_cohort%column(c) = ci - if ( mod(c, cohorts_per_col ) == 0 ) ci = ci + 1 - - end do - - end subroutine set_cohort_decomp - !------------------------------------------------------------------------ subroutine set_landunit_veg_compete (ltype, gi, li, ci, pi) ! diff --git a/components/clm/src/main/subgridMod.F90 b/components/clm/src/main/subgridMod.F90 index 1924edaf68..f4f082feed 100644 --- a/components/clm/src/main/subgridMod.F90 +++ b/components/clm/src/main/subgridMod.F90 @@ -17,7 +17,7 @@ module subgridMod use clm_varctl , only : iulog use clm_instur , only : wt_lunit, urban_valid, wt_cft use glcBehaviorMod , only : glc_behavior_type - use EDtypesMod, only : cohorts_per_col + use FatesInterfaceMod, only : fates_maxElementsPerSite implicit none private @@ -163,7 +163,7 @@ subroutine subgrid_get_info_natveg(gi, ncohorts, npatches, ncols, nlunits) ! based on all columns. ! ------------------------------------------------------------------------- - ncohorts = ncols*cohorts_per_col + ncohorts = ncols*fates_maxElementsPerSite end subroutine subgrid_get_info_natveg diff --git a/components/clm/src/utils/clmfates_interfaceMod.F90 b/components/clm/src/utils/clmfates_interfaceMod.F90 index 77f9667e74..5034c355fd 100644 --- a/components/clm/src/utils/clmfates_interfaceMod.F90 +++ b/components/clm/src/utils/clmfates_interfaceMod.F90 @@ -25,7 +25,7 @@ module CLMFatesInterfaceMod ! ! Conventions: ! keep line widths within 90 spaces - ! DLM acronym = Driving Land Model + ! HLM acronym = Host Land Model ! ! ------------------------------------------------------------------------------------- @@ -77,19 +77,19 @@ module CLMFatesInterfaceMod use shr_log_mod , only : errMsg => shr_log_errMsg ! Used FATES Modules - use FatesInterfaceMod , only : fates_interface_type, & - set_fates_ctrlparms, & - allocate_bcin, & - allocate_bcout + use FatesInterfaceMod , only : fates_interface_type + use FatesInterfaceMod , only : allocate_bcin + use FatesInterfaceMod , only : allocate_bcout - use FatesGlobals , only : SetFatesTime + use FatesInterfaceMod , only : SetFatesTime + use FatesInterfaceMod , only : set_fates_ctrlparms use FatesHistoryInterfaceMod, only : fates_history_interface_type use FatesRestartInterfaceMod, only : fates_restart_interface_type use ChecksBalancesMod , only : SummarizeNetFluxes, FATES_BGC_Carbon_BalanceCheck use EDTypesMod , only : ed_patch_type - use EDtypesMod , only : cp_numlevgrnd + use FatesInterfaceMod , only : hlm_numlevgrnd use EDMainMod , only : ed_ecosystem_dynamics use EDMainMod , only : ed_update_site use EDInitMod , only : zero_site @@ -106,7 +106,7 @@ module CLMFatesInterfaceMod use EDPhysiologyMod , only : flux_into_litter_pools implicit none - + type, public :: f2hmap_type ! This is the associated column index of each FATES site @@ -147,7 +147,6 @@ module CLMFatesInterfaceMod contains procedure, public :: init - procedure, public :: init_allocate procedure, public :: check_hlm_active procedure, public :: restart procedure, public :: init_coldstart @@ -171,13 +170,13 @@ module CLMFatesInterfaceMod __FILE__ contains - - ! ==================================================================================== - subroutine init(this, bounds_proc, use_ed) + ! ==================================================================================== + + subroutine init(this, bounds_proc ) ! --------------------------------------------------------------------------------- - ! This initializes the dlm_fates_interface_type + ! This initializes the hlm_fates_interface_type ! ! sites is the root of the ED state hierarchy (instantaneous info on ! the state of the ecosystem). As such, it governs the connection points between @@ -201,30 +200,29 @@ subroutine init(this, bounds_proc, use_ed) ! Input Arguments class(hlm_fates_interface_type), intent(inout) :: this type(bounds_type),intent(in) :: bounds_proc - logical,intent(in) :: use_ed ! NEEDS TO BE PASSED (FOR NOW) - ! BC THE FATES SITE VECTORS - ! NEED TO BE GENERATED - ! FOR NON-ED AS WELL. SO - ! ONLY PART OF THIS MAY BE OPERATIVE + ! local variables integer :: nclumps ! Number of threads logical :: verbose_output integer :: pass_masterproc + integer :: nc ! thread index + integer :: s ! FATES site index + integer :: c ! HLM column index + integer :: l ! HLM LU index + integer :: g ! HLM grid index + integer, allocatable :: collist (:) + type(bounds_type) :: bounds_clump + integer :: nmaxcol + + if(.not.use_ed) return - if (use_ed) then - - ! Initialize the FATES communicators with the HLM - ! This involves to stages - ! 1) allocate the vectors - ! 2) add the history variables defined in clm_inst to the history machinery - call EDecophysconInit( EDpftvarcon_inst, numpft ) - call param_derived%Init(numpft_ed) - - end if - if(DEBUG)then - write(iulog,*) 'Entering clm_fates%init' - end if + ! Initialize the FATES communicators with the HLM + ! This involves to stages + ! 1) allocate the vectors + ! 2) add the history variables defined in clm_inst to the history machinery + call EDecophysconInit( EDpftvarcon_inst, numpft ) + call param_derived%Init( numpft_ed ) verbose_output = .false. call FatesInterfaceInit(iulog, verbose_output) @@ -260,37 +258,11 @@ subroutine init(this, bounds_proc, use_ed) ! Check through FATES parameters to see if all have been set call set_fates_ctrlparms('check_allset') - if(DEBUG)then write(iulog,*) 'clm_fates%init(): allocating for ',nclumps,' threads' end if - end subroutine init - - ! ==================================================================================== - - subroutine init_allocate(this) - - implicit none - ! Input Arguments - class(hlm_fates_interface_type), intent(inout) :: this - ! local variables - integer :: nclumps ! Number of threads - integer :: nc ! thread index - integer :: s ! FATES site index - integer :: c ! HLM column index - integer :: l ! HLM LU index - integer :: g ! HLM grid index - integer, allocatable :: collist (:) - type(bounds_type) :: bounds_clump - type(bounds_type) :: bounds_proc - integer :: nmaxcol - - if(DEBUG)then - write(iulog,*) 'Entering clm_fates%init_allocate' - end if - nclumps = get_proc_clumps() !$OMP PARALLEL DO PRIVATE (nc,bounds_clump,nmaxcol,s,c,l,g,collist) @@ -381,7 +353,7 @@ subroutine init_allocate(this) do s = 1, this%fates(nc)%nsites c = this%f2hmap(nc)%fcolumn(s) - this%fates(nc)%bc_in(s)%depth_gl(0:cp_numlevgrnd) = col%zi(c,0:cp_numlevgrnd) + this%fates(nc)%bc_in(s)%depth_gl(0:hlm_numlevgrnd) = col%zi(c,0:hlm_numlevgrnd) end do if( this%fates(nc)%nsites == 0 ) then @@ -393,17 +365,15 @@ subroutine init_allocate(this) end do !$OMP END PARALLEL DO - call get_proc_bounds(bounds_proc) + call this%init_history_io(bounds_proc) - end subroutine init_allocate - - - ! ------------------------------------------------------------------------------------ - - subroutine check_hlm_active(this, nc, bounds_clump) + end subroutine init + ! =================================================================================== + + subroutine check_hlm_active(this, nc, bounds_clump) implicit none class(hlm_fates_interface_type), intent(inout) :: this @@ -412,12 +382,14 @@ subroutine check_hlm_active(this, nc, bounds_clump) ! local variables integer :: c + + + if (.not.use_ed) return do c = bounds_clump%begc,bounds_clump%endc ! FATES ACTIVE BUT HLM IS NOT if(this%f2hmap(nc)%hsites(c)>0 .and. .not.col%active(c)) then - write(iulog,*) 'INACTIVE COLUMN WITH ACTIVE FATES SITE' write(iulog,*) 'c = ',c @@ -476,6 +448,8 @@ subroutine dynamics_driv(this, nc, bounds_clump, & real(r8) :: day_of_year !----------------------------------------------------------------------- + if(.not.use_ed) return + ! --------------------------------------------------------------------------------- ! Part I. ! Prepare input boundary conditions for FATES dynamics @@ -620,6 +594,8 @@ subroutine wrap_update_hlmfates_dyn(this, nc, bounds_clump, & integer :: s ! site index integer :: c ! column index + if (.not.use_ed) return + associate( & tlai => canopystate_inst%tlai_patch , & elai => canopystate_inst%elai_patch , & @@ -734,11 +710,7 @@ subroutine restart( this, bounds_proc, ncid, flag, waterstate_inst, canopystate_ use FatesIODimensionsMod, only: fates_bounds_type use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int use EDMainMod, only : ed_update_site - use EDTypesMod, only: cohorts_per_col ! EDtypes should be protected - ! this variable should be transferred - ! to a location where we keep - ! variables that are co-dictated by - ! FATES and the HLM + use FatesInterfaceMod, only: fates_maxElementsPerSite implicit none @@ -767,6 +739,8 @@ subroutine restart( this, bounds_proc, ncid, flag, waterstate_inst, canopystate_ logical, save :: initialized = .false. + if (.not.use_ed) return + nclumps = get_proc_clumps() ! --------------------------------------------------------------------------------- @@ -821,7 +795,7 @@ subroutine restart( this, bounds_proc, ncid, flag, waterstate_inst, canopystate_ c = this%f2hmap(nc)%fcolumn(s) this%fates_restart%restart_map(nc)%site_index(s) = c this%fates_restart%restart_map(nc)%cohort1_index(s) = & - bounds_proc%begCohort + (c-bounds_proc%begc)*cohorts_per_col + 1 + bounds_proc%begCohort + (c-bounds_proc%begc)*fates_maxElementsPerSite + 1 end do end do @@ -983,6 +957,7 @@ subroutine init_coldstart(this, waterstate_inst, canopystate_inst) integer :: c integer :: g + if(.not.use_ed) return nclumps = get_proc_clumps() @@ -1061,6 +1036,8 @@ subroutine wrap_sunfrac(this,nc,atm2lnd_inst,canopystate_inst) type(ed_patch_type), pointer :: cpatch ! c"urrent" patch INTERF-TODO: SHOULD ! BE HIDDEN AS A FATES PRIVATE + + if(.not.use_ed) return associate( forc_solad => atm2lnd_inst%forc_solad_grc, & forc_solai => atm2lnd_inst%forc_solai_grc, & @@ -1184,6 +1161,8 @@ subroutine wrap_btran(this,nc,fn,filterc,soilstate_inst, waterstate_inst, & integer :: j integer :: ifp integer :: p + + if (.not.use_ed) return associate(& sucsat => soilstate_inst%sucsat_col , & ! Input: [real(r8) (:,:) ] minimum soil suction (mm) @@ -1356,6 +1335,8 @@ subroutine wrap_photosynthesis(this, nc, bounds, fn, filterp, & integer :: s,c,p,ifp,j,icp real(r8) :: dtime + if (.not.use_ed) return + call t_startf('edpsn') associate(& t_soisno => temperature_inst%t_soisno_col , & @@ -1456,6 +1437,8 @@ subroutine wrap_accumulatefluxes(this, nc, fn, filterp) integer :: s,c,p,ifp,icp real(r8) :: dtime + if (.not.use_ed) return + ! Run a check on the filter do icp = 1,fn p = filterp(icp) @@ -1503,6 +1486,8 @@ subroutine wrap_canopy_radiation(this, bounds_clump, nc, & ! locals integer :: s,c,p,ifp,icp + if (.not.use_ed) return + associate(& albgrd_col => surfalb_inst%albgrd_col , & !in albgri_col => surfalb_inst%albgri_col , & !in @@ -1588,6 +1573,8 @@ subroutine wrap_bgc_summary(this, nc, soilbiogeochem_carbonflux_inst, & logical :: is_beg_day integer :: s,c + if (.not.use_ed) return + associate(& hr => soilbiogeochem_carbonflux_inst%hr_col, & ! (gC/m2/s) total heterotrophic respiration totsomc => soilbiogeochem_carbonstate_inst%totsomc_col, & ! (gC/m2) total soil organic matter carbon @@ -1847,6 +1834,8 @@ subroutine hlm_bounds_to_fates_bounds(hlm, fates) type(bounds_type), intent(in) :: hlm type(fates_bounds_type), intent(out) :: fates + if (.not.use_ed) return + fates%cohort_begin = hlm%begcohort fates%cohort_end = hlm%endcohort