diff --git a/cime/cime_config/cesm/machines/config_compilers.xml b/cime/cime_config/cesm/machines/config_compilers.xml index 318ac8ed9a..ee13c73857 100644 --- a/cime/cime_config/cesm/machines/config_compilers.xml +++ b/cime/cime_config/cesm/machines/config_compilers.xml @@ -556,8 +556,8 @@ for mct, etc. $(NETCDF_HOME) -DLinux -DCPRGNU - -ffree-line-length-132 - -ffpe-trap=invalid,zero,overflow + -ffree-line-length-132 + -g -fbacktrace -fbounds-check -ffpe-trap=invalid,zero,overflow -Wline-truncation -L$(NETCDF_HOME)/lib/ -lnetcdff -lnetcdf -lcurl -llapack -lblas -DHAVE_VPRINTF -DHAVE_GETTIMEOFDAY diff --git a/cime/cime_config/cesm/machines/config_machines.xml b/cime/cime_config/cesm/machines/config_machines.xml index 1d082f468d..90a44f6905 100644 --- a/cime/cime_config/cesm/machines/config_machines.xml +++ b/cime/cime_config/cesm/machines/config_machines.xml @@ -861,10 +861,6 @@ - - -np {{ num_tasks }} - -npernode {{ tasks_per_node }} - mpirun diff --git a/components/clm/src/ED/biogeochem/EDCanopyStructureMod.F90 b/components/clm/src/ED/biogeochem/EDCanopyStructureMod.F90 index e91e4608d5..655013c75e 100755 --- a/components/clm/src/ED/biogeochem/EDCanopyStructureMod.F90 +++ b/components/clm/src/ED/biogeochem/EDCanopyStructureMod.F90 @@ -465,12 +465,12 @@ subroutine canopy_structure( currentSite ) endif !call terminate_cohorts(currentPatch) if(promswitch == 1)then - ! write(fates_log(),*) 'cohort loop',currentCohort%pft,currentCohort%indexnumber,currentPatch%patchno + ! write(fates_log(),*) 'cohort loop',currentCohort%pft,currentPatch%patchno endif !----------- End of cohort splitting ------------------------------! else if(promswitch == 1)then - ! write(fates_log(),*) 'cohort list',currentCohort%pft,currentCohort%indexnumber, & + ! write(fates_log(),*) 'cohort list',currentCohort%pft, & ! currentCohort%canopy_layer,currentCohort%c_area endif endif @@ -485,7 +485,7 @@ subroutine canopy_structure( currentSite ) !currentPatch%patchno,z,i,lower_cohort_switch endif if(promswitch == 1.and.associated(currentPatch%tallest))then - ! write(fates_log(),*) 'cohorts',currentCohort%pft,currentCohort%indexnumber,currentPatch%patchno, & + ! write(fates_log(),*) 'cohorts',currentCohort%pft,currentPatch%patchno, & !currentCohort%c_area endif enddo !arealayer loop @@ -1067,7 +1067,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort%c_area/currentPatch%total_canopy_area) currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (remainder * fleaf * & currentCohort%c_area/currentPatch%total_canopy_area*(layer_top_hite+layer_bottom_hite)/2.0_r8) - write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + if ( DEBUG ) write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) if(currentCohort%dbh <= 0._r8.or.currentCohort%n == 0._r8)then write(fates_log(), *) 'ED: dbh or n is zero in clmedlink', currentCohort%dbh,currentCohort%n endif diff --git a/components/clm/src/ED/biogeochem/EDCohortDynamicsMod.F90 b/components/clm/src/ED/biogeochem/EDCohortDynamicsMod.F90 index d468c03d78..0adfa7004b 100755 --- a/components/clm/src/ED/biogeochem/EDCohortDynamicsMod.F90 +++ b/components/clm/src/ED/biogeochem/EDCohortDynamicsMod.F90 @@ -6,14 +6,16 @@ module EDCohortDynamicsMod ! !USES: use abortutils , only : endrun use FatesGlobals , only : fates_log + use FatesGlobals , only : freq_day use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : fates_unset_int use shr_log_mod , only : errMsg => shr_log_errMsg use EDPftvarcon , only : EDPftvarcon_inst 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, udata + use EDtypesMod , only : ncwd, maxcohortsperpatch use EDtypesMod , only : sclass_ed,nlevsclass_ed,AREA use EDtypesMod , only : min_npm2, min_nppatch, min_n_safemath ! @@ -73,7 +75,6 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & !---------------------------------------------------------------------- allocate(new_cohort) - udata%cohort_number = udata%cohort_number + 1 !give each cohort a unique number for checking cohort fusing routine. call nan_cohort(new_cohort) ! Make everything in the cohort not-a-number call zero_cohort(new_cohort) ! Zero things that need to be zeroed. @@ -82,7 +83,8 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & ! Define cohort state variable !**********************/ - new_cohort%indexnumber = udata%cohort_number + new_cohort%indexnumber = fates_unset_int ! Cohort indexing was not thread-safe, setting + ! bogus value for the time being (RGK-012017) new_cohort%siteptr => patchptr%siteptr new_cohort%patchptr => patchptr new_cohort%pft = pft @@ -109,7 +111,7 @@ subroutine create_cohort(patchptr, pft, nn, hite, dbh, & if (new_cohort%dbh <= 0.0_r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 ) then write(fates_log(),*) 'ED: something is zero in create_cohort', & - new_cohort%indexnumber,new_cohort%dbh,new_cohort%n, & + new_cohort%dbh,new_cohort%n, & new_cohort%pft call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -184,6 +186,9 @@ subroutine allocate_live_biomass(cc_p,mode) ! accounts for the fact that live biomass may decline in the off-season, ! making leaf_memory unrealistic. real(r8) :: ratio_balive ! ratio between root+shoot biomass now and root+shoot biomass when leaves fell off. + real(r8) :: new_bl + real(r8) :: new_br + real(r8) :: new_bsw integer :: ft ! functional type integer :: leaves_off_switch @@ -218,69 +223,68 @@ subroutine allocate_live_biomass(cc_p,mode) ! Use different proportions if the leaves are on vs off if(leaves_off_switch==0)then - ! Tracking npp/gpp diagnostics only occur after growth derivatives is called - if(mode==1)then - ! it will not be able to put out as many leaves as it had previous timestep - currentcohort%npp_leaf = currentcohort%npp_leaf + & - max(0.0_r8,currentcohort%balive*leaf_frac - currentcohort%bl)/udata%deltat - end if - currentcohort%bl = currentcohort%balive*leaf_frac + new_bl = currentcohort%balive*leaf_frac + + new_br = EDpftvarcon_inst%froot_leaf(ft) * (currentcohort%balive + currentcohort%laimemory) * leaf_frac + + new_bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & + currentcohort%laimemory)*leaf_frac !diagnose the root and stem biomass from the functional balance hypothesis. This is used when the leaves are !fully on. - if(mode==1)then + if(mode==1)then + currentcohort%npp_leaf = currentcohort%npp_leaf + & + max(0.0_r8,new_bl - currentcohort%bl) / freq_day + currentcohort%npp_froot = currentcohort%npp_froot + & - max(0._r8, EDPftvarcon_inst%froot_leaf(ft)*(currentcohort%balive+currentcohort%laimemory)*leaf_frac - & - currentcohort%br) / udata%deltat + max(0._r8,new_br - currentcohort%br) / freq_day - currentcohort%npp_bsw = max(0._r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & - currentcohort%laimemory)*leaf_frac - currentcohort%bsw)/udata%deltat + currentcohort%npp_bsw = max(0.0_r8, new_bsw - currentcohort%bsw)/freq_day currentcohort%npp_bdead = currentCohort%dbdeaddt end if - - currentcohort%br = EDPftvarcon_inst%froot_leaf(ft) * (currentcohort%balive + currentcohort%laimemory) * leaf_frac - currentcohort%bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & - currentcohort%laimemory)*leaf_frac - - - else ! Leaves are on (leaves_off_switch==1) - - !the purpose of this section is to figure out the root and stem biomass when the leaves are off - !at this point, we know the former leaf mass (laimemory) and the current alive mass - !because balive may decline in the off-season, we need to adjust the root and stem biomass that are predicted - !from the laimemory, for the fact that we now might not have enough live biomass to support the hypothesized root mass - !thus, we use 'ratio_balive' to adjust br and bsw. Apologies that this is so complicated! RF - - - currentcohort%bl = 0.0_r8 + + currentcohort%bl = new_bl + currentcohort%br = new_br + currentcohort%bsw = new_bsw + + else ! Leaves are off (leaves_off_switch==1) + + !the purpose of this section is to figure out the root and stem biomass when the leaves are off + !at this point, we know the former leaf mass (laimemory) and the current alive mass + !because balive may decline in the off-season, we need to adjust the + !root and stem biomass that are predicted from the laimemory, for the fact that we now might + !not have enough live biomass to support the hypothesized root mass + !thus, we use 'ratio_balive' to adjust br and bsw. Apologies that this is so complicated! RF + ideal_balive = currentcohort%laimemory * EDPftvarcon_inst%froot_leaf(ft) + & currentcohort%laimemory* EDecophyscon%sapwood_ratio(ft) * currentcohort%hite - currentcohort%br = EDPftvarcon_inst%froot_leaf(ft) * (ideal_balive + currentcohort%laimemory) * leaf_frac - currentcohort%bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & - currentcohort%laimemory)*leaf_frac - - ratio_balive = currentcohort%balive / ideal_balive - currentcohort%br = currentcohort%br * ratio_balive - currentcohort%bsw = currentcohort%bsw * ratio_balive + ratio_balive = currentcohort%balive / ideal_balive + + new_br = EDpftvarcon_inst%froot_leaf(ft) * (ideal_balive + currentcohort%laimemory) * & + leaf_frac * ratio_balive + new_bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite * & + (ideal_balive + currentcohort%laimemory) * leaf_frac * ratio_balive ! Diagnostics if(mode==1)then currentcohort%npp_froot = currentcohort%npp_froot + & - max(0.0_r8,EDPftvarcon_inst%froot_leaf(ft)*(ideal_balive + & - currentcohort%laimemory)*leaf_frac*ratio_balive-currentcohort%br)/udata%deltat + max(0.0_r8,new_br-currentcohort%br)/freq_day - currentcohort%npp_bsw = max(0.0_r8,EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(ideal_balive + & - currentcohort%laimemory)*leaf_frac*ratio_balive - currentcohort%bsw)/udata%deltat + currentcohort%npp_bsw = max(0.0_r8, new_bsw-currentcohort%bsw)/freq_day currentcohort%npp_bdead = currentCohort%dbdeaddt end if + currentcohort%bl = 0.0_r8 + currentcohort%br = new_br + currentcohort%bsw = new_bsw + endif if (abs(currentcohort%balive -currentcohort%bl- currentcohort%br - currentcohort%bsw)>1e-12) then @@ -1006,8 +1010,7 @@ subroutine copy_cohort( currentCohort,copyc ) o => currentCohort n => copyc - udata%cohort_number = udata%cohort_number + 1 - n%indexnumber = udata%cohort_number + n%indexnumber = fates_unset_int ! VEGETATION STRUCTURE n%pft = o%pft @@ -1038,13 +1041,14 @@ subroutine copy_cohort( currentCohort,copyc ) n%gpp_acc_hold = o%gpp_acc_hold n%gpp_acc = o%gpp_acc n%gpp_tstep = o%gpp_tstep + n%npp_acc_hold = o%npp_acc_hold n%npp_tstep = o%npp_tstep + n%npp_acc = o%npp_acc if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ia ',o%npp_acc if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ib ',o%resp_acc - n%npp_acc_hold = o%npp_acc_hold n%resp_tstep = o%resp_tstep n%resp_acc = o%resp_acc n%resp_acc_hold = o%resp_acc_hold diff --git a/components/clm/src/ED/biogeochem/EDGrowthFunctionsMod.F90 b/components/clm/src/ED/biogeochem/EDGrowthFunctionsMod.F90 index a3fc06ceac..3a371b58b2 100755 --- a/components/clm/src/ED/biogeochem/EDGrowthFunctionsMod.F90 +++ b/components/clm/src/ED/biogeochem/EDGrowthFunctionsMod.F90 @@ -7,7 +7,7 @@ module EDGrowthFunctionsMod ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog + use FatesGlobals , only : fates_log use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysContype , only : EDecophyscon use EDTypesMod , only : ed_cohort_type, cp_nlevcan, dinc_ed @@ -76,7 +76,7 @@ real(r8) function Hite( cohort_in ) c = 0.37_r8 if(cohort_in%dbh <= 0._r8)then - write(iulog,*) 'ED: dbh less than zero problem!',cohort_in%indexnumber + write(fates_log(),*) 'ED: dbh less than zero problem!' cohort_in%dbh = 0.1_r8 endif @@ -106,7 +106,7 @@ real(r8) function Bleaf( cohort_in ) real(r8) :: slascaler ! changes the target biomass according to the SLA if(cohort_in%dbh < 0._r8.or.cohort_in%pft == 0.or.cohort_in%dbh > 1000.0_r8)then - write(iulog,*) 'problems in bleaf',cohort_in%dbh,cohort_in%pft + write(fates_log(),*) 'problems in bleaf',cohort_in%dbh,cohort_in%pft endif if(cohort_in%dbh <= EDecophyscon%max_dbh(cohort_in%pft))then @@ -117,7 +117,7 @@ real(r8) function Bleaf( cohort_in ) slascaler = 0.03_r8/EDPftvarcon_inst%slatop(cohort_in%pft) bleaf = bleaf * slascaler - !write(iulog,*) 'bleaf',bleaf, slascaler,cohort_in%pft + !write(fates_log(),*) 'bleaf',bleaf, slascaler,cohort_in%pft !Adjust for canopies that have become so deep that their bottom layer is not producing any carbon... !nb this will change the allometry and the effects of this remain untested. RF. April 2014 @@ -141,7 +141,7 @@ real(r8) function tree_lai( cohort_in ) real(r8) :: slat ! the sla of the top leaf layer. m2/kgC if( cohort_in%bl < 0._r8 .or. cohort_in%pft == 0 ) then - write(iulog,*) 'problem in treelai',cohort_in%bl,cohort_in%pft + write(fates_log(),*) 'problem in treelai',cohort_in%bl,cohort_in%pft endif if( cohort_in%status_coh == 2 ) then ! are the leaves on? @@ -162,7 +162,7 @@ real(r8) function tree_lai( cohort_in ) ! at the moments cp_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(iulog,*) 'too much lai' , cohort_in%treelai , cohort_in%pft , cp_nlevcan * dinc_ed + write(fates_log(),*) 'too much lai' , cohort_in%treelai , cohort_in%pft , cp_nlevcan * dinc_ed endif return @@ -186,7 +186,7 @@ real(r8) function tree_sai( cohort_in ) sai_scaler = 0.05_r8 ! here, a high biomass of 20KgC per m2 gives us a high SAI of 1.0. if( cohort_in%bdead < 0._r8 .or. cohort_in%pft == 0 ) then - write(iulog,*) 'problem in treesai',cohort_in%bdead,cohort_in%pft + write(fates_log(),*) 'problem in treesai',cohort_in%bdead,cohort_in%pft endif cohort_in%c_area = c_area(cohort_in) ! call the tree area @@ -199,7 +199,7 @@ real(r8) function tree_sai( cohort_in ) ! at the moments cp_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(iulog,*) 'too much sai' , cohort_in%treesai , cohort_in%pft , cp_nlevcan * dinc_ed + write(fates_log(),*) 'too much sai' , cohort_in%treesai , cohort_in%pft , cp_nlevcan * dinc_ed endif return @@ -223,13 +223,13 @@ real(r8) function c_area( cohort_in ) real(r8) :: dbh ! Tree diameter at breat height. cm. if (DEBUG_growth) then - write(iulog,*) 'z_area 1',cohort_in%dbh,cohort_in%pft - write(iulog,*) 'z_area 2',EDecophyscon%max_dbh - write(iulog,*) 'z_area 3',EDPftvarcon_inst%woody - write(iulog,*) 'z_area 4',cohort_in%n - write(iulog,*) 'z_area 5',cohort_in%patchptr%spread - write(iulog,*) 'z_area 6',cohort_in%canopy_layer - write(iulog,*) 'z_area 7',ED_val_grass_spread + write(fates_log(),*) 'z_area 1',cohort_in%dbh,cohort_in%pft + write(fates_log(),*) 'z_area 2',EDecophyscon%max_dbh + write(fates_log(),*) 'z_area 3',EDPftvarcon_inst%woody + write(fates_log(),*) 'z_area 4',cohort_in%n + write(fates_log(),*) 'z_area 5',cohort_in%patchptr%spread + write(fates_log(),*) 'z_area 6',cohort_in%canopy_layer + write(fates_log(),*) 'z_area 7',ED_val_grass_spread end if dbh = min(cohort_in%dbh,EDecophyscon%max_dbh(cohort_in%pft)) @@ -371,8 +371,8 @@ subroutine mortality_rates( cohort_in,cmort,hmort,bmort ) endif else - write(iulog,*) 'dbh problem in mortality_rates', & - cohort_in%dbh,cohort_in%pft,cohort_in%n,cohort_in%canopy_layer,cohort_in%indexnumber + write(fates_log(),*) 'dbh problem in mortality_rates', & + cohort_in%dbh,cohort_in%pft,cohort_in%n,cohort_in%canopy_layer endif !mortality_rates = bmort + hmort + cmort diff --git a/components/clm/src/ED/biogeochem/EDPatchDynamicsMod.F90 b/components/clm/src/ED/biogeochem/EDPatchDynamicsMod.F90 index fe44705e5b..93298a2cda 100755 --- a/components/clm/src/ED/biogeochem/EDPatchDynamicsMod.F90 +++ b/components/clm/src/ED/biogeochem/EDPatchDynamicsMod.F90 @@ -7,10 +7,11 @@ module EDPatchDynamicsMod 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 EDPftvarcon , only : EDPftvarcon_inst 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 : ed_site_type, ed_patch_type, ed_cohort_type, udata + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : min_patch_area, cp_numlevgrnd, cp_numSWb ! implicit none @@ -45,7 +46,6 @@ subroutine disturbance_rates( site_in) ! ! !USES: use EDGrowthFunctionsMod , only : c_area, mortality_rates - use EDTypesMod , only : udata ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: site_in @@ -85,7 +85,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)*udata%deltat*currentCohort%c_area/currentPatch%area + min(1.0_r8,currentCohort%dmort)*freq_day*currentCohort%c_area/currentPatch%area endif @@ -271,7 +271,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 * udata%deltat)) + currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * 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 +298,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/udata%deltat ! This was zero in the donor + nc%imort = ED_val_understorey_death/freq_day ! This was zero in the donor nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort nc%bmort = currentCohort%bmort @@ -336,7 +336,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/udata%deltat + nc%fmort = currentCohort%fire_mort/freq_day nc%imort = 0.0_r8 nc%cmort = currentCohort%cmort nc%hmort = currentCohort%hmort @@ -716,7 +716,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 * udata%deltat) + canopy_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * freq_day) currentPatch%canopy_mortality_woody_litter = currentPatch%canopy_mortality_woody_litter + & canopy_dead*(currentCohort%bdead+currentCohort%bsw) @@ -831,6 +831,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_ new_patch%siteptr => currentSite new_patch%age = age + new_patch%age_class = 1 new_patch%area = areap new_patch%spread = spread_local new_patch%cwd_ag = cwd_ag_local @@ -899,6 +900,7 @@ subroutine zero_patch(cp_p) currentPatch%clm_pno = 999 currentPatch%age = nan + currentPatch%age_class = 1 currentPatch%area = nan currentPatch%canopy_layer_lai(:) = nan currentPatch%total_canopy_area = nan @@ -935,8 +937,6 @@ subroutine zero_patch(cp_p) currentPatch%lai = nan ! leaf area index of patch currentPatch%spread(:) = nan ! dynamic ratio of dbh to canopy area. currentPatch%pft_agb_profile(:,:) = nan - currentPatch%gpp = 0._r8 - currentPatch%npp = 0._r8 ! DISTURBANCE currentPatch%disturbance_rates = 0._r8 @@ -1150,6 +1150,7 @@ subroutine fuse_2_patches(dp, rp) ! associated with the secnd patch ! ! !USES: + use EDTypesMod, only: ageclass_ed ! ! !ARGUMENTS: type (ed_patch_type) , intent(inout), pointer :: dp ! Donor Patch @@ -1169,6 +1170,7 @@ subroutine fuse_2_patches(dp, rp) !area weighted average of ages & litter rp%age = (dp%age * dp%area + rp%age * rp%area)/(dp%area + rp%area) + rp%age_class = count(rp%age-ageclass_ed.ge.0.0_r8) do p = 1,numpft_ed rp%seeds_in(p) = (rp%seeds_in(p)*rp%area + dp%seeds_in(p)*dp%area)/(rp%area + dp%area) diff --git a/components/clm/src/ED/biogeochem/EDPhysiologyMod.F90 b/components/clm/src/ED/biogeochem/EDPhysiologyMod.F90 index 8e99378d0e..1bb570d486 100755 --- a/components/clm/src/ED/biogeochem/EDPhysiologyMod.F90 +++ b/components/clm/src/ED/biogeochem/EDPhysiologyMod.F90 @@ -6,20 +6,27 @@ module EDPhysiologyMod ! Miscellaneous physiology routines from ED. ! ============================================================================ - use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog - use spmdMod , only : masterproc - use TemperatureType , only : temperature_type - use SoilStateType , only : soilstate_type - use WaterstateType , only : waterstate_type + 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 FatesConstantsMod, only : r8 => fates_r8 use EDPftvarcon , only : EDPftvarcon_inst 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 : 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 + + + implicit none private @@ -39,13 +46,14 @@ module EDPhysiologyMod public :: flux_into_litter_pools logical, parameter :: DEBUG = .false. ! local debug flag - + character(len=*), parameter, private :: sourcefile = & + __FILE__ ! ============================================================================ contains ! ============================================================================ - subroutine canopy_derivs( currentSite, currentPatch ) + subroutine canopy_derivs( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: ! spawn new cohorts of juveniles of each PFT @@ -55,6 +63,7 @@ subroutine canopy_derivs( currentSite, currentPatch ) ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type) , intent(inout), target :: currentPatch + type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: type(ed_cohort_type), pointer ::currentCohort @@ -65,14 +74,14 @@ subroutine canopy_derivs( currentSite, currentPatch ) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - call Growth_Derivatives(currentSite, currentCohort) + call Growth_Derivatives(currentSite, currentCohort, bc_in ) currentCohort => currentCohort%taller enddo end subroutine canopy_derivs ! ============================================================================ - subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) + subroutine non_canopy_derivs( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: ! Returns time differentials of the state vector @@ -82,8 +91,9 @@ subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type) , intent(inout) :: currentPatch - type(temperature_type) , intent(in) :: temperature_inst + type(ed_patch_type), intent(inout) :: currentPatch + type(bc_in_type), intent(in) :: bc_in + ! ! !LOCAL VARIABLES: integer c,p @@ -110,11 +120,12 @@ subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) ! update fragmenting pool fluxes call cwd_input(currentPatch) - call cwd_out( currentSite, currentPatch, temperature_inst) + call cwd_out( currentSite, currentPatch, bc_in) do p = 1,numpft_ed currentSite%dseed_dt(p) = currentSite%dseed_dt(p) + & - (currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - currentPatch%seed_germination(p)) * currentPatch%area/AREA + (currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - & + currentPatch%seed_germination(p)) * currentPatch%area/AREA enddo do c = 1,ncwd @@ -123,19 +134,12 @@ subroutine non_canopy_derivs( currentSite, currentPatch, temperature_inst ) enddo do p = 1,numpft_ed - currentPatch%dleaf_litter_dt(p) = currentPatch%leaf_litter_in(p) - currentPatch%leaf_litter_out(p) - currentPatch%droot_litter_dt(p) = currentPatch%root_litter_in(p) - currentPatch%root_litter_out(p) + currentPatch%dleaf_litter_dt(p) = currentPatch%leaf_litter_in(p) - & + currentPatch%leaf_litter_out(p) + currentPatch%droot_litter_dt(p) = currentPatch%root_litter_in(p) - & + currentPatch%root_litter_out(p) enddo - ! currentPatch%leaf_litter_in(:) = 0.0_r8 - ! currentPatch%root_litter_in(:) = 0.0_r8 - ! currentPatch%leaf_litter_out(:) = 0.0_r8 - ! currentPatch%root_litter_out(:) = 0.0_r8 - ! currentPatch%CWD_AG_in(:) = 0.0_r8 - ! currentPatch%cwd_bg_in(:) = 0.0_r8 - ! currentPatch%CWD_AG_out(:) = 0.0_r8 - ! currentPatch%cwd_bg_out(:) = 0.0_r8 - end subroutine non_canopy_derivs ! ============================================================================ @@ -175,7 +179,7 @@ subroutine trim_canopy( currentSite ) currentCohort%treelai = tree_lai(currentCohort) currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) if (currentCohort%nv > cp_nlevcan)then - write(iulog,*) 'nv > cp_nlevcan',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & + write(fates_log(),*) 'nv > cp_nlevcan',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & currentCohort%c_area,currentCohort%n,currentCohort%bl endif @@ -203,7 +207,7 @@ subroutine trim_canopy( currentSite ) if (currentCohort%canopy_trim > trim_limit)then if ( DEBUG ) then - write(iulog,*) 'trimming leaves',currentCohort%canopy_trim,currentCohort%leaf_cost + write(fates_log(),*) 'trimming leaves',currentCohort%canopy_trim,currentCohort%leaf_cost endif ! keep trimming until none of the canopy is in negative carbon balance. @@ -221,7 +225,7 @@ subroutine trim_canopy( currentSite ) if (currentCohort%NV.gt.2)then ! leaf_cost may be uninitialized, removing its diagnostic from the log ! to allow checking with fpe_traps (RGK) - write(iulog,*) 'nv>4',currentCohort%year_net_uptake(1:6),currentCohort%canopy_trim + write(fates_log(),*) 'nv>4',currentCohort%year_net_uptake(1:6),currentCohort%canopy_trim endif currentCohort%year_net_uptake(:) = 999.0_r8 @@ -230,7 +234,7 @@ subroutine trim_canopy( currentSite ) endif if ( DEBUG ) then - write(iulog,*) 'trimming',currentCohort%canopy_trim + write(fates_log(),*) 'trimming',currentCohort%canopy_trim endif ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. @@ -242,25 +246,22 @@ subroutine trim_canopy( currentSite ) end subroutine trim_canopy ! ============================================================================ - subroutine phenology( currentSite, temperature_inst, waterstate_inst) + subroutine phenology( currentSite, bc_in ) ! ! !DESCRIPTION: ! Phenology. ! ! !USES: - use clm_varcon, only : tfrz - use clm_time_manager, only : get_curr_date - use clm_time_manager, only : get_ref_date, timemgr_datediff - use EDTypesMod, only : udata - use PatchType , only : patch + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + ! ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(temperature_type) , intent(in) :: temperature_inst - type(waterstate_type) , intent(in) :: waterstate_inst + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + ! ! !LOCAL VARIABLES: - real(r8), pointer :: t_veg24(:) + integer :: t ! day of year integer :: ncolddays ! no days underneath the threshold for leaf drop integer :: ncolddayslim ! critical no days underneath the threshold for leaf drop @@ -273,8 +274,6 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) integer :: mon ! month (1, ..., 12) integer :: day ! day of month (1, ..., 31) integer :: sec ! seconds of the day - integer :: patchi ! the first CLM/ALM patch index of the associated column - integer :: coli ! the CLM/ALM column index of the associated site real(r8) :: gdd_threshold real(r8) :: a,b,c ! params of leaf-pn model from botta et al. 2000. @@ -285,27 +284,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) real(r8) :: drought_threshold real(r8) :: off_time ! minimum number of days between leaf off and leaf on for drought phenology real(r8) :: temp_in_C ! daily averaged temperature in celcius - real(r8) :: mindayson - real(r8) :: modelday - - !------------------------------------------------------------------------ - - ! INTERF-TODO: THIS IS A BAND-AID, AS I WAS HOPING TO REMOVE CLM_PNO - ! ALREADY REMOVED currentSite%clmcolumn, hence the need for these - - patchi = currentSite%oldest_patch%clm_pno-1 - coli = patch%column(patchi) - - t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs - - call get_curr_date(yr, mon, day, sec) - curdate = yr*10000 + mon*100 + day - - call get_ref_date(yr, mon, day, sec) - refdate = yr*10000 + mon*100 + day - - call timemgr_datediff(refdate, 0, curdate, sec, modelday) - if ( masterproc ) write(iulog,*) 'modelday',modelday + real(r8), parameter :: mindayson = 30.0 ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) ! - this is arbitrary and poorly understood. Needs work. ED_ @@ -317,15 +296,13 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) b = 638.0_r8 c = -0.001_r8 coldday = 5.0_r8 !ed_ph_chiltemp - - mindayson = 30 !Parameters from SDGVM model of senesence ncolddayslim = 5 cold_t = 7.5_r8 ! ed_ph_coldtemp - t = udata%time_period - temp_in_C = t_veg24(patchi) - tfrz + t = day_of_year + temp_in_C = bc_in%t_veg24_si - tfrz !-----------------Cold Phenology--------------------! @@ -369,12 +346,12 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) endif ! ! accumulate the GDD using daily mean temperatures - if (t_veg24(patchi) .gt. tfrz) then - currentSite%ED_GDD_site = currentSite%ED_GDD_site + t_veg24(currentSite%oldest_patch%clm_pno-1) - tfrz + if (bc_in%t_veg24_si .gt. tfrz) then + currentSite%ED_GDD_site = currentSite%ED_GDD_site + bc_in%t_veg24_si - tfrz endif - timesinceleafoff = modelday - currentSite%leafoffdate + timesinceleafoff = 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 @@ -383,14 +360,14 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) if (currentSite%status == 1) then if (currentSite%ncd >= 1) then currentSite%status = 2 !alter status of site to 'leaves on' - ! NOTE(bja, 2015-01) should leafondate = modelday to be consistent with leaf off? + ! NOTE(bja, 2015-01) should leafondate = model_day to be consistent with leaf off? currentSite%leafondate = t !record leaf on date - if ( DEBUG ) write(iulog,*) 'leaves on' + if ( DEBUG ) write(fates_log(),*) 'leaves on' endif !ncd endif !status endif !GDD - timesinceleafon = modelday - currentSite%leafondate + timesinceleafon = model_day - currentSite%leafondate !LEAF OFF: COLD THRESHOLD @@ -404,8 +381,8 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) if (timesinceleafon > mindayson)then if (currentSite%status == 2)then currentSite%status = 1 !alter status of site to 'leaves on' - currentSite%leafoffdate = modelday !record leaf off date - if ( DEBUG ) write(iulog,*) 'leaves off' + currentSite%leafoffdate = model_day !record leaf off date + if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif endif @@ -414,8 +391,8 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) 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 = modelday !record leaf off date - if ( DEBUG ) write(iulog,*) 'leaves off' + currentSite%leafoffdate = model_day !record leaf off date + if ( DEBUG ) write(fates_log(),*) 'leaves off' endif endif @@ -447,7 +424,7 @@ subroutine phenology( currentSite, temperature_inst, waterstate_inst) ! distinction actually matter??).... !Accumulate surface water memory of last 10 days. - currentSite%water_memory(1) = waterstate_inst%h2osoi_vol_col(coli,1) + 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) enddo @@ -531,7 +508,8 @@ subroutine phenology_leafonoff(currentSite) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - real(r8) :: store_output ! the amount of the store to put into leaves - is a barrier against negative storage and C starvation. + real(r8) :: store_output ! the amount of the store to put into leaves - + ! is a barrier against negative storage and C starvation. !------------------------------------------------------------------------ @@ -560,11 +538,11 @@ subroutine phenology_leafonoff(currentSite) ! Add deployed carbon to alive biomass pool currentCohort%balive = currentCohort%balive + currentCohort%bl - if ( DEBUG ) write(iulog,*) 'EDPhysMod 1 ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 1 ',currentCohort%bstore currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! Drain store - if ( DEBUG ) write(iulog,*) 'EDPhysMod 2 ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 2 ',currentCohort%bstore currentCohort%laimemory = 0.0_r8 @@ -599,11 +577,11 @@ subroutine phenology_leafonoff(currentSite) endif currentCohort%balive = currentCohort%balive + currentCohort%bl - if ( DEBUG ) write(iulog,*) 'EDPhysMod 3 ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 3 ',currentCohort%bstore currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! empty store - if ( DEBUG ) write(iulog,*) 'EDPhysMod 4 ',currentCohort%bstore + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 4 ',currentCohort%bstore currentCohort%laimemory = 0.0_r8 @@ -661,7 +639,8 @@ subroutine seeds_in( currentSite, cp_pnt ) currentCohort => currentPatch%tallest do while (associated(currentCohort)) p = currentCohort%pft - currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + currentCohort%seed_prod * currentCohort%n/currentPatch%area + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + & + currentCohort%seed_prod * currentCohort%n/currentPatch%area currentCohort => currentCohort%shorter enddo !cohort loop @@ -670,8 +649,10 @@ subroutine seeds_in( currentSite, cp_pnt ) do while(associated(currentPatch)) 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 - currentSite%seed_rain_flux(p) = currentSite%seed_rain_flux(p) + EDecophyscon%seed_rain(p) * currentPatch%area/AREA !KgC/m2/year + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + & + EDecophyscon%seed_rain(p) !KgC/m2/year + currentSite%seed_rain_flux(p) = currentSite%seed_rain_flux(p) + & + EDecophyscon%seed_rain(p) * currentPatch%area/AREA !KgC/m2/year enddo endif currentPatch => currentPatch%younger @@ -727,24 +708,26 @@ subroutine seed_germination( currentSite, currentPatch ) max_germination = 1.0_r8 !this is arbitrary do p = 1,numpft_ed - currentPatch%seed_germination(p) = min(currentSite%seed_bank(p) * germination_timescale,max_germination) + currentPatch%seed_germination(p) = min(currentSite%seed_bank(p) * & + germination_timescale,max_germination) enddo end subroutine seed_germination ! ============================================================================ - subroutine Growth_Derivatives( currentSite, currentCohort) + subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) ! ! !DESCRIPTION: ! Main subroutine controlling growth and allocation derivatives ! ! !USES: use EDGrowthFunctionsMod , only : Bleaf, dDbhdBd, dhdbd, hite, mortality_rates,dDbhdBl - use EDTypesMod , only : udata + ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_cohort_type),intent(inout), target :: currentCohort + type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: real(r8) :: dbldbd !rate of change of dead biomass per unit dbh @@ -789,11 +772,13 @@ subroutine Growth_Derivatives( currentSite, currentCohort) endif ! NPP - if ( DEBUG ) write(iulog,*) 'EDphys 716 ',currentCohort%npp_acc + if ( DEBUG ) write(fates_log(),*) 'EDphys 716 ',currentCohort%npp_acc - currentCohort%npp_acc_hold = currentCohort%npp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year - currentCohort%gpp_acc_hold = currentCohort%gpp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year - currentCohort%resp_acc_hold = currentCohort%resp_acc * udata%n_sub ! convert from kgC/indiv/day into kgC/indiv/year + ! 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 currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n @@ -823,7 +808,8 @@ subroutine Growth_Derivatives( currentSite, currentCohort) if (EDPftvarcon_inst%stress_decid(currentCohort%pft) /= 1.and.EDPftvarcon_inst%season_decid(currentCohort%pft) /= 1.and. & EDPftvarcon_inst%evergreen(currentCohort%pft) /= 1)then - write(iulog,*) 'problem with phenology definitions',currentCohort%pft,EDPftvarcon_inst%stress_decid(currentCohort%pft), & + write(fates_log(),*) 'problem with phenology definitions',currentCohort%pft, & + EDPftvarcon_inst%stress_decid(currentCohort%pft), & EDPftvarcon_inst%season_decid(currentCohort%pft),EDPftvarcon_inst%evergreen(currentCohort%pft) endif @@ -835,23 +821,23 @@ subroutine Growth_Derivatives( currentSite, currentCohort) ! Calculate carbon balance ! this is the fraction of maintenance demand we -have- to do... - if ( DEBUG ) write(iulog,*) 'EDphys 760 ',currentCohort%npp_acc_hold, currentCohort%md, & + if ( DEBUG ) write(fates_log(),*) 'EDphys 760 ',currentCohort%npp_acc_hold, currentCohort%md, & EDecophyscon%leaf_stor_priority(currentCohort%pft) currentCohort%carbon_balance = currentCohort%npp_acc_hold - & currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) - ! Allowing only carbon from NPP pool to account for npp flux into the maintenance pools + ! Allowing only carbon from NPP pool to account for npp flux into the maintenance turnover pools ! ie this does not include any use of storage carbon or balive to make up for missing carbon balance in the transfer - currentCohort%npp_leaf = min(currentCohort%npp_acc_hold*currentCohort%leaf_md/currentCohort%md, & - currentCohort%leaf_md*EDecophyscon%leaf_stor_priority(currentCohort%pft)) - currentCohort%npp_froot = min(currentCohort%npp_acc_hold*currentCohort%root_md/currentCohort%md, & - currentCohort%root_md*EDecophyscon%leaf_stor_priority(currentCohort%pft)) + currentCohort%npp_leaf = max(0.0_r8,min(currentCohort%npp_acc_hold*currentCohort%leaf_md/currentCohort%md, & + currentCohort%leaf_md*EDecophyscon%leaf_stor_priority(currentCohort%pft))) + currentCohort%npp_froot = max(0.0_r8,min(currentCohort%npp_acc_hold*currentCohort%root_md/currentCohort%md, & + currentCohort%root_md*EDecophyscon%leaf_stor_priority(currentCohort%pft))) if (Bleaf(currentCohort) > 0._r8)then - if ( DEBUG ) write(iulog,*) 'EDphys A ',currentCohort%carbon_balance + if ( DEBUG ) write(fates_log(),*) 'EDphys A ',currentCohort%carbon_balance if (currentCohort%carbon_balance > 0._r8)then !spend C on growing and storing @@ -863,21 +849,26 @@ subroutine Growth_Derivatives( currentSite, currentCohort) !what is the flux into the store? currentCohort%storage_flux = currentCohort%carbon_balance * f_store - if ( DEBUG ) write(iulog,*) 'EDphys B ',f_store + currentCohort%npp_store = currentCohort%carbon_balance * f_store + if ( DEBUG ) write(fates_log(),*) 'EDphys B ',f_store !what is the tax on the carbon available for growth? currentCohort%carbon_balance = currentCohort%carbon_balance * (1.0_r8 - f_store) else !cbalance is negative. Take C out of store to pay for maintenance respn. + currentCohort%storage_flux = currentCohort%carbon_balance + + ! Note that npp_store only tracks the flux between NPP and storage. Storage can + ! also be drawn down to support some turnover demand. + currentCohort%npp_store = min(0.0_r8,currentCohort%npp_acc_hold) + currentCohort%carbon_balance = 0._r8 endif else - currentCohort%storage_flux = 0._r8 - currentCohort%carbon_balance = 0._r8 - write(iulog,*) 'ED: no leaf area in gd', currentCohort%indexnumber,currentCohort%n,currentCohort%bdead, & - currentCohort%dbh,currentCohort%balive + write(fates_log(),*) 'No target leaf area in GrowthDerivs? Bleaf(cohort) <= 0?' + call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -930,7 +921,7 @@ subroutine Growth_Derivatives( currentSite, currentCohort) !FIX(RF,032414) - to fix high bl's. needed to prevent numerical errors without the ODEINT. if (currentCohort%balive > target_balive*1.1_r8)then va = 0.0_r8; vs = 1._r8 - write(iulog,*) 'using high bl cap',target_balive,currentCohort%balive + write(fates_log(),*) 'using high bl cap',target_balive,currentCohort%balive endif else @@ -944,34 +935,33 @@ subroutine Growth_Derivatives( currentSite, currentCohort) currentCohort%dbdeaddt = gr_fract * vs * currentCohort%carbon_balance currentCohort%dbstoredt = currentCohort%storage_flux - if ( DEBUG ) write(iulog,*) 'EDPhys dbstoredt I ',currentCohort%dbstoredt + if ( DEBUG ) write(fates_log(),*) 'EDPhys dbstoredt I ',currentCohort%dbstoredt currentCohort%seed_prod = (1.0_r8 - gr_fract) * currentCohort%carbon_balance if (abs(currentCohort%npp_acc_hold-(currentCohort%dbalivedt+currentCohort%dbdeaddt+currentCohort%dbstoredt+ & currentCohort%seed_prod+currentCohort%md)) > 0.0000000001_r8)then - write(iulog,*) 'error in carbon check growth derivs',currentCohort%npp_acc_hold- & + write(fates_log(),*) 'error in carbon check growth derivs',currentCohort%npp_acc_hold- & (currentCohort%dbalivedt+currentCohort%dbdeaddt+currentCohort%dbstoredt+currentCohort%seed_prod+currentCohort%md) - write(iulog,*) 'cohort fluxes',currentCohort%pft,currentCohort%canopy_layer,currentCohort%n, & + write(fates_log(),*) 'cohort fluxes',currentCohort%pft,currentCohort%canopy_layer,currentCohort%n, & currentCohort%npp_acc_hold,currentCohort%dbalivedt,balive_loss, & currentCohort%dbdeaddt,currentCohort%dbstoredt,currentCohort%seed_prod,currentCohort%md * & EDecophyscon%leaf_stor_priority(currentCohort%pft) - write(iulog,*) 'proxies' ,target_balive,currentCohort%balive,currentCohort%dbh,va,vs,gr_fract + write(fates_log(),*) 'proxies' ,target_balive,currentCohort%balive,currentCohort%dbh,va,vs,gr_fract endif ! 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 * udata%deltat > currentCohort%balive*0.99)then - write(iulog,*) 'using non-neg leaf mass cap',currentCohort%balive , currentCohort%dbalivedt,currentCohort%dbstoredt, & + if (-1.0_r8*currentCohort%dbalivedt * 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 - if ( DEBUG ) write(iulog,*) 'EDPhys dbstoredt II ',currentCohort%dbstoredt + if ( DEBUG ) write(fates_log(),*) 'EDPhys dbstoredt II ',currentCohort%dbstoredt currentCohort%dbalivedt = 0._r8 endif currentCohort%npp_bseed = currentCohort%seed_prod - currentCohort%npp_store = max(0.0_r8,currentCohort%storage_flux) ! calculate change in diameter and height currentCohort%ddbhdt = currentCohort%dbdeaddt * dDbhdBd(currentCohort) @@ -990,7 +980,6 @@ subroutine recruitment( t, currentSite, currentPatch ) ! ! !USES: use EDGrowthFunctionsMod, only : bdead,dbh, Bleaf - use EDTypesMod, only : udata ! ! !ARGUMENTS integer, intent(in) :: t @@ -1017,14 +1006,14 @@ subroutine recruitment( t, currentSite, currentPatch ) + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite) temp_cohort%bstore = EDecophyscon%cushion(ft)*(temp_cohort%balive/ (1.0_r8 + EDPftvarcon_inst%froot_leaf(ft) & + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite)) - temp_cohort%n = currentPatch%area * currentPatch%seed_germination(ft)*udata%deltat & + temp_cohort%n = currentPatch%area * currentPatch%seed_germination(ft)*freq_day & / (temp_cohort%bdead+temp_cohort%balive+temp_cohort%bstore) if (t == 1)then - write(iulog,*) 'filling in cohorts where there are none left; this will break carbon balance', & + write(fates_log(),*) 'filling in cohorts where there are none left; this will break carbon balance', & currentPatch%patchno,currentPatch%area temp_cohort%n = 0.1_r8*currentPatch%area - write(iulog,*) 'cohort n',ft,temp_cohort%n + write(fates_log(),*) 'cohort n',ft,temp_cohort%n endif temp_cohort%laimemory = 0.0_r8 @@ -1043,7 +1032,7 @@ subroutine recruitment( t, currentSite, currentPatch ) endif if (temp_cohort%n > 0.0_r8 )then - if ( DEBUG ) write(iulog,*) 'EDPhysiologyMod.F90 call create_cohort ' + if ( DEBUG ) write(fates_log(),*) 'EDPhysiologyMod.F90 call create_cohort ' call create_cohort(currentPatch, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & temp_cohort%laimemory, cohortstatus, temp_cohort%canopy_trim, currentPatch%NCL_p) @@ -1064,7 +1053,7 @@ subroutine CWD_Input( currentPatch) ! !USES: use SFParamsMod , only : SF_val_CWD_frac use EDParamsMod , only : ED_val_ag_biomass - use EDTypesMod , only : udata + ! ! !ARGUMENTS type(ed_patch_type),intent(inout), target :: currentPatch @@ -1094,7 +1083,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/udata%deltat + currentCohort%leaf_litter * currentCohort%n/currentPatch%area/freq_day !daily leaf loss needs to be scaled up to the annual scale here. @@ -1113,7 +1102,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/udata%deltat)* dead_n + (currentCohort%bl+currentCohort%leaf_litter/freq_day)* dead_n currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & (currentCohort%br+currentCohort%bstore) * dead_n @@ -1124,7 +1113,7 @@ subroutine CWD_Input( currentPatch) SF_val_CWD_frac(c) * dead_n * (1.0_r8-ED_val_ag_biomass) if (currentPatch%cwd_AG_in(c) < 0.0_r8)then - write(iulog,*) 'negative CWD in flux',currentPatch%cwd_AG_in(c), & + write(fates_log(),*) 'negative CWD in flux',currentPatch%cwd_AG_in(c), & (currentCohort%bdead+currentCohort%bsw), dead_n endif enddo @@ -1142,41 +1131,42 @@ subroutine CWD_Input( currentPatch) end subroutine CWD_Input ! ============================================================================ - subroutine fragmentation_scaler( currentPatch, temperature_inst ) + subroutine fragmentation_scaler( currentPatch, bc_in) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model - ! FIX(SPM, 091914) this should be a function as it returns a value in currentPatch%fragmentation_scaler + ! FIX(SPM, 091914) this should be a function as it returns a value in + ! currentPatch%fragmentation_scaler ! ! !USES: - use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_TKFRZ - use EDSharedParamsMod , only : EDParamsShareInst + use EDSharedParamsMod , only : EDParamsShareInst + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod, only : pi => pi_const ! ! !ARGUMENTS - type(ed_patch_type) , intent(inout) :: currentPatch - type(temperature_type) , intent(in) :: temperature_inst + type(ed_patch_type), intent(inout) :: currentPatch + type(bc_in_type), intent(in) :: bc_in + ! ! !LOCAL VARIABLES: logical :: use_century_tfunc = .false. - integer :: p,j + integer :: j + integer :: ifp ! Index of a FATES Patch "ifp" real(r8) :: t_scalar real(r8) :: w_scalar real(r8) :: catanf ! hyperbolic temperature function from CENTURY real(r8) :: catanf_30 ! hyperbolic temperature function from CENTURY real(r8) :: t1 ! temperature argument real(r8) :: Q10 ! temperature dependence - real(r8) :: froz_q10 ! separate q10 for frozen soil respiration rates. default to same as above zero rates - real(r8), pointer :: t_veg24(:) + real(r8) :: froz_q10 ! separate q10 for frozen soil respiration rates. + ! default to same as above zero rates !---------------------------------------------------------------------- - catanf(t1) = 11.75_r8 +(29.7_r8 / SHR_CONST_PI) * atan( SHR_CONST_PI * 0.031_r8 * ( t1 - 15.4_r8 )) - - t_veg24 => temperature_inst%t_veg24_patch ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs - + catanf(t1) = 11.75_r8 +(29.7_r8 / pi) * atan( pi * 0.031_r8 * ( t1 - 15.4_r8 )) catanf_30 = catanf(30._r8) - p = currentPatch%clm_pno + ifp = currentPatch%patchno ! set "froz_q10" parameter froz_q10 = EDParamsShareInst%froz_q10 @@ -1185,20 +1175,22 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) if ( .not. use_century_tfunc ) then !calculate rate constant scalar for soil temperature,assuming that the base rate constants !are assigned for non-moisture limiting conditions at 25C. - if (t_veg24(p) >= SHR_CONST_TKFRZ) then - t_scalar = Q10**((t_veg24(p)-(SHR_CONST_TKFRZ+25._r8))/10._r8) - ! Q10**((t_soisno(c,j)-(SHR_CONST_TKFRZ+25._r8))/10._r8) + if (bc_in%t_veg24_pa(ifp) >= tfrz) then + t_scalar = Q10**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) + ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) else - t_scalar = (Q10**(-25._r8/10._r8))*(froz_q10**((t_veg24(p)-SHR_CONST_TKFRZ)/10._r8)) - !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-SHR_CONST_TKFRZ)/10._r8) + t_scalar = (Q10**(-25._r8/10._r8))*(froz_q10**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) + !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) endif else - ! original century uses an arctangent function to calculate the temperature dependence of decomposition - t_scalar = max(catanf(t_veg24(p)-SHR_CONST_TKFRZ)/catanf_30,0.01_r8) + ! original century uses an arctangent function to calculate the + ! temperature dependence of decomposition + t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) endif !Moisture Limitations - !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed soil moisture values, which is not realistic. + !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed + !soil moisture values, which is not realistic. !litter decomp is proportional to water limitation on average... w_scalar = sum(currentPatch%btran_ft(1:numpft_ed))/numpft_ed @@ -1207,7 +1199,7 @@ subroutine fragmentation_scaler( currentPatch, temperature_inst ) end subroutine fragmentation_scaler ! ============================================================================ - subroutine cwd_out( currentSite, currentPatch, temperature_inst ) + subroutine cwd_out( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model @@ -1215,12 +1207,13 @@ subroutine cwd_out( currentSite, currentPatch, temperature_inst ) ! ! !USES: use SFParamsMod, only : SF_val_max_decomp - use EDTypesMod , only : udata + ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type) , intent(inout), target :: currentPatch - type(temperature_type) , intent(in) :: temperature_inst + type(ed_patch_type), intent(inout), target :: currentPatch + type(bc_in_type), intent(in) :: bc_in + ! ! !LOCAL VARIABLES: integer :: c,ft @@ -1228,8 +1221,8 @@ subroutine cwd_out( currentSite, currentPatch, temperature_inst ) currentPatch%root_litter_out(:) = 0.0_r8 currentPatch%leaf_litter_out(:) = 0.0_r8 - - call fragmentation_scaler(currentPatch, temperature_inst) + + call fragmentation_scaler(currentPatch, bc_in) !Flux of coarse woody debris into decomposing litter pool. @@ -1256,19 +1249,19 @@ subroutine cwd_out( currentSite, currentPatch, temperature_inst ) currentPatch%root_litter_out(ft) = max(0.0_r8,currentPatch%root_litter(ft)* SF_val_max_decomp(dg_sf) * & currentPatch%fragmentation_scaler ) if ( currentPatch%leaf_litter_out(ft)<0.0_r8.or.currentPatch%root_litter_out(ft)<0.0_r8)then - write(iulog,*) 'root or leaf out is negative?',SF_val_max_decomp(dg_sf),currentPatch%fragmentation_scaler + write(fates_log(),*) 'root or leaf out is negative?',SF_val_max_decomp(dg_sf),currentPatch%fragmentation_scaler endif enddo !add up carbon going into fragmenting pools currentSite%flux_out = currentSite%flux_out + sum(currentPatch%leaf_litter_out) * & - currentPatch%area *udata%deltat!kgC/site/day + currentPatch%area *freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%root_litter_out) * & - currentPatch%area *udata%deltat!kgC/site/day + currentPatch%area *freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_ag_out) * & - currentPatch%area *udata%deltat!kgC/site/day + currentPatch%area *freq_day!kgC/site/day currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_bg_out) * & - currentPatch%area *udata%deltat!kgC/site/day + currentPatch%area *freq_day!kgC/site/day end subroutine cwd_out @@ -1297,14 +1290,15 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) !use EDCLMLinkMod, only: cwd_fcel_ed, cwd_flig use EDPftvarcon, only : EDPftvarcon_inst - use shr_const_mod, only: SHR_CONST_CDAY + 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 - ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi + ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, + ! pftspecific_rootingprofile, rootprof_exp, surfprof_exp, zisoi, dzsoi_decomp, zsoi ! implicit none ! @@ -1363,7 +1357,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) delta = 0.001_r8 !no of seconds in a year. - time_convert = 365.0_r8*SHR_CONST_CDAY + time_convert = 365.0_r8*sec_per_day ! number of grams in a kilogram mass_convert = 1000._r8 @@ -1372,8 +1366,10 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! first calculate vertical profiles ! define two types of profiles: - ! (1) a surface profile, for leaves and stem inputs, which is the same for each pft but differs from one site to the next to avoid inputting any C into permafrost or bedrock - ! (2) a fine root profile, which is indexed by both site and pft, differs for each pft and also from one site to the next to avoid inputting any C into permafrost or bedrock + ! (1) a surface profile, for leaves and stem inputs, which is the same for each + ! pft but differs from one site to the next to avoid inputting any C into permafrost or bedrock + ! (2) a fine root profile, which is indexed by both site and pft, differs for + ! each pft and also from one site to the next to avoid inputting any C into permafrost or bedrock ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1498,13 +1494,13 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) stem_prof_sum = stem_prof_sum + stem_prof(s,j) * dzsoi_decomp(j) end do if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then - write(iulog, *) 'profile sums: ', leaf_prof_sum, stem_prof_sum - write(iulog, *) 'surface_prof: ', surface_prof - write(iulog, *) 'surface_prof_tot: ', surface_prof_tot - write(iulog, *) 'leaf_prof: ', leaf_prof(s,:) - write(iulog, *) 'stem_prof: ', stem_prof(s,:) - write(iulog, *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col - write(iulog, *) 'dzsoi_decomp: ', dzsoi_decomp + write(fates_log(), *) 'profile sums: ', leaf_prof_sum, stem_prof_sum + write(fates_log(), *) 'surface_prof: ', surface_prof + write(fates_log(), *) 'surface_prof_tot: ', surface_prof_tot + write(fates_log(), *) 'leaf_prof: ', leaf_prof(s,:) + 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() endif ! now check each fine root profile @@ -1514,7 +1510,7 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) 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(iulog, *) 'profile sums: ', froot_prof_sum + write(fates_log(), *) 'profile sums: ', froot_prof_sum call endrun() endif end do @@ -1582,12 +1578,12 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools ! ! do c = 1, ncwd - ! write(iulog,*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel, currentpatch%area/AREA - ! write(iulog,*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), cwd_fcel, currentpatch%area/AREA ! end do ! do ft = 1,numpft_ed - ! write(iulog,*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel, currentpatch%area/AREA - ! write(iulog,*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), cwd_fcel, currentpatch%area/AREA ! end do ! ! ! CWD pools fragmenting into decomposing litter pools. @@ -1648,15 +1644,15 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) end do end do - ! write(iulog,*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c - ! write_col(iulog,*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c - ! write_col(iulog,*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c - ! write_col(iulog,*)'cdk cp_numlevdecomp_full, bounds%begc, bounds%endc: ', cp_numlevdecomp_full, bounds%begc, bounds%endc - ! write(iulog,*)'cdk leaf_prof: ', leaf_prof - ! write(iulog,*)'cdk stem_prof: ', stem_prof - ! write(iulog,*)'cdk froot_prof: ', froot_prof - ! write(iulog,*)'cdk croot_prof_perpatch: ', croot_prof_perpatch - ! write(iulog,*)'cdk croot_prof: ', croot_prof + ! 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(fates_log(),*)'cdk leaf_prof: ', leaf_prof + ! write(fates_log(),*)'cdk stem_prof: ', stem_prof + ! write(fates_log(),*)'cdk froot_prof: ', froot_prof + ! write(fates_log(),*)'cdk croot_prof_perpatch: ', croot_prof_perpatch + ! write(fates_log(),*)'cdk croot_prof: ', croot_prof end subroutine flux_into_litter_pools diff --git a/components/clm/src/ED/biogeophys/EDAccumulateFluxesMod.F90 b/components/clm/src/ED/biogeophys/EDAccumulateFluxesMod.F90 index 78563a3a2d..bd2437c92f 100644 --- a/components/clm/src/ED/biogeophys/EDAccumulateFluxesMod.F90 +++ b/components/clm/src/ED/biogeophys/EDAccumulateFluxesMod.F90 @@ -9,14 +9,18 @@ module EDAccumulateFluxesMod ! Rosie Fisher. March 2014. ! ! !USES: + use abortutils, only : endrun + use shr_log_mod , only : errMsg => shr_log_errMsg implicit none private ! public :: AccumulateFluxes_ED logical :: DEBUG = .false. ! for debugging this module - !------------------------------------------------------------------------------ + character(len=*), parameter, private :: sourcefile = & + __FILE__ + contains !------------------------------------------------------------------------------ @@ -33,6 +37,8 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) 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 integer, intent(in) :: nsites @@ -67,12 +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_acc, & - ccohort%npp_tstep + write(iulog,*) 'EDAccumFlux 64 ',ccohort%npp_tstep write(iulog,*) 'EDAccumFlux 66 ',ccohort%gpp_tstep write(iulog,*) 'EDAccumFlux 67 ',ccohort%resp_tstep endif - + ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep diff --git a/components/clm/src/ED/biogeophys/EDBtranMod.F90 b/components/clm/src/ED/biogeophys/EDBtranMod.F90 index bc9d541359..49d011c292 100644 --- a/components/clm/src/ED/biogeophys/EDBtranMod.F90 +++ b/components/clm/src/ED/biogeophys/EDBtranMod.F90 @@ -192,7 +192,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) end if enddo enddo - + !weight patch level output BTRAN for the bc_out(s)%btran_pa(ifp) = 0.0_r8 do ft = 1,numpft_ed @@ -203,10 +203,11 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft_ed end if enddo - - temprootr = sum(bc_out(s)%rootr_pagl(ifp,:)) + + ! 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)) if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then - write(iulog,*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs),sum(cpatch%rootr_ft(1:2,:),dim=2) do j = 1,cp_numlevgrnd bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr enddo diff --git a/components/clm/src/ED/biogeophys/EDPhotosynthesisMod.F90 b/components/clm/src/ED/biogeophys/EDPhotosynthesisMod.F90 deleted file mode 100644 index 8fd3a3d8ec..0000000000 --- a/components/clm/src/ED/biogeophys/EDPhotosynthesisMod.F90 +++ /dev/null @@ -1,1160 +0,0 @@ -module EDPhotosynthesisMod - - !------------------------------------------------------------------------------ - ! !DESCRIPTION: - ! Calculates the photosynthetic fluxes for the ED model - ! This code is equivalent to the 'photosynthesis' subroutine in PhotosynthesisMod.F90. - ! We have split this out to reduce merge conflicts until we can pull out - ! common code used in both the ED and CLM versions. - ! - ! !USES: - ! - - use abortutils, only : endrun - use FatesGlobals, only : fates_log - use FatesConstantsMod, only : r8 => fates_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg - - implicit none - private - - - ! PUBLIC MEMBER FUNCTIONS: - public :: Photosynthesis_ED !ED specific photosynthesis routine - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------------ - -contains - - !--------------------------------------------------------- - subroutine Photosynthesis_ED (nsites, sites,bc_in,bc_out,dtime) - - - ! - ! !DESCRIPTION: - ! Leaf photosynthesis and stomatal conductance calculation as described by - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to - ! a multi-layer canopy - ! - ! !USES: - - use abortutils , only : endrun - use clm_varpar , only : mxpft ! THIS WILL BE DEPRECATED WHEN PARAMETER - ! READS ARE REFACTORED (RGK 10-13-2016) - use EDPftvarcon , only : EDPftvarcon_inst ! THIS WILL BE DEPRECATED WHEN PARAMETER - ! READS ARE REFACTORED (RGK 10-13-2016) - use EDParamsMod , only : ED_val_ag_biomass - use EDSharedParamsMod , only : EDParamsShareInst - use EDTypesMod , only : numpft_ed - use EDTypesMod , only : dinc_ed - 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 : maxpatchespercol - use EDTypesMod , only : cp_numlevsoil - use EDTypesMod , only : cp_nlevcan - use EDTypesMod , only : cp_nclmax - - use EDEcophysContype , only : EDecophyscon - - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : bc_out_type - - use EDCanopyStructureMod, only : calc_areaindex - - use FatesConstantsMod, only : umolC_to_kgC - use FatesConstantsMod, only : g_per_kg - use FatesConstantsMod, only : mg_per_g - use FatesConstantsMod, only : sec_per_min - use FatesConstantsMod, only : umol_per_mmol - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - - ! !ARGUMENTS: - ! ----------------------------------------------------------------------------------- - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - real(r8),intent(in) :: dtime - - - ! !LOCAL VARIABLES: - ! ----------------------------------------------------------------------------------- - type (ed_patch_type) , pointer :: currentPatch - type (ed_cohort_type), pointer :: currentCohort - - integer , parameter :: psn_type = 2 !c3 or c4. - - logical :: DEBUG = .false. - - ! - ! Leaf photosynthesis parameters - real(r8) :: vcmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8) :: jmax_z(cp_nclmax,mxpft,cp_nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) - real(r8) :: tpu_z(cp_nclmax,mxpft,cp_nlevcan) ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8) :: kp_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) - real(r8) :: lmr_z(cp_nclmax,mxpft,cp_nlevcan) ! initial slope of CO2 response curve (C4 plants) - real(r8) :: rs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal resistance s/m - real(r8) :: gs_z(cp_nclmax,mxpft,cp_nlevcan) ! stomatal conductance m/s - - real(r8) :: ci ! intracellular leaf CO2 (Pa) - real(r8) :: lnc(mxpft) ! leaf N concentration (gN leaf/m^2) - - real(r8) :: kc( maxpatchespercol ) ! Michaelis-Menten constant for CO2 (Pa) - real(r8) :: ko( maxpatchespercol ) ! Michaelis-Menten constant for O2 (Pa) - real(r8) :: co2_cp( maxpatchespercol ) ! CO2 compensation point (Pa) - - ! --------------------------------------------------------------- - ! TO-DO: bbbopt is slated to be transferred to the parameter file - ! ---------------------------------------------------------------- - real(r8) :: bbbopt(psn_type) ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) - real(r8) :: bbb(mxpft) ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) - - real(r8) :: kn(mxpft) ! leaf nitrogen decay coefficient - real(r8) :: vcmax25top(mxpft) ! canopy top: maximum rate of carboxylation at 25C (umol CO2/m**2/s) - real(r8) :: jmax25top(mxpft) ! canopy top: maximum electron transport rate at 25C (umol electrons/m**2/s) - real(r8) :: tpu25top(mxpft) ! canopy top: triose phosphate utilization rate at 25C (umol CO2/m**2/s) - real(r8) :: lmr25top(mxpft) ! canopy top: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - real(r8) :: kp25top(mxpft) ! canopy top: initial slope of CO2 response curve (C4 plants) at 25C - - real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C (umol CO2/m**2/s) - real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C (umol electrons/m**2/s) - real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C (umol CO2/m**2/s) - real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - real(r8) :: kp25 ! leaf layer: Initial slope of CO2 response curve (C4 plants) at 25C - real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) - real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) - real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) - - real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) - real(r8) :: jmaxha ! activation energy for jmax (J/mol) - real(r8) :: tpuha ! activation energy for tpu (J/mol) - real(r8) :: lmrha ! activation energy for lmr (J/mol) - real(r8) :: kcha ! activation energy for kc (J/mol) - real(r8) :: koha ! activation energy for ko (J/mol) - real(r8) :: cpha ! activation energy for cp (J/mol) - - real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) - real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) - real(r8) :: tpuhd ! deactivation energy for tpu (J/mol) - real(r8) :: lmrhd ! deactivation energy for lmr (J/mol) - - real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) - real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) - real(r8) :: tpuse ! entropy term for tpu (J/mol/K) - real(r8) :: lmrse ! entropy term for lmr (J/mol/K) - - real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: lmrc ! scaling factor for high temperature inhibition (25 C = 1.0) - - real(r8) :: qe(psn_type) ! quantum efficiency, used only for C4 (mol CO2 / mol photons) - real(r8) :: fnps ! fraction of light absorbed by non-photosynthetic pigments - real(r8) :: theta_psii ! empirical curvature parameter for electron transport rate - - real(r8) :: theta_cj(psn_type) ! empirical curvature parameter for ac, aj photosynthesis co-limitation - real(r8) :: theta_ip ! empirical curvature parameter for ap photosynthesis co-limitation - - ! Other - integer :: c,CL,f,s,iv,j,ps,ft,ifp ! indices - integer :: NCL_p ! number of canopy layers in patch - real(r8) :: cf ! s m**2/umol -> s/m - - real(r8) :: gb ! leaf boundary layer conductance (m/s) - real(r8) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) - real(r8) :: cs ! CO2 partial pressure at leaf surface (Pa) - real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) - real(r8) :: gs ! leaf stomatal conductance (m/s) - real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) - real(r8) :: sco ! relative specificity of rubisco - real(r8) :: tl ! leaf temperature in photosynthesis temperature function (K) - real(r8) :: ha ! activation energy in photosynthesis temperature function (J/mol) - real(r8) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) - real(r8) :: se ! entropy term in photosynthesis temperature function (J/mol/K) - real(r8) :: cc2 ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: ciold ! previous value of Ci for convergence check - real(r8) :: gs_mol_err ! gs_mol for error check - real(r8) :: je ! electron transport rate (umol electrons/m**2/s) - real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) - real(r8) :: aquad,bquad,cquad ! terms for quadratic equations - real(r8) :: r1,r2 ! roots of quadratic equation - real(r8) :: ceair ! vapor pressure of air, constrained (Pa) - real(r8) :: act25 ! (umol/mgRubisco/min) Rubisco activity at 25 C - integer :: niter ! iteration loop index - real(r8) :: nscaler ! leaf nitrogen scaling coefficient - real(r8) :: leaf_frac ! ratio of to leaf biomass to total alive biomass - - real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ap ! product-limited (C3) or CO2-limited (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ag(cp_nclmax,mxpft,cp_nlevcan) ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: an(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: an_av(cp_nclmax,mxpft,cp_nlevcan) ! net leaf photosynthesis (umol CO2/m**2/s) averaged over sun and shade leaves. - real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) - real(r8) :: laican ! canopy sum of lai_z - real(r8) :: vai ! leaf and steam area in ths layer. - integer :: exitloop - real(r8) :: laifrac - real(r8) :: tcsoi ! Temperature response function for root respiration. - real(r8) :: tc ! Temperature response function for wood - - - real(r8) :: q10 ! temperature dependence of root respiration - integer :: sunsha ! sun (1) or shaded (2) leaves... - real(r8) :: coarse_wood_frac ! amount of woody biomass that is coarse... - real(r8) :: tree_area - real(r8) :: gs_cohort - real(r8) :: rscanopy - real(r8) :: elai - - real(r8) :: live_stem_n ! Live stem (above-ground sapwood) nitrogen content (kgN/plant) - real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) nitrogen content (kgN/plant) - real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) - - ! Parameters - ! ----------------------------------------------------------------------- - ! Base maintenance respiration rate for plant tissues base_mr_20 - ! M. Ryan, 1991. Effects of climate change on plant respiration. - ! Ecological Applications, 1(2), 157-167. - ! Original expression is br = 0.0106 molC/(molN h) - ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) - ! - ! Base rate is at 20C. Adjust to 25C using the CN Q10 = 1.5 - ! (gC/gN/s) - ! ------------------------------------------------------------------------ - - real(r8),parameter :: base_mr_20 = 2.525e-6_r8 - - ! maximum stomatal resistance [s/m] - real(r8),parameter :: rsmax0 = 2.e4_r8 - - ! First guess on ratio between intracellular co2 and the atmosphere - ! an iterator converges on actual - real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 - real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 - - - associate( & - c3psn => EDPftvarcon_inst%c3psn , & ! photosynthetic pathway: 0. = c4, 1. = c3 - slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, projected area basis [m^2/gC] - flnr => EDPftvarcon_inst%flnr , & ! fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) - woody => EDPftvarcon_inst%woody , & ! Is vegetation woody or not? - fnitr => EDPftvarcon_inst%fnitr , & ! foliage nitrogen limitation factor (-) - leafcn => EDPftvarcon_inst%leafcn , & ! leaf C:N (gC/gN) - frootcn => EDPftvarcon_inst%frootcn , & ! froot C:N (gc/gN) - bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship - - ! Peter Thornton: 3/13/09 - ! Q10 was originally set to 2.0, an arbitrary choice, but reduced to 1.5 as part of the tuning - ! to improve seasonal cycle of atmospheric CO2 concentration in global - ! simulatoins - q10 = 1.5_r8 - Q10 = EDParamsShareInst%Q10 - - !==============================================================================! - ! Photosynthesis and stomatal conductance parameters, from: - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - !==============================================================================! - - ! vcmax25 parameters, from CN - - act25 = 3.6_r8 !umol/mgRubisco/min - ! Convert rubisco activity units from umol/mgRubisco/min -> umol/gRubisco/s - act25 = act25 * mg_per_g / sec_per_min - - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 - - kcha = 79430._r8 - koha = 36380._r8 - cpha = 37830._r8 - vcmaxha = 65330._r8 - jmaxha = 43540._r8 - tpuha = 53100._r8 - lmrha = 46390._r8 - - ! High temperature deactivation, from: - ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 - ! The factor "c" scales the deactivation to a value of 1.0 at 25C - - vcmaxhd = 149250._r8 - jmaxhd = 152040._r8 - tpuhd = 150650._r8 - lmrhd = 150650._r8 - - vcmaxse = 485._r8 - jmaxse = 495._r8 - tpuse = 490._r8 - lmrse = 490._r8 - - vcmaxc = fth25_f(vcmaxhd, vcmaxse) - jmaxc = fth25_f(jmaxhd, jmaxse) - tpuc = fth25_f(tpuhd, tpuse) - lmrc = fth25_f(lmrhd, lmrse) - - ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - - fnps = 0.15_r8 - theta_psii = 0.7_r8 - theta_ip = 0.95_r8 - - qe(1) = 0._r8 - theta_cj(1) = 0.98_r8 - bbbopt(1) = 10000._r8 - - qe(2) = 0.05_r8 - theta_cj(2) = 0.80_r8 - bbbopt(2) = 40000._r8 - - do s = 1,nsites - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - ifp = ifp+1 - - bc_out(s)%psncanopy_pa(ifp) = 0._r8 - bc_out(s)%lmrcanopy_pa(ifp) = 0._r8 - bc_out(s)%rssun_pa(ifp) = 0._r8 - bc_out(s)%rssha_pa(ifp) = 0._r8 - bc_out(s)%gccanopy_pa(ifp) = 0._r8 - - ! Patch level filter flag for photosynthesis calculations - ! has a short memory, flags: - ! 1 = patch has not been called - ! 2 = patch is currently marked for photosynthesis - ! 3 = patch has been called for photosynthesis at least once - if(bc_in(s)%filter_photo_pa(ifp)==2)then - - currentPatch%ncan(:,:) = 0 - !redo the canopy structure algorithm to get round a bug that is happening for site 125, FT13. - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & - max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft),currentCohort%NV) - - currentCohort => currentCohort%shorter - - enddo !cohort - - currentPatch%nrad = currentPatch%ncan - do CL = 1,cp_nclmax - do ft = 1,numpft_ed - currentPatch%present(CL,ft) = 0 - do iv = 1, currentPatch%nrad(CL,ft); - if(currentPatch%canopy_area_profile(CL,ft,iv) > 0._r8)then - currentPatch%present(CL,ft) = 1 - end if - end do !iv - enddo !ft - enddo !CL - - - ! kc, ko, currentPatch, from: Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! - ! kc25 = 404.9 umol/mol - ! ko25 = 278.4 mmol/mol - ! cp25 = 42.75 umol/mol - ! - ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate - ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco - ! - - kc25 = (404.9_r8 / 1.e06_r8) * bc_in(s)%forc_pbot - ko25 = (278.4_r8 / 1.e03_r8) * bc_in(s)%forc_pbot - sco = 0.5_r8 * 0.209_r8 / (42.75_r8 / 1.e06_r8) - cp25 = 0.5_r8 * bc_in(s)%oair_pa(ifp) / sco - - if(bc_in(s)%t_veg_pa(ifp).gt.150_r8.and.bc_in(s)%t_veg_pa(ifp).lt.350_r8)then - kc(ifp) = kc25 * ft1_f(bc_in(s)%t_veg_pa(ifp), kcha) - ko(ifp) = ko25 * ft1_f(bc_in(s)%t_veg_pa(ifp), koha) - co2_cp(ifp) = cp25 * ft1_f(bc_in(s)%t_veg_pa(ifp), cpha) - else - kc(ifp) = 1 - ko(ifp) = 1 - co2_cp(ifp) = 1 - end if - - end if - - currentpatch => currentpatch%younger - end do - - ! Multi-layer parameters scaled by leaf nitrogen profile. - ! Loop through each canopy layer to calculate nitrogen profile using - ! cumulative lai at the midpoint of the layer - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - ifp = ifp+1 - - if(bc_in(s)%filter_photo_pa(ifp)==2)then - - NCL_p = currentPatch%NCL_p - - do FT = 1,numpft_ed !calculate patch and pft specific propserties at canopy top. - - if (nint(c3psn(FT)) == 1)then - ps = 1 - else - ps = 2 - end if - bbb(FT) = max (bbbopt(ps)*currentPatch%btran_ft(FT), 1._r8) - - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - lnc(FT) = 1._r8 / (slatop(FT) * leafcn(FT)) - - !at the moment in ED we assume that there is no active N cycle. This should change, of course. FIX(RF,032414) Sep2011. - vcmax25top(FT) = fnitr(FT) !fudge - shortcut using fnitr as a proxy for vcmax... - - ! Parameters derived from vcmax25top. Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - ! used jmax25 = 1.97 vcmax25, from Wullschleger (1993) Journal of Experimental Botany 44:907-920. - ! Here use a factor "1.67", from Medlyn et al (2002) Plant, Cell and Environment 25:1167-1179 - - !RF - copied this from the CLM trunk code, but where did it come from, and how can we make these consistant? - !jmax25top(FT) = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrzc),11._r8),35._r8)) * vcmax25top(FT) - - jmax25top(FT) = 1.67_r8 * vcmax25top(FT) - tpu25top(FT) = 0.167_r8 * vcmax25top(FT) - kp25top(FT) = 20000._r8 * vcmax25top(FT) - - ! Nitrogen scaling factor. Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used - ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al (2010) Biogeosciences, 7, 1833-1859 - ! Remove daylength factor from vcmax25 so that kn is based on maximum vcmax25 - - if (bc_in(s)%dayl_factor_pa(ifp) == 0._r8) then - kn(FT) = 0._r8 - else - kn(FT) = exp(0.00963_r8 * vcmax25top(FT) - 2.43_r8) - end if - - ! Leaf maintenance respiration to match the base rate used in CN - ! but with the new temperature functions for C3 and C4 plants. - ! - ! - ! CN respiration has units: g C / g N [leaf] / s. This needs to be - ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - ! - ! Then scale this value at the top of the canopy for canopy depth - - lmr25top(FT) = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) - lmr25top(FT) = lmr25top(FT) * lnc(FT) / (umolC_to_kgC * g_per_kg) - - end do !FT - - !==============================================================================! - ! Calculate Nitrogen scaling factors and photosynthetic parameters. - !==============================================================================! - do CL = 1, NCL_p - do FT = 1,numpft_ed - - do iv = 1, currentPatch%nrad(CL,FT) - if(currentPatch%canopy_area_profile(CL,FT,iv)>0._r8.and.currentPatch%present(CL,FT) /= 1)then - write(fates_log(),*) 'CF: issue with present structure',CL,FT,iv, & - currentPatch%canopy_area_profile(CL,FT,iv),currentPatch%present(CL,FT), & - currentPatch%nrad(CL,FT),currentPatch%ncl_p,cp_nclmax - currentPatch%present(CL,FT) = 1 - end if - enddo - - if(currentPatch%present(CL,FT) == 1)then ! are there any leaves of this pft in this layer? - - if(CL==NCL_p)then !are we in the top canopy layer or a shaded layer? - laican = 0._r8 - else - laican = sum(currentPatch%canopy_layer_lai(CL+1:NCL_p)) - end if - - ! Loop through canopy layers (above snow). Respiration needs to be - ! calculated every timestep. Others are calculated only if daytime - do iv = 1, currentPatch%nrad(CL,FT) - vai = (currentPatch%elai_profile(CL,FT,iv)+currentPatch%esai_profile(CL,FT,iv)) !vegetation area index. - if (iv == 1) then - laican = laican + 0.5_r8 * vai - else - laican = laican + 0.5_r8 * (currentPatch%elai_profile(CL,FT,iv-1)+ & - currentPatch%esai_profile(CL,FT,iv-1))+vai - end if - - ! Scale for leaf nitrogen profile - nscaler = exp(-kn(FT) * laican) - - - ! Maintenance respiration: umol CO2 / m**2 [leaf] / s - lmr25 = lmr25top(FT) * nscaler - - if (nint(c3psn(FT)) == 1)then - lmr_z(CL,FT,iv) = lmr25 * ft1_f(bc_in(s)%t_veg_pa(ifp), lmrha) * & - fth_f(bc_in(s)%t_veg_pa(ifp), lmrhd, lmrse, lmrc) - else - lmr_z(CL,FT,iv) = lmr25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) - lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) / (1._r8 + exp( 1.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+55._r8)) )) - end if - - if (currentPatch%ed_parsun_z(CL,FT,iv) <= 0._r8) then ! night time - vcmax_z(CL,FT,iv) = 0._r8 - jmax_z(CL,FT,iv) = 0._r8 - tpu_z(CL,FT,iv) = 0._r8 - kp_z(CL,FT,iv) = 0._r8 - else ! day time - vcmax25 = vcmax25top(FT) * nscaler - jmax25 = jmax25top(FT) * nscaler - tpu25 = tpu25top(FT) * nscaler - kp25 = kp25top(FT) * nscaler - - ! Adjust for temperature - vcmax_z(CL,FT,iv) = vcmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), vcmaxha) * & - fth_f(bc_in(s)%t_veg_pa(ifp), vcmaxhd, vcmaxse, vcmaxc) - jmax_z(CL,FT,iv) = jmax25 * ft1_f(bc_in(s)%t_veg_pa(ifp), jmaxha) * & - fth_f(bc_in(s)%t_veg_pa(ifp), jmaxhd, jmaxse, jmaxc) - tpu_z(CL,FT,iv) = tpu25 * ft1_f(bc_in(s)%t_veg_pa(ifp), tpuha) * & - fth_f(bc_in(s)%t_veg_pa(ifp), tpuhd, tpuse, tpuc) - - if (nint(c3psn(FT)) /= 1) then - vcmax_z(CL,FT,iv) = vcmax25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) - vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + & - exp( 0.2_r8*((tfrz+15._r8)-bc_in(s)%t_veg_pa(ifp)) )) - vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) / (1._r8 + & - exp( 0.3_r8*(bc_in(s)%t_veg_pa(ifp)-(tfrz+40._r8)) )) - end if - kp_z(CL,FT,iv) = kp25 * 2._r8**((bc_in(s)%t_veg_pa(ifp)-(tfrz+25._r8))/10._r8) !q10 response of product limited psn. - end if - ! Adjust for soil water:(umol co2/m**2/s) - - vcmax_z(CL,FT,iv) = vcmax_z(CL,FT,iv) * currentPatch%btran_ft(FT) - ! completely removed respiration drought response - ! - (lmr_z(CL,FT,iv) * (1.0_r8-currentPatch%btran_ft(FT)) *EDPftvarcon_inst%resp_drought_response(FT)) - lmr_z(CL,FT,iv) = lmr_z(CL,FT,iv) - - end do ! iv - end if !present - enddo !PFT - enddo !CL - - !==============================================================================! - ! Leaf-level photosynthesis and stomatal conductance - !==============================================================================! - - ! Leaf boundary layer conductance, umol/m**2/s - - ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS (RGK 10-13-2016) - cf = bc_in(s)%forc_pbot/(rgas*1.e-3_r8*bc_in(s)%tgcm_pa(ifp))*1.e06_r8 - gb = 1._r8/bc_in(s)%rb_pa(ifp) - gb_mol = gb * cf - - ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures - ! that hs does not go to zero. Also eair <= esat_tv so that hs <= 1 - ceair = min( max(bc_in(s)%eair_pa(ifp), 0.05_r8*bc_in(s)%esat_tv_pa(ifp)), bc_in(s)%esat_tv_pa(ifp) ) - - ! Loop through canopy layers (above snow). Only do calculations if daytime - do CL = 1, NCL_p - do FT = 1,numpft_ed - if (nint(c3psn(FT)) == 1)then - ps = 1 - else - ps = 2 - end if - if(currentPatch%present(CL,FT) == 1)then ! are there any leaves of this pft in this layer? - do iv = 1, currentPatch%nrad(CL,FT) - if ( DEBUG ) write(fates_log(),*) 'EDphoto 581 ',currentPatch%ed_parsun_z(CL,ft,iv) - if (currentPatch%ed_parsun_z(CL,FT,iv) <= 0._r8) then ! night time - - ac = 0._r8 - aj = 0._r8 - ap = 0._r8 - ag(CL,FT,iv) = 0._r8 - an(CL,FT,iv) = ag(CL,FT,iv) - lmr_z(CL,FT,iv) - an_av(cl,ft,iv) = 0._r8 - currentPatch%psn_z(cl,ft,iv) = 0._r8 - rs_z(CL,FT,iv) = min(rsmax0, 1._r8/bbb(FT) * cf) - - else ! day time - !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - - if ( DEBUG ) write(fates_log(),*) 'EDphot 594 ',currentPatch%ed_laisun_z(CL,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDphot 595 ',currentPatch%ed_laisha_z(CL,ft,iv) - - if(currentPatch%ed_laisun_z(CL,ft,iv)+currentPatch%ed_laisha_z(cl,ft,iv) > 0._r8)then - - if ( DEBUG ) write(fates_log(),*) '600 in laisun, laisha loop ' - - !Loop aroun shaded and unshaded leaves - currentPatch%psn_z(CL,ft,iv) = 0._r8 ! psn is accumulated across sun and shaded leaves. - rs_z(CL,FT,iv) = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. - gs_z(CL,FT,iv) = 0._r8 - an_av(CL,FT,iv) = 0._r8 - do sunsha = 1,2 - ! Electron transport rate for C3 plants. Convert par from W/m2 to umol photons/m**2/s - ! using the factor 4.6 - ! Convert from units of par absorbed per unit ground area to par absorbed per unit leaf area. - - if(sunsha == 1)then !sunlit - if((currentPatch%ed_laisun_z(CL,FT,iv) * currentPatch%canopy_area_profile(CL,FT,iv)) > & - 0.0000000001_r8)then - - qabs = currentPatch%ed_parsun_z(CL,FT,iv) / (currentPatch%ed_laisun_z(CL,FT,iv) * & - currentPatch%canopy_area_profile(CL,FT,iv)) - qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - - else - qabs = 0.0_r8 - end if - else - - qabs = currentPatch%ed_parsha_z(CL,FT,iv) / (currentPatch%ed_laisha_z(CL,FT,iv) * & - currentPatch%canopy_area_profile(CL,FT,iv)) - qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - - end if - - !convert the absorbed par into absorbed par per m2 of leaf, - ! so it is consistant with the vcmax and lmr numbers. - aquad = theta_psii - bquad = -(qabs + jmax_z(cl,ft,iv)) - cquad = qabs * jmax_z(cl,ft,iv) - call quadratic_f (aquad, bquad, cquad, r1, r2) - je = min(r1,r2) - - ! Iterative loop for ci beginning with initial guess - ! THIS CALL APPEARS TO BE REDUNDANT WITH LINE 423 (RGK) - - if (nint(c3psn(FT)) == 1)then - ci = init_a2l_co2_c3 * bc_in(s)%cair_pa(ifp) - else - ci = init_a2l_co2_c4 * bc_in(s)%cair_pa(ifp) - end if - - niter = 0 - exitloop = 0 - do while(exitloop == 0) - ! Increment iteration counter. Stop if too many iterations - niter = niter + 1 - - ! Save old ci - ciold = ci - - ! Photosynthesis limitation rate calculations - if (nint(c3psn(FT)) == 1)then - ! C3: Rubisco-limited photosynthesis - ac = vcmax_z(cl,ft,iv) * max(ci-co2_cp(ifp), 0._r8) / (ci+kc(ifp)* & - (1._r8+bc_in(s)%oair_pa(ifp)/ko(ifp))) - ! C3: RuBP-limited photosynthesis - aj = je * max(ci-co2_cp(ifp), 0._r8) / (4._r8*ci+8._r8*co2_cp(ifp)) - ! C3: Product-limited photosynthesis - ap = 3._r8 * tpu_z(cl,ft,iv) - else - ! C4: Rubisco-limited photosynthesis - ac = vcmax_z(cl,ft,iv) - ! C4: RuBP-limited photosynthesis - if(sunsha == 1)then !sunlit - if((currentPatch%ed_laisun_z(cl,ft,iv) * currentPatch%canopy_area_profile(cl,ft,iv)) > & - 0.0000000001_r8)then !guard against /0's in the night. - aj = qe(ps) * currentPatch%ed_parsun_z(cl,ft,iv) * 4.6_r8 - !convert from per cohort to per m2 of leaf) - aj = aj / (currentPatch%ed_laisun_z(cl,ft,iv) * & - currentPatch%canopy_area_profile(cl,ft,iv)) - else - aj = 0._r8 - end if - else - aj = qe(ps) * currentPatch%ed_parsha_z(cl,ft,iv) * 4.6_r8 - aj = aj / (currentPatch%ed_laisha_z(cl,ft,iv) * & - currentPatch%canopy_area_profile(cl,ft,iv)) - end if - - ! C4: PEP carboxylase-limited (CO2-limited) - ap = kp_z(cl,ft,iv) * max(ci, 0._r8) / bc_in(s)%forc_pbot - end if - ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap - aquad = theta_cj(ps) - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) - - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (aquad, bquad, cquad, r1, r2) - ag(cl,ft,iv) = min(r1,r2) - - ! Net carbon assimilation. Exit iteration if an < 0 - an(cl,ft,iv) = ag(cl,ft,iv) - lmr_z(cl,ft,iv) - if (an(cl,ft,iv) < 0._r8) then - exitloop = 1 - end if - - ! Quadratic gs_mol calculation with an known. Valid for an >= 0. - ! With an <= 0, then gs_mol = bbb - - cs = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot - cs = max(cs,1.e-06_r8) - aquad = cs - bquad = cs*(gb_mol - bbb(FT)) - bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot - cquad = -gb_mol*(cs*bbb(FT) + & - bb_slope(ft)*an(cl,ft,iv)*bc_in(s)%forc_pbot*ceair/bc_in(s)%esat_tv_pa(ifp)) - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - - ! Derive new estimate for ci - ci = bc_in(s)%cair_pa(ifp) - an(cl,ft,iv) * bc_in(s)%forc_pbot * & - (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) - - ! Check for ci convergence. Delta ci/pair = mol/mol. Multiply by 10**6 to - ! convert to umol/mol (ppm). Exit iteration if convergence criteria of +/- 1 x 10**-6 ppm - ! is met OR if at least ten iterations (niter=10) are completed - - if ((abs(ci-ciold)/bc_in(s)%forc_pbot*1.e06_r8 <= 2.e-06_r8) .or. niter == 5) then - exitloop = 1 - end if - end do !iteration loop - - ! End of ci iteration. Check for an < 0, in which case gs_mol = bbb - if (an(cl,ft,iv) < 0._r8) then - gs_mol = bbb(FT) - end if - - ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) - cs = bc_in(s)%cair_pa(ifp) - 1.4_r8/gb_mol * an(cl,ft,iv) * bc_in(s)%forc_pbot - cs = max(cs,1.e-06_r8) - ci = bc_in(s)%cair_pa(ifp) - & - an(cl,ft,iv) * bc_in(s)%forc_pbot * (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) - ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) - gs = gs_mol / cf - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', ag(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', currentPatch%f_sun(cl,ft,iv) - - !accumulate total photosynthesis umol/m2 ground/s-1. weight per unit sun and sha leaves. - if(sunsha == 1)then !sunlit - - currentPatch%psn_z(cl,ft,iv) = currentPatch%psn_z(cl,ft,iv) + ag(cl,ft,iv) * & - currentPatch%f_sun(cl,ft,iv) - an_av(cl,ft,iv) = an_av(cl,ft,iv) + an(cl,ft,iv) * & - currentPatch%f_sun(cl,ft,iv) - gs_z(cl,ft,iv) = gs_z(cl,ft,iv) + 1._r8/(min(1._r8/gs, rsmax0)) * & - currentPatch%f_sun(cl,ft,iv) - - else - - currentPatch%psn_z(cl,ft,iv) = currentPatch%psn_z(cl,ft,iv) + ag(cl,ft,iv) & - * (1.0_r8-currentPatch%f_sun(cl,ft,iv)) - an_av(cl,ft,iv) = an_av(cl,ft,iv) + an(cl,ft,iv) & - * (1.0_r8-currentPatch%f_sun(cl,ft,iv)) - gs_z(cl,ft,iv) = gs_z(cl,ft,iv) + & - 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-currentPatch%f_sun(cl,ft,iv)) - - end if - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', currentPatch%psn_z(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', ag(cl,ft,iv) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', currentPatch%f_sun(cl,ft,iv) - - ! Make sure iterative solution is correct - if (gs_mol < 0._r8) then - write (fates_log(),*)'Negative stomatal conductance:' - write (fates_log(),*)'ifp,iv,gs_mol= ',ifp,iv,gs_mol - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b - hs = (gb_mol*ceair + gs_mol*bc_in(s)%esat_tv_pa(ifp)) / ((gb_mol+gs_mol)*bc_in(s)%esat_tv_pa(ifp)) - gs_mol_err = bb_slope(ft)*max(an(cl,ft,iv), 0._r8)*hs/cs*bc_in(s)%forc_pbot + bbb(FT) - - if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then - write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' - write (fates_log(),*) gs_mol, gs_mol_err - end if - - enddo !sunsha loop - !average leaf-level stomatal resistance rate over sun and shade leaves... - rs_z(cl,ft,iv) = 1._r8/gs_z(cl,ft,iv) - else !No leaf area. This layer is present only because of stems. (leaves are off, or have reduced to 0 - currentPatch%psn_z(cl,ft,iv) = 0._r8 - rs_z(CL,FT,iv) = min(rsmax0, 1._r8/bbb(FT) * cf) - - end if !is there leaf area? - - - end if ! night or day - end do ! iv canopy layer - end if ! present(L,ft) ? rd_array - end do ! PFT loop - end do !canopy layer - - !==============================================================================! - ! Unpack fluxes from arrays into cohorts - !==============================================================================! - - call currentPatch%set_root_fraction(bc_in(s)%depth_gl) - - if(currentPatch%countcohorts > 0.0)then !avoid errors caused by empty patches - - currentCohort => currentPatch%tallest ! Cohort loop - - do while (associated(currentCohort)) ! Cohort loop - - if(currentCohort%n > 0._r8)then - - ! Zero cohort flux accumulators. - currentCohort%npp_tstep = 0.0_r8 - currentCohort%resp_tstep = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%resp_m = 0.0_r8 - - ! Select canopy layer and PFT. - FT = currentCohort%pft !are we going to have ftindex? - CL = currentCohort%canopy_layer - !------------------------------------------------------------------------------ - ! Accumulate fluxes over the sub-canopy layers of each cohort. - !------------------------------------------------------------------------------ - ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). - tree_area = currentCohort%c_area/currentCohort%n - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 816 ', currentCohort%gpp_tstep - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 817 ', currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 818 ', cl - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 819 ', ft - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 820 ', currentCohort%nv - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 821 ', currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1) - - if (currentCohort%nv > 1) then !is there canopy, and are the leaves on? - - currentCohort%gpp_tstep = sum(currentPatch%psn_z(cl,ft,1:currentCohort%nv-1) * & - currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1)) * tree_area - - currentCohort%rdark = sum(lmr_z(cl,ft,1:currentCohort%nv-1) * & - currentPatch%elai_profile(cl,ft,1:currentCohort%nv-1)) * tree_area - - currentCohort%gscan = sum((1.0_r8/(rs_z(cl,ft,1:currentCohort%nv-1)+bc_in(s)%rb_pa(ifp)))) * tree_area - currentCohort%ts_net_uptake(1:currentCohort%nv) = an_av(cl,ft,1:currentCohort%nv) * umolC_to_kgC * dtime - - else - - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%gscan = 0.0_r8 - currentCohort%ts_net_uptake(:) = 0.0_r8 - - end if - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 832 ', currentCohort%gpp_tstep - - laifrac = (currentCohort%treelai+currentCohort%treesai)-(currentCohort%nv-1)*dinc_ed - - gs_cohort = 1.0_r8/(rs_z(cl,ft,currentCohort%nv)+bc_in(s)%rb_pa(ifp))*laifrac*tree_area - currentCohort%gscan = currentCohort%gscan+gs_cohort - - if ( DEBUG ) then - write(fates_log(),*) 'EDPhoto 868 ', currentCohort%gpp_tstep - write(fates_log(),*) 'EDPhoto 869 ', currentPatch%psn_z(cl,ft,currentCohort%nv) - write(fates_log(),*) 'EDPhoto 870 ', currentPatch%elai_profile(cl,ft,currentCohort%nv) - write(fates_log(),*) 'EDPhoto 871 ', laifrac - write(fates_log(),*) 'EDPhoto 872 ', tree_area - write(fates_log(),*) 'EDPhoto 873 ', currentCohort%nv, cl, ft - endif - - currentCohort%gpp_tstep = currentCohort%gpp_tstep + currentPatch%psn_z(cl,ft,currentCohort%nv) * & - currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 843 ', currentCohort%rdark - - - currentCohort%rdark = currentCohort%rdark + lmr_z(cl,ft,currentCohort%nv) * & - currentPatch%elai_profile(cl,ft,currentCohort%nv) * laifrac * tree_area - - ! Convert dark respiration from umol/plant/s to kgC/plant/s - currentCohort%rdark = currentCohort%rdark * umolC_to_kgC - - leaf_frac = 1.0_r8/(currentCohort%canopy_trim + EDecophyscon%sapwood_ratio(currentCohort%pft) * & - currentCohort%hite + EDPftvarcon_inst%froot_leaf(currentCohort%pft)) - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! THIS CALCULATION SHOULD BE MOVED TO THE ALLOMETRY MODULE (RGK 10-8-2016) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * & - currentCohort%hite * (currentCohort%balive + currentCohort%laimemory)*leaf_frac - - ! Calculate the amount of nitrogen in the above and below ground - ! stem and root pools, used for maint resp - ! We are using the fine-root C:N ratio as an approximation for - ! the sapwood pools. - ! Units are in (kgN/plant) - ! ------------------------------------------------------------------ - live_stem_n = ED_val_ag_biomass * currentCohort%bsw / & - frootcn(currentCohort%pft) - live_croot_n = (1.0_r8-ED_val_ag_biomass) * currentCohort%bsw / & - frootcn(currentCohort%pft) - froot_n = currentCohort%br / frootcn(currentCohort%pft) - - - !------------------------------------------------------------------------------ - ! Calculate Whole Plant Respiration (this doesn't really need to be in this iteration at all, surely?) - ! Leaf respn needs to be in the sub-layer loop to account for changing N through canopy. - !------------------------------------------------------------------------------ - - ! Live stem MR (kgC/plant/s) (above ground sapwood) - ! ------------------------------------------------------------------ - if (woody(ft) == 1) then - tc = q10**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) - ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_stem_n * base_mr_20 * tc - else - currentCohort%livestem_mr = 0._r8 - end if - - - ! Fine Root MR (kgC/plant/s) - ! ------------------------------------------------------------------ - currentCohort%froot_mr = 0._r8 - do j = 1,cp_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) - enddo - - ! Coarse Root MR (kgC/plant/s) (below ground sapwood) - ! ------------------------------------------------------------------ - if (woody(ft) == 1) then - currentCohort%livecroot_mr = 0._r8 - do j = 1,cp_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 + & - live_croot_n * base_mr_20 * tcsoi * & - currentPatch%rootfr_ft(ft,j) - enddo - else - currentCohort%livecroot_mr = 0._r8 - end if - - ! convert gpp from umol/indiv/s-1 to kgC/indiv/s-1 = X * 12 *10-6 * 10-3 - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr - - currentCohort%gpp_tstep = currentCohort%gpp_tstep * umolC_to_kgC - ! add on whole plant respiration values in kgC/indiv/s-1 - currentCohort%resp_m = currentCohort%livestem_mr + currentCohort%livecroot_mr + currentCohort%froot_mr - ! no drought response * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft)*EDPftvarcon_inst%resp_drought_response(FT)) - currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark - - ! convert from kgC/indiv/s to kgC/indiv/timestep - currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep - if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - - currentCohort%resp_g = EDPftvarcon_inst%grperc(ft) * & - (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) - currentCohort%resp_tstep = currentCohort%resp_m + currentCohort%resp_g ! kgC/indiv/ts - currentCohort%npp_tstep = currentCohort%gpp_tstep - currentCohort%resp_tstep ! kgC/indiv/ts - - !------------------------------------------------------------------------------ - ! Remove whole plant respiration from net uptake. (kgC/indiv/ts) - if(currentCohort%treelai > 0._r8)then - ! do iv =1,currentCohort%NV - ! currentCohort%year_net_uptake(iv) = currentCohort%year_net_uptake(iv) - & - ! (timestep_secs*(currentCohort%livestem_mr + currentCohort%livecroot_mr & - ! minus contribution to whole plant respn. - ! + currentCohort%froot_mr))/(currentCohort%treelai*currentCohort%c_area/currentCohort%n) - ! enddo - else !lai<0 - currentCohort%gpp_tstep = 0._r8 - currentCohort%resp_m = 0._r8 - currentCohort%gscan = 0._r8 - end if - else !pft<0 n<0 - write(fates_log(),*) 'CF: pft 0 or n 0',currentCohort%pft,currentCohort%n,currentCohort%indexnumber - currentCohort%gpp_tstep = 0._r8 - currentCohort%resp_m = 0._r8 - currentCohort%gscan = 0._r8 - currentCohort%ts_net_uptake(1:currentCohort%nv) = 0._r8 - end if !pft<0 n<0 - - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) + currentCohort%gpp_tstep - bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) + currentCohort%resp_m - ! accumulate cohort level canopy conductances over whole area before dividing by total area. - bc_out(s)%gccanopy_pa(ifp) = bc_out(s)%gccanopy_pa(ifp) + currentCohort%gscan * & - currentCohort%n /currentPatch%total_canopy_area - - currentCohort => currentCohort%shorter - - enddo ! end cohort loop. - end if !count_cohorts is more than zero. - - - elai = calc_areaindex(currentPatch,'elai') - - bc_out(s)%psncanopy_pa(ifp) = bc_out(s)%psncanopy_pa(ifp) / currentPatch%area - bc_out(s)%lmrcanopy_pa(ifp) = bc_out(s)%lmrcanopy_pa(ifp) / currentPatch%area - if(bc_out(s)%gccanopy_pa(ifp) > 1._r8/rsmax0 .and. elai > 0.0_r8)then - rscanopy = (1.0_r8/bc_out(s)%gccanopy_pa(ifp))-bc_in(s)%rb_pa(ifp)/elai ! this needs to be resistance per unit leaf area. - else - rscanopy = rsmax0 - end if - bc_out(s)%rssun_pa(ifp) = rscanopy - bc_out(s)%rssha_pa(ifp) = rscanopy - bc_out(s)%gccanopy_pa(ifp) = 1.0_r8/rscanopy*cf/umol_per_mmol !convert into umol m-2 s-1 then mmol m-2 s-1. - end if - - currentPatch => currentPatch%younger - - end do - - end do !site loop - - end associate - -end subroutine Photosynthesis_ED - -! ======================================================================================= - -function ft1_f(tl, ha) result(ans) - ! - !!DESCRIPTION: - ! photosynthesis temperature response - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) - real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- - - ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) - - return - end function ft1_f - - ! ===================================================================================== - - function fth_f(tl,hd,se,scaleFactor) result(ans) - ! - !!DESCRIPTION: - !photosynthesis temperature inhibition - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) - real(r8), intent(in) :: scaleFactor ! scaling factor for high temperature inhibition (25 C = 1.0) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- - - ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) - - return - end function fth_f - - ! ===================================================================================== - - function fth25_f(hd,se)result(ans) - ! - !!DESCRIPTION: - ! scaling factor for photosynthesis temperature inhibition - ! - ! !REVISION HISTORY: - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES - - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - - ! - ! !ARGUMENTS: - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temperature function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temperature function (J/mol/K) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- - - ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) - - return - end function fth25_f - - ! ===================================================================================== - - subroutine quadratic_f (a, b, c, r1, r2) - ! - ! !DESCRIPTION: - !==============================================================================! - !----------------- Solve quadratic equation for its two roots -----------------! - !==============================================================================! - ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific - ! Computing (Cambridge University Press, Cambridge), pp. 145. - ! - ! !REVISION HISTORY: - ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: a,b,c ! Terms for quadratic equation - real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation - ! - ! !LOCAL VARIABLES: - real(r8) :: q ! Temporary term for quadratic solution - !------------------------------------------------------------------------------ - - if (a == 0._r8) then - write (fates_log(),*) 'Quadratic solution error: a = ',a - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if (b >= 0._r8) then - q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) - else - q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) - end if - - r1 = q / a - if (q /= 0._r8) then - r2 = c / q - else - r2 = 1.e36_r8 - end if - - end subroutine quadratic_f - -end module EDPhotosynthesisMod diff --git a/components/clm/src/ED/biogeophys/FatesPlantRespPhotosynthMod.F90 b/components/clm/src/ED/biogeophys/FatesPlantRespPhotosynthMod.F90 new file mode 100644 index 0000000000..8f530d5444 --- /dev/null +++ b/components/clm/src/ED/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -0,0 +1,1631 @@ +module FATESPlantRespPhotosynthMod + + !------------------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculates the plant respiration and photosynthetic fluxes for the FATES model + ! This code is similar to and was originally based off of the 'photosynthesis' + ! subroutine in the CLM model. + ! + ! Parameter for activation and deactivation energies were taken from: + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + ! High temperature deactivation, from: + ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 + ! The factor "c" scales the deactivation to a value of 1.0 at 25C + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! ------------------------------------------------------------------------------------ + + ! !USES: + + use abortutils, only : 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 + + implicit none + private + + public :: FatesPlantRespPhotosynthDrive ! Called by the HLM-Fates interface + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------------------- + + ! maximum stomatal resistance [s/m] (used across several procedures) + real(r8),parameter :: rsmax0 = 2.e4_r8 + + logical :: DEBUG = .false. + +contains + + !-------------------------------------------------------------------------------------- + + subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) + + ! ----------------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Leaf photosynthesis and stomatal conductance calculation as described by + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to + ! a multi-layer canopy + ! ----------------------------------------------------------------------------------- + + + ! !USES: + + use clm_varpar , only : mxpft ! THIS WILL BE DEPRECATED WHEN PARAMETER + ! READS ARE REFACTORED (RGK 10-13-2016) + use EDPftvarcon , only : EDPftvarcon_inst ! THIS WILL BE DEPRECATED WHEN PARAMETER + ! READS ARE REFACTORED (RGK 10-13-2016) + use EDParamsMod , only : ED_val_ag_biomass + use EDSharedParamsMod , only : EDParamsShareInst + 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 EDEcophysContype , only : EDecophyscon + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + use EDCanopyStructureMod, only : calc_areaindex + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : umol_per_mmol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesParameterDerivedMod, only : param_derived + + + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + real(r8),intent(in) :: dtime + + + ! LOCAL VARIABLES: + ! ----------------------------------------------------------------------------------- + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type), pointer :: currentCohort + + ! ----------------------------------------------------------------------------------- + ! These three arrays hold leaf-level biophysical rates that are calculated + ! in one loop and then sent to the cohorts in another loop. If hydraulics are + ! on, we calculate a unique solution for each level-cohort-layer combination. + ! If we are not using hydraulics, we calculate a unique solution for each + ! level-pft-layer combination. Thus the following three arrays are statically + ! allocated for the maximum space of the two cases (numCohortsPerPatch) + ! The "_z" suffix indicates these variables are discretized at the "leaf_layer" + ! scale. + ! Note: For these temporary arrays, we have the leaf layer dimension first + ! and the canopy layer last. This order is chosen for efficiency. The arrays + ! such as leaf area that are bound to the patch structure DO NOT follow this order + ! as they are used in many other parts of the code with different looping, we + ! are not modifying its order now. + ! ----------------------------------------------------------------------------------- + + ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this + real(r8) :: lmr_z(cp_nlevcan,mxpft,cp_nclmax) + + ! stomatal resistance s/m + real(r8) :: rs_z(cp_nlevcan,mxpft,cp_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) + + ! Mask used to determine which leaf-layer biophysical rates have been + ! used already + logical :: rate_mask_z(cp_nlevcan,mxpft,cp_nclmax) + + real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation + ! (umol co2/m**2/s) + real(r8) :: jmax_z ! leaf layer maximum electron transport rate + ! (umol electrons/m**2/s) + real(r8) :: tpu_z ! leaf layer triose phosphate utilization rate + ! (umol CO2/m**2/s) + real(r8) :: kp_z ! leaf layer initial slope of CO2 response + ! curve (C4 plants) + + real(r8) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) + real(r8) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8) :: kn(mxpft) ! leaf nitrogen decay coefficient + real(r8) :: cf ! s m**2/umol -> s/m + real(r8) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8) :: nscaler ! leaf nitrogen scaling coefficient + real(r8) :: leaf_frac ! ratio of to leaf biomass to total alive biomass + real(r8) :: laican ! canopy sum of lai_z + real(r8) :: vai ! leaf and steam area in ths layer. + real(r8) :: tcsoi ! Temperature response function for root respiration. + real(r8) :: tcwood ! Temperature response function for wood + real(r8) :: rscanopy ! Canopy resistance [s/m] + real(r8) :: elai ! exposed LAI (patch scale) + real(r8) :: live_stem_n ! Live stem (above-ground sapwood) + ! nitrogen content (kgN/plant) + real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) + ! nitrogen content (kgN/plant) + real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) + real(r8) :: gccanopy_pa ! Patch level canopy stomatal conductance [mmol m-2 s-1] + + ! ----------------------------------------------------------------------------------- + ! Keeping these two definitions in case they need to be added later + ! + ! ----------------------------------------------------------------------------------- + !real(r8) :: psncanopy_pa ! patch sunlit leaf photosynthesis (umol CO2 /m**2/ s) + !real(r8) :: lmrcanopy_pa ! patch sunlit leaf maintenance respiration rate (umol CO2/m**2/s) + + integer :: cl,s,iv,j,ps,ft,ifp ! indices + integer :: nv ! number of leaf layers + integer :: NCL_p ! number of canopy layers in patch + + ! Parameters + ! ----------------------------------------------------------------------- + ! Base maintenance respiration rate for plant tissues base_mr_20 + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + ! + ! Base rate is at 20C. Adjust to 25C using the CN Q10 = 1.5 + ! (gC/gN/s) + ! ------------------------------------------------------------------------ + + real(r8),parameter :: base_mr_20 = 2.525e-6_r8 + + ! ----------------------------------------------------------------------------------- + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! ----------------------------------------------------------------------------------- + + ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) + ! For C3 and C4 plants + ! ----------------------------------------------------------------------------------- + ! TO-DO: bbbopt is slated to be transferred to the parameter file + ! ----------------------------------------------------------------------------------- + real(r8),parameter, dimension(2) :: bbbopt = [10000._r8,40000._r8] + + + associate( & + c3psn => EDPftvarcon_inst%c3psn , & + slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, + ! projected area basis [m^2/gC] + flnr => EDPftvarcon_inst%flnr , & ! fraction of leaf N in the Rubisco + ! enzyme (gN Rubisco / gN leaf) + woody => EDPftvarcon_inst%woody , & ! Is vegetation woody or not? + fnitr => EDPftvarcon_inst%fnitr , & ! foliage nitrogen limitation factor (-) + leafcn => EDPftvarcon_inst%leafcn , & ! leaf C:N (gC/gN) + frootcn => EDPftvarcon_inst%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship + q10 => EDParamsShareInst%Q10 ) + + + do s = 1,nsites + + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + + ifp = ifp+1 + NCL_p = currentPatch%NCL_p + + ! Part I. Zero output boundary conditions + ! --------------------------------------------------------------------------- + bc_out(s)%rssun_pa(ifp) = 0._r8 + bc_out(s)%rssha_pa(ifp) = 0._r8 + + gccanopy_pa = 0._r8 + + !psncanopy_pa = 0._r8 + !lmrcanopy_pa = 0._r8 + + ! Part II. Filter out patches + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis already + ! --------------------------------------------------------------------------- + if(bc_in(s)%filter_photo_pa(ifp)==2)then + + + ! Part III. Calculate the number of sublayers for each pft and layer. + ! And then identify which layer/pft combinations have things in them. + ! Output: + ! currentPatch%ncan(:,:) + ! currentPatch%present(:,:) + call UpdateCanopyNCanNRadPresent(currentPatch) + + + ! Part IV. Identify some environmentally derived parameters: + ! These quantities are biologically irrelevant + ! Michaelis-Menten constant for CO2 (Pa) + ! Michaelis-Menten constant for O2 (Pa) + ! CO2 compensation point (Pa) + ! CF? I have no idea what cf is (rgk 12-01-2016) + ! leaf boundary layer conductance of h20 + ! constrained vapor pressure + call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in + bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%tgcm_pa(ifp), & ! in + bc_in(s)%eair_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in + mm_kco2, & ! out + mm_ko2, & ! out + co2_cpoint, & ! out + cf, & ! out + gb_mol, & ! out + ceair) ! out + + ! Part V. Pre-process some variables that are PFT dependent + ! but not environmentally dependent + ! ------------------------------------------------------------------------ + + do ft = 1,numpft_ed + + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al + ! (2010) Biogeosciences, 7, 1833-1859 + ! Remove daylength factor from vcmax25 so that kn is based on maximum vcmax25 + + if (bc_in(s)%dayl_factor_pa(ifp) == 0._r8) then + kn(ft) = 0._r8 + else + kn(ft) = exp(0.00963_r8 * param_derived%vcmax25top(ft) - 2.43_r8) + end if + + end do !ft + + call currentPatch%set_root_fraction(bc_in(s)%depth_gl) + + ! ------------------------------------------------------------------------ + ! Part VI: Loop over all leaf layers. + ! The concept of leaf layers is a result of the radiative transfer scheme. + ! A leaf layer has uniform radiation environment. Leaf layers are a group + ! of vegetation surfaces (stems and leaves) which inhabit the same + ! canopy-layer "CL", have the same functional type "ft" and within those + ! two partitions are further partitioned into vertical layers where + ! downwelling radiation attenuates in order. + ! In this phase we loop over the leaf layers and calculate the + ! photosynthesis and respiration of the layer (since all biophysical + ! properties are homogeneous). After this step, we can loop through + ! our cohort list, associate each cohort with its list of leaf-layers + ! and transfer these quantities to the cohort. + ! With plant hydraulics, we must realize that photosynthesis and + ! respiration will be different for leaves of each cohort in the leaf + ! layers, as they will have there own hydraulic limitations. + ! NOTE: Only need to flush mask on the number of used pfts, not the whole + ! scratch space. + ! ------------------------------------------------------------------------ + rate_mask_z(:,1:numpft_ed,:) = .false. + + if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) ! Cohort loop + + ! Identify the canopy layer (cl), functional type (ft) + ! and the leaf layer (IV) for this cohort + ft = currentCohort%pft + cl = currentCohort%canopy_layer + + + ! are there any leaves of this pft in this layer? + if(currentPatch%present(cl,ft) == 1)then + + if(cl==NCL_p)then !are we in the top canopy layer or a shaded layer? + laican = 0._r8 + else + laican = sum(currentPatch%canopy_layer_lai(cl+1:NCL_p)) + end if + + ! Loop over leaf-layers + do iv = 1,currentCohort%nv + + ! ------------------------------------------------------------ + ! If we are doing plant hydro-dynamics (or any run-type + ! where cohorts may generate different photosynthetic rates + ! of other cohorts in the same canopy-pft-layer combo), + ! we re-calculate the leaf biophysical rates for the + ! cohort-layer combo of interest. + ! but in the vanilla case, we only re-calculate if it has + ! not been done yet. + ! ------------------------------------------------------------ + + if ( .not.rate_mask_z(iv,ft,cl) .or. use_fates_plant_hydro ) then + + if (use_fates_plant_hydro) then + write(fates_log(),*) 'use_fates_plant_hydro in EDTypes' + write(fates_log(),*) 'has been set to true. You have inadvertently' + write(fates_log(),*) 'turned on a future feature that is not in the' + write(fates_log(),*) 'FATES codeset yet. Please set this to' + write(fates_log(),*) 'false and re-compile.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + !! !! bbb = max (bbbopt(ps)*currentCohort%btran(iv), 1._r8) + !! !! btran = currentCohort%btran(iv) + else + bbb = max (bbbopt(nint(c3psn(ft)))*currentPatch%btran_ft(ft), 1._r8) + btran_eff = currentPatch%btran_ft(ft) + end if + + ! Vegetation area index + vai = (currentPatch%elai_profile(cl,ft,iv)+currentPatch%esai_profile(cl,ft,iv)) + if (iv == 1) then + laican = laican + 0.5_r8 * vai + else + laican = laican + 0.5_r8 * (currentPatch%elai_profile(cl,ft,iv-1)+ & + currentPatch%esai_profile(cl,ft,iv-1))+vai + end if + + ! Scale for leaf nitrogen profile + nscaler = exp(-kn(ft) * laican) + + ! Part VII: Calculate dark respiration (leaf maintenance) for this layer + call LeafLayerMaintenanceRespiration( param_derived%lmr25top(ft),& ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(iv,ft,cl)) ! out + + ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), + ! (2) maximum electron transport rate, (3) triose phosphate + ! utilization rate and (4) the initial slope of CO2 response curve + ! (C4 plants). Earlier we calculated their base rates as dictated + ! by their plant functional type and some simple scaling rules for + ! nitrogen limitation baesd on canopy position (not prognostic). + ! These rates are the specific rates used in the actual photosynthesis + ! calculations that take localized environmental effects (temperature) + ! into consideration. + + call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in + ft, & ! in + param_derived%vcmax25top(ft), & ! in + param_derived%jmax25top(ft), & ! in + param_derived%tpu25top(ft), & ! in + param_derived%kp25top(ft), & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + btran_eff, & ! in + vcmax_z, & ! out + jmax_z, & ! out + tpu_z, & ! out + kp_z ) ! out + + ! Part IX: This call calculates the actual photosynthesis for the + ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. + + call LeafLayerPhotosynthesis(currentPatch%f_sun(cl,ft,iv), & ! in + currentPatch%ed_parsun_z(cl,ft,iv), & ! in + currentPatch%ed_parsha_z(cl,ft,iv), & ! in + currentPatch%ed_laisun_z(cl,ft,iv), & ! in + currentPatch%ed_laisha_z(cl,ft,iv), & ! in + currentPatch%canopy_area_profile(cl,ft,iv), & ! in + ft, & ! in + vcmax_z, & ! in + jmax_z, & ! in + tpu_z, & ! in + kp_z, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + bbb, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(iv,ft,cl), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(iv,ft,cl), & ! out + anet_av_z(iv,ft,cl)) ! out + + rate_mask_z(iv,ft,cl) = .true. + end if + end do + + ! Zero cohort flux accumulators. + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%resp_m = 0.0_r8 + currentCohort%ts_net_uptake = 0.0_r8 + + ! --------------------------------------------------------------- + ! Part VII: Transfer leaf flux rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the + ! leaf layer (which is area independent, ie /m2) onto each cohort + ! (where the rates become per cohort, ie /individual). Most likely + ! a sum over layers. + ! --------------------------------------------------------------- + nv = currentCohort%nv + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + anet_av_z(1:nv,ft,cl), & !in + currentPatch%elai_profile(cl,ft,1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + currentCohort%treelai, & !in + currentCohort%treesai, & !in + bc_in(s)%rb_pa(ifp), & !in + currentCohort%gscan, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark) !out + + ! Net Uptake does not need to be scaled, just transfer directly + currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC + + else + + ! In this case, the cohort had no leaves, + ! so no productivity,conductance, transpiration uptake + ! or dark respiration + + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%gscan = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 + + end if ! if(currentPatch%present(cl,ft) == 1)then + + + ! ------------------------------------------------------------------ + ! Part VIII: Calculate maintenance respiration in the sapwood and + ! fine root pools. + ! ------------------------------------------------------------------ + + leaf_frac = 1.0_r8/(currentCohort%canopy_trim + & + EDecophyscon%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite + EDPftvarcon_inst%froot_leaf(currentCohort%pft)) + + + currentCohort%bsw = EDecophyscon%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite * & + (currentCohort%balive + currentCohort%laimemory)*leaf_frac + + + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) + ! ------------------------------------------------------------------ + live_stem_n = ED_val_ag_biomass * currentCohort%bsw / & + frootcn(currentCohort%pft) + live_croot_n = (1.0_r8-ED_val_ag_biomass) * currentCohort%bsw / & + frootcn(currentCohort%pft) + froot_n = currentCohort%br / frootcn(currentCohort%pft) + + + !------------------------------------------------------------------------------ + ! Calculate Whole Plant Respiration + ! (this doesn't really need to be in this iteration at all, surely?) + ! Response: (RGK 12-2016): I think the positioning of these calls is + ! appropriate as of now. Maintenance calculations in sapwood and roots + ! vary by cohort and with changing temperature at the minimum, and there are + ! no sub-pools chopping up those pools any finer that need to be dealty with. + !------------------------------------------------------------------------------ + + ! Live stem MR (kgC/plant/s) (above ground sapwood) + ! ------------------------------------------------------------------ + if (woody(ft) == 1) then + tcwood = q10**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s + currentCohort%livestem_mr = live_stem_n * base_mr_20 * tcwood + else + currentCohort%livestem_mr = 0._r8 + end if + + + ! Fine Root MR (kgC/plant/s) + ! ------------------------------------------------------------------ + currentCohort%froot_mr = 0._r8 + do j = 1,cp_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) + enddo + + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) + ! ------------------------------------------------------------------ + if (woody(ft) == 1) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,cp_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 + & + live_croot_n * base_mr_20 * tcsoi * & + currentPatch%rootfr_ft(ft,j) + enddo + else + currentCohort%livecroot_mr = 0._r8 + end if + + + ! ------------------------------------------------------------------ + ! Part IX: Perform some unit conversions (rate to integrated) and + ! calcualate some fluxes that are sums and nets of the base fluxes + ! ------------------------------------------------------------------ + + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + + + + ! add on whole plant respiration values in kgC/indiv/s-1 + currentCohort%resp_m = currentCohort%livestem_mr + & + currentCohort%livecroot_mr + & + currentCohort%froot_mr + + ! no drought response right now.. something like: + ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & + ! EDPftvarcon_inst%resp_drought_response(ft)) + + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + + ! convert from kgC/indiv/s to kgC/indiv/timestep + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + + currentCohort%resp_g = EDPftvarcon_inst%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - & + currentCohort%resp_m)) + currentCohort%resp_tstep = currentCohort%resp_m + & + currentCohort%resp_g ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - & + currentCohort%resp_tstep ! kgC/indiv/ts + + ! Accumulate stomatal conductance over the patch + gccanopy_pa = gccanopy_pa + & + currentCohort%gscan * & + currentCohort%n /currentPatch%total_canopy_area + + !psncanopy_pa = psncanopy_pa + currentCohort%gpp_tstep + !lmrcanopy_pa = lmrcanopy_pa + currentCohort%resp_m + + currentCohort => currentCohort%shorter + + enddo ! end cohort loop. + end if !count_cohorts is more than zero. + + + elai = calc_areaindex(currentPatch,'elai') + + !psncanopy_pa(ifp) = psncanopy_pa(ifp) / currentPatch%area + !lmrcanopy_pa(ifp) = lmrcanopy_pa(ifp) / currentPatch%area + + if(gccanopy_pa > 1._r8/rsmax0 .and. elai > 0.0_r8)then + rscanopy = (1.0_r8/gccanopy_pa)-bc_in(s)%rb_pa(ifp)/elai + else + rscanopy = rsmax0 + end if + + bc_out(s)%rssun_pa(ifp) = rscanopy + bc_out(s)%rssha_pa(ifp) = rscanopy + + + end if + + currentPatch => currentPatch%younger + + end do + + end do !site loop + + end associate + end subroutine FatesPlantRespPhotosynthDrive + + ! ======================================================================================= + + subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in + parsun_lsl, & ! in + parsha_lsl, & ! in + laisun_lsl, & ! in + laisha_lsl, & ! in + canopy_area_lsl, & ! in + ft, & ! in + vcmax, & ! in + jmax, & ! in + tpu, & ! in + co2_rcurve_islope, & ! in + veg_tempk, & ! in + veg_esat, & ! in + can_press, & ! in + can_co2_ppress, & ! in + can_o2_ppress, & ! in + btran, & ! in + bbb, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr, & ! in + psn_out, & ! out + rstoma_out, & ! out + anet_av_out) ! out + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates photosynthesis and stomatal conductance within each leaf + ! sublayer. + ! A note on naming conventions: As this subroutine is called for every + ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" + ! (LSL), those variables are given a dimension tag "_lsl" + ! Other arguments or variables may be indicative of scales broader than the LSL. + ! ------------------------------------------------------------------------------------ + + use EDEcophysContype , only : EDecophyscon + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + ! ------------------------------------------------------------------------------------ + real(r8), intent(in) :: f_sun_lsl ! + real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves + real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves + real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves + real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves + real(r8), intent(in) :: canopy_area_lsl ! + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) + + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively + ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference + ! point for these input values are NOT within that boundary layer that separates the stomata from + ! the canopy air space. The reference point for these is on the outside of that boundary + ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the + ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy + ! but most likely it is the closest value one can get to the edge of the leaf's boundary + ! layer. We use the convention "can_" because a reference point of within the canopy + ! ia a best reasonable scenario of where we can get that information from. + + real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) + real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + real(r8), intent(in) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8), intent(in) :: cf ! s m**2/umol -> s/m + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s + real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) + real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) + ! averaged over sun and shade leaves. + + ! Locals + ! ------------------------------------------------------------------------ + integer :: pp_type ! Index for the different photosynthetic pathways C3,C4 + integer :: sunsha ! Index for differentiating sun and shade + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) + real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: co2_intra_c ! intracellular leaf CO2 (Pa) + real(r8) :: co2_intra_c_old ! intracellular leaf CO2 (Pa) (previous iteration) + logical :: loop_continue ! Loop control variable + integer :: niter ! iteration loop index + real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ap ! product-limited (C3) or CO2-limited + ! (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: init_co2_intra_c ! First guess intracellular co2 specific to C path + ! Parameters + ! ------------------------------------------------------------------------ + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! empirical curvature parameter for electron transport rate + real(r8),parameter :: theta_psii = 0.7_r8 + + ! First guess on ratio between intracellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + + ! quantum efficiency, used only for C4 (mol CO2 / mol photons) + real(r8),parameter,dimension(2) :: quant_eff = [0.0_r8,0.05_r8] + + ! empirical curvature parameter for ac, aj photosynthesis co-limitation + real(r8),parameter,dimension(2) :: theta_cj = [0.98_r8,0.80_r8] + + ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8),parameter :: theta_ip = 0.95_r8 + + associate( bb_slope => EDecophyscon%BB_slope ) ! slope of BB relationship + + if (nint(EDPftvarcon_inst%c3psn(ft)) == 1) then! photosynthetic pathway: 0. = c4, 1. = c3 + pp_type = 1 + init_co2_intra_c = init_a2l_co2_c3 * can_co2_ppress + else + pp_type = 2 + init_co2_intra_c = init_a2l_co2_c4 * can_co2_ppress + end if + + ! Part III: Photosynthesis and Conductance + ! ---------------------------------------------------------------------------------- + + if ( parsun_lsl <= 0._r8 ) then ! night time + + anet_av_out = 0._r8 + psn_out = 0._r8 + rstoma_out = min(rsmax0, 1._r8/bbb * cf) + + else ! day time (a little bit more complicated ...) + +! if ( DEBUG ) write(fates_log(),*) 'EDphot 594 ',laisun_lsl +! if ( DEBUG ) write(fates_log(),*) 'EDphot 595 ',laisha_lsl + + !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + if ( laisun_lsl + laisha_lsl > 0._r8 ) then + +! if ( DEBUG ) write(fates_log(),*) '600 in laisun, laisha loop ' + + !Loop aroun shaded and unshaded leaves + psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. + rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + anet_av_out = 0._r8 + gstoma = 0._r8 + + do sunsha = 1,2 + ! Electron transport rate for C3 plants. + ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 + ! Convert from units of par absorbed per unit ground area to par + ! absorbed per unit leaf area. + + if(sunsha == 1)then !sunlit + if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then + + qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + + else + qabs = 0.0_r8 + end if + else + + qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + + end if + + !convert the absorbed par into absorbed par per m2 of leaf, + ! so it is consistant with the vcmax and lmr numbers. + aquad = theta_psii + bquad = -(qabs + jmax) + cquad = qabs * jmax + call quadratic_f (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) + + ! Initialize intracellular co2 + co2_intra_c = init_co2_intra_c + + niter = 0 + loop_continue = .true. + do while(loop_continue) + ! Increment iteration counter. Stop if too many iterations + niter = niter + 1 + + ! Save old co2_intra_c + co2_intra_c_old = co2_intra_c + + ! Photosynthesis limitation rate calculations + if (pp_type == 1)then + + ! C3: Rubisco-limited photosynthesis + ac = vcmax * max(co2_intra_c-co2_cpoint, 0._r8) / & + (co2_intra_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) + + ! C3: RuBP-limited photosynthesis + aj = je * max(co2_intra_c-co2_cpoint, 0._r8) / & + (4._r8*co2_intra_c+8._r8*co2_cpoint) + + ! C3: Product-limited photosynthesis + ap = 3._r8 * tpu + + else + + ! C4: Rubisco-limited photosynthesis + ac = vcmax + + ! C4: RuBP-limited photosynthesis + if(sunsha == 1)then !sunlit + !guard against /0's in the night. + if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then + aj = quant_eff(pp_type) * parsun_lsl * 4.6_r8 + !convert from per cohort to per m2 of leaf) + aj = aj / (laisun_lsl * canopy_area_lsl) + else + aj = 0._r8 + end if + else + aj = quant_eff(pp_type) * parsha_lsl * 4.6_r8 + aj = aj / (laisha_lsl * canopy_area_lsl) + end if + + ! C4: PEP carboxylase-limited (CO2-limited) + ap = co2_rcurve_islope * max(co2_intra_c, 0._r8) / can_press + + end if + + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + aquad = theta_cj(pp_type) + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + + ! Net carbon assimilation. Exit iteration if an < 0 + anet = agross - lmr + if (anet < 0._r8) then + loop_continue = .false. + end if + + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = bbb + + leaf_co2_ppress = can_co2_ppress- 1.4_r8/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - bbb) - bb_slope(ft) * anet * can_press + cquad = -gb_mol*(leaf_co2_ppress*bbb + & + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) + + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + ! Derive new estimate for co2_intra_c + co2_intra_c = can_co2_ppress - anet * can_press * & + (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + + ! Check for co2_intra_c convergence. Delta co2_intra_c/pair = mol/mol. + ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if + ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten + ! iterations (niter=10) are completed + + if ((abs(co2_intra_c-co2_intra_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & + .or. niter == 5) then + loop_continue = .false. + end if + end do !iteration loop + + ! End of co2_intra_c iteration. Check for an < 0, in which case gs_mol = bbb + if (anet < 0._r8) then + gs_mol = bbb + end if + + ! Final estimates for leaf_co2_ppress and co2_intra_c + ! (needed for early exit of co2_intra_c iteration when an < 0) + leaf_co2_ppress = can_co2_ppress - 1.4_r8/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_intra_c = can_co2_ppress - anet * can_press * & + (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + + ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) + gs = gs_mol / cf + +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', psn_out +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', agross +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', f_sun_lsl + + ! Accumulate total photosynthesis umol/m2 ground/s-1. + ! weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + psn_out = psn_out + agross * f_sun_lsl + anet_av_out = anet_av_out + anet * f_sun_lsl + gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl + else + psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) + anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) + gstoma = gstoma + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) + end if + +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', psn_out +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', agross +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', f_sun_lsl + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'gs_mol= ',gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress p + b + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + bbb + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' + write (fates_log(),*) gs_mol, gs_mol_err + end if + + enddo !sunsha loop + + !average leaf-level stomatal resistance rate over sun and shade leaves... + rstoma_out = 1._r8/gstoma + + else + !No leaf area. This layer is present only because of stems. + ! (leaves are off, or have reduced to 0) + psn_out = 0._r8 + rstoma_out = min(rsmax0, 1._r8/bbb * cf) + + end if !is there leaf area? + + + end if ! night or day + end associate + return + end subroutine LeafLayerPhotosynthesis + + ! ===================================================================================== + + subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv + psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) + lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) + rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) + anet_av_llz, & ! in anet_av_z(1:currentCohort%nv,ft,cl) + elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) + c_area, & ! in currentCohort%c_area + nplant, & ! in currentCohort%n + treelai, & ! in currentCohort%treelai + treesai, & ! in currentCohort%treesai + rb, & ! in bc_in(s)%rb_pa(ifp) + gscan, & ! out currentCohort%gscan + gpp, & ! out currentCohort%gpp_tstep + rdark) ! out currentCohort%rdark + + ! ------------------------------------------------------------------------------------ + ! This subroutine effectively integrates leaf carbon fluxes over the + ! leaf layers to give cohort totals. + ! Some arguments have the suffix "_llz". This indicates that the vector + ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling + ! array which has the "_z" tag, thus "llz". + ! ------------------------------------------------------------------------------------ + + use FatesConstantsMod, only : umolC_to_kgC + use EDTypesMod, only : dinc_ed + + ! Arguments + integer, intent(in) :: nv ! number of active leaf layers + real(r8), intent(in) :: psn_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: lmr_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: rs_llz(nv) ! s/m + real(r8), intent(in) :: anet_av_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer + real(r8), intent(in) :: c_area ! crown area m2/m2 + real(r8), intent(in) :: nplant ! indiv/m2 + real(r8), intent(in) :: treelai ! m2/m2 + real(r8), intent(in) :: treesai ! m2/m2 + real(r8), intent(in) :: rb ! boundary layer resistance (s/m) + + real(r8), intent(out) :: gscan ! Canopy conductance of the cohort m/s + real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) + real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) + + ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS + ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. + + ! Locals + real(r8) :: tree_area + real(r8) :: laifrac + + ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). + tree_area = c_area/nplant + + ! The routine is only called if there are leaves. If there are leaves, + ! there is at least 1 layer + + laifrac = (treelai+treesai)-dble(nv-1)*dinc_ed + + ! Canopy Conductance + gscan = 1.0_r8/(rs_llz(nv)+rb)*laifrac*tree_area + + ! GPP + gpp = psn_llz(nv) * elai_llz(nv) * laifrac * tree_area + + ! Dark respiration + rdark = lmr_llz(nv) * elai_llz(nv) * laifrac * tree_area + + ! If there is more than one layer, add the sum over the others + if ( nv>1 ) then + gpp = gpp + sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area + rdark = rdark + sum(lmr_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area + gscan = gscan + sum((1.0_r8/(rs_llz(1:nv-1) + rb ))) * tree_area + end if + + ! Convert dark respiration and GPP from umol/plant/s to kgC/plant/s + + rdark = rdark * umolC_to_kgC + gpp = gpp * umolC_to_kgC + + if ( DEBUG ) then + write(fates_log(),*) 'EDPhoto 816 ', gpp + write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) + write(fates_log(),*) 'EDPhoto 820 ', nv + write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) + write(fates_log(),*) 'EDPhoto 843 ', rdark + write(fates_log(),*) 'EDPhoto 871 ', laifrac + write(fates_log(),*) 'EDPhoto 872 ', tree_area + write(fates_log(),*) 'EDPhoto 873 ', nv + endif + + return + end subroutine ScaleLeafLayerFluxToCohort + + ! ===================================================================================== + + function ft1_f(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + + return + end function ft1_f + + ! ===================================================================================== + + function fth_f(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temp function (K) + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) + real(r8), intent(in) :: scaleFactor ! scaling factor for high temp inhibition (25 C = 1.0) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + + return + end function fth_f + + ! ===================================================================================== + + function fth25_f(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + + ! + ! !ARGUMENTS: + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + + return + end function fth25_f + + ! ===================================================================================== + + subroutine quadratic_f (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ + + if (a == 0._r8) then + write (fates_log(),*) 'Quadratic solution error: a = ',a + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if + + r1 = q / a + if (q /= 0._r8) then + r2 = c / q + else + r2 = 1.e36_r8 + end if + + end subroutine quadratic_f + + ! ==================================================================================== + + subroutine quadratic_fast (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ + + ! if (a == 0._r8) then + ! write (fates_log(),*) 'Quadratic solution error: a = ',a + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if + + r1 = q / a + ! if (q /= 0._r8) then + r2 = c / q + ! else + ! r2 = 1.e36_r8 + ! end if + + end subroutine quadratic_fast + + + ! ==================================================================================== + + subroutine UpdateCanopyNCanNRadPresent(currentPatch) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates two patch level quanities: + ! currentPatch%ncan and + ! currentPatch%present + ! + ! currentPatch%ncan(:,:) is a two dimensional array that indicates + ! the total number of leaf layers (including those that are not exposed to light) + ! in each canopy layer and for each functional type. + ! + ! currentPatch%nrad(:,:) is a two dimensional array that indicates + ! the total number of EXPOSED leaf layers, but for all intents and purposes + ! in the photosynthesis routine, this appears to be the same as %ncan... + ! + ! currentPatch%present(:,:) has the same dimensions, is binary, and + ! indicates whether or not leaf layers are present (by evaluating the canopy area + ! profile). + ! --------------------------------------------------------------------------------- + + use EDTypesMod , only : cp_nclmax + use EDTypesMOd , only : numpft_ed + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + + ! Arguments + type(ed_patch_type), target :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + ! Locals + integer :: cl ! Canopy Layer Index + integer :: ft ! Function Type Index + integer :: iv ! index of the exposed leaf layer for each canopy layer and pft + + ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT + ! and use the cohort's memory of how many layer's it takes up to assign the maximum + ! of the layer/pft index it is in + ! --------------------------------------------------------------------------------- + + currentPatch%ncan(:,:) = 0 + ! redo the canopy structure algorithm to get round a + ! bug that is happening for site 125, FT13. + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & + currentCohort%NV) + + currentCohort => currentCohort%shorter + + enddo !cohort + + ! NRAD = NCAN ... + currentPatch%nrad = currentPatch%ncan + + ! Now loop through and identify which layer and pft combo has scattering elements + do cl = 1,cp_nclmax + do ft = 1,numpft_ed + currentPatch%present(cl,ft) = 0 + do iv = 1, currentPatch%nrad(cl,ft); + if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then + currentPatch%present(cl,ft) = 1 + end if + end do !iv + enddo !ft + enddo !cl + + return + end subroutine UpdateCanopyNCanNRadPresent + + ! ==================================================================================== + + subroutine GetCanopyGasParameters(can_press, & + can_o2_partialpress, & + veg_tempk, & + air_tempk, & + air_vpress, & + veg_esat, & + rb, & + mm_kco2, & + mm_ko2, & + co2_cpoint, & + cf, & + gb_mol, & + ceair) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 + ! and O2, as well as the CO2 compentation point. + ! --------------------------------------------------------------------------------- + + use FatesConstantsMod, only: umol_per_mol + use FatesConstantsMod, only: mmol_per_mol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + + ! Arguments + real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) + real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) + real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) + real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) + real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) + real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) + real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) + + real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(out) :: cf ! s m**2/umol -> s/m + real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) + + ! Locals + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: sco ! relative specificity of rubisco + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + ! --------------------------------------------------------------------------------- + ! Intensive values (per mol of air) + ! kc, ko, currentPatch, from: Bernacchi et al (2001) + ! Plant, Cell and Environment 24:253-259 + ! --------------------------------------------------------------------------------- + + real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 + real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 + real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 + + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + + real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) + real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) + real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) + + + ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate + ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco + + ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information + ! about what they are or do, so I can't give them more descriptive names. Someone please + ! fill this in when possible) + + kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press + ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press + sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) + cp25 = 0.5_r8 * can_o2_partialpress / sco + + if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then + mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) + mm_ko2 = ko25 * ft1_f(veg_tempk, koha) + co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) + else + mm_kco2 = 1.0_r8 + mm_ko2 = 1.0_r8 + co2_cpoint = 1.0_r8 + end if + + ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS + ! (RGK 10-13-201). THE MEANING OF CF IS UNCLEAR, BUT THIS APPEARS TO BE A MOLAR CONVERSION + + cf = can_press/(rgas*1.e-3_r8 * air_tempk )*1.e06_r8 + gb_mol = (1._r8/ rb) * cf + + ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures + ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 + ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) + + + + return + end subroutine GetCanopyGasParameters + + ! ==================================================================================== + + subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & + nscaler, & + ft, & + veg_tempk, & + lmr) + + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C + ! for this pft (umol CO2/m**2/s) + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + ! Locals + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + + ! Parameter + real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) + real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) + real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) + real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) + + ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s + ! ---------------------------------------------------------------------------------- + lmr25 = lmr25top_ft * nscaler + + if ( nint(EDpftvarcon_inst%c3psn(ft)) == 1)then + lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & + fth_f(veg_tempk, lmrhd, lmrse, lmrc) + else + lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) + end if + + ! Any hydrodynamic limitations could go here, currently none + ! lmr = lmr * (nothing) + + end subroutine LeafLayerMaintenanceRespiration + + ! ==================================================================================== + + subroutine LeafLayerBiophysicalRates( parsun_lsl, & + ft, & + vcmax25top_ft, & + jmax25top_ft, & + tpu25top_ft, & + co2_rcurve_islope25top_ft, & + nscaler, & + veg_tempk, & + btran, & + vcmax, & + jmax, & + tpu, & + co2_rcurve_islope ) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the localized rates of several key photosynthesis + ! rates. By localized, we mean specific to the plant type and leaf layer, + ! which factors in leaf physiology, as well as environmental effects. + ! This procedure should be called prior to iterative solvers, and should + ! have pre-calculated the reference rates for the pfts before this. + ! + ! The output biophysical rates are: + ! vcmax: maximum rate of carboxilation, + ! jmax: maximum electron transport rate, + ! tpu: triose phosphate utilization rate and + ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) + ! --------------------------------------------------------------------------------- + + use EDPftvarcon , only : EDPftvarcon_inst + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + + ! Arguments + ! ------------------------------------------------------------------------------ + + real(r8), intent(in) :: parsun_lsl ! PAR absorbed in sunlit leaves for this layer + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C + ! for this pft (umol electrons/m**2/s) + real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve + ! (C4 plants) at 25C, canopy top, this pft + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + + real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(out) :: jmax ! maximum electron transport rate + ! (umol electrons/m**2/s) + real(r8), intent(out) :: tpu ! triose phosphate utilization rate + ! (umol CO2/m**2/s) + real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + + ! Locals + ! ------------------------------------------------------------------------------- + real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C + ! (umol CO2/m**2/s) + real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C + ! (umol electrons/m**2/s) + real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C + ! (umol CO2/m**2/s) + real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve + ! (C4 plants) at 25C + + + ! Parameters + ! --------------------------------------------------------------------------------- + real(r8), parameter :: vcmaxha = 65330._r8 ! activation energy for vcmax (J/mol) + real(r8), parameter :: jmaxha = 43540._r8 ! activation energy for jmax (J/mol) + real(r8), parameter :: tpuha = 53100._r8 ! activation energy for tpu (J/mol) + real(r8), parameter :: vcmaxhd = 149250._r8 ! deactivation energy for vcmax (J/mol) + real(r8), parameter :: jmaxhd = 152040._r8 ! deactivation energy for jmax (J/mol) + real(r8), parameter :: tpuhd = 150650._r8 ! deactivation energy for tpu (J/mol) + real(r8), parameter :: vcmaxse = 485._r8 ! entropy term for vcmax (J/mol/K) + real(r8), parameter :: jmaxse = 495._r8 ! entropy term for jmax (J/mol/K) + real(r8), parameter :: tpuse = 490._r8 ! entropy term for tpu (J/mol/K) + real(r8), parameter :: vcmaxc = 1.1534040_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) + real(r8), parameter :: jmaxc = 1.1657242_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) + real(r8), parameter :: tpuc = 1.1591239_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) + + if ( parsun_lsl <= 0._r8) then ! night time + vcmax = 0._r8 + jmax = 0._r8 + tpu = 0._r8 + co2_rcurve_islope = 0._r8 + else ! day time + vcmax25 = vcmax25top_ft * nscaler + jmax25 = jmax25top_ft * nscaler + tpu25 = tpu25top_ft * nscaler + co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler + + ! Adjust for temperature + vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) + jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) + tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) + + if (nint(EDPftvarcon_inst%c3psn(ft)) /= 1) then + vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) + vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + end if + !q10 response of product limited psn. + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + end if + + ! Adjust for water limitations + vcmax = vcmax * btran + + return + end subroutine LeafLayerBiophysicalRates + + end module FATESPlantRespPhotosynthMod diff --git a/components/clm/src/ED/fire/SFMainMod.F90 b/components/clm/src/ED/fire/SFMainMod.F90 index 47c96c3015..c9e15af8f5 100755 --- a/components/clm/src/ED/fire/SFMainMod.F90 +++ b/components/clm/src/ED/fire/SFMainMod.F90 @@ -5,15 +5,26 @@ module SFMainMod ! Code originally developed by Allan Spessa & Rosie Fisher as part of the NERC-QUEST project. ! ============================================================================ - use shr_kind_mod , only : r8 => shr_kind_r8; - use spmdMod , only : masterproc - use clm_varctl , only : iulog - use atm2lndType , only : atm2lnd_type - use TemperatureType , only : temperature_type + use FatesConstantsMod , only : r8 => fates_r8 + +! use spmdMod , only : masterproc + use EDTypesMod , only : cp_masterproc ! 1= master process, 0=not master process + use FatesGlobals , only : fates_log + + use FatesInterfaceMod , only : bc_in_type + use pftconMod , only : pftcon use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysconType , only : EDecophyscon - use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, AREA, DG_SF, FIRE_THRESHOLD - use EDtypesMod , only : LB_SF, LG_SF, NCWD, TR_SF + use EDtypesMod , only : ed_site_type + use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : ed_cohort_type + use EDtypesMod , only : AREA + use EDtypesMod , only : DG_SF + use EDtypesMod , only : FIRE_THRESHOLD + use EDtypesMod , only : LB_SF + use EDtypesMod , only : LG_SF + use EDtypesMod , only : NCWD + use EDtypesMod , only : TR_SF implicit none private @@ -42,13 +53,13 @@ module SFMainMod ! ============================================================================ ! Area of site burned by fire ! ============================================================================ - subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) + subroutine fire_model( currentSite, bc_in) use clm_varctl, only : use_ed_spit_fire type(ed_site_type) , intent(inout), target :: currentSite - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - type(temperature_type) , intent(in) :: temperature_inst + type(bc_in_type) , intent(in) :: bc_in + type (ed_patch_type), pointer :: currentPatch @@ -62,12 +73,12 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) enddo if(write_SF==1)then - write(iulog,*) 'use_ed_spit_fire',use_ed_spit_fire + write(fates_log(),*) 'use_ed_spit_fire',use_ed_spit_fire endif if(use_ed_spit_fire)then - call fire_danger_index(currentSite, temperature_inst, atm2lnd_inst) - call wind_effect(currentSite, atm2lnd_inst) + call fire_danger_index(currentSite, bc_in) + call wind_effect(currentSite, bc_in) call charecteristics_of_fuel(currentSite) call rate_of_spread(currentSite) call ground_fuel_consumption(currentSite) @@ -81,20 +92,19 @@ subroutine fire_model( currentSite, atm2lnd_inst, temperature_inst) end subroutine fire_model - !***************************************************************** - subroutine fire_danger_index ( currentSite, temperature_inst, atm2lnd_inst) + !***************************************************************** + subroutine fire_danger_index ( currentSite, bc_in) - !***************************************************************** + !***************************************************************** ! currentSite%acc_NI is the accumulated Nesterov fire danger index - use clm_varcon , only : tfrz - use SFParamsMod, only : SF_val_fdi_a, SF_val_fdi_b - + use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod , only : sec_per_day + type(ed_site_type) , intent(inout), target :: currentSite - type(temperature_type) , intent(in) :: temperature_inst - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - + type(bc_in_type) , intent(in) :: bc_in + real(r8) :: temp_in_C ! daily averaged temperature in celcius real(r8) :: rainfall ! daily precip real(r8) :: rh ! daily rh @@ -102,35 +112,31 @@ subroutine fire_danger_index ( currentSite, temperature_inst, atm2lnd_inst) real yipsolon; !intermediate varable for dewpoint calculation real dewpoint; !dewpoint in K real d_NI; !daily change in Nesterov Index. C^2 + integer :: iofp ! index of oldest the fates patch - associate( & - t_veg24 => temperature_inst%t_veg24_patch , & ! Input: [real(r8) (:)] avg pft vegetation temperature for last 24 hrs - - prec24 => atm2lnd_inst%prec24_patch , & ! Input: [real(r8) (:)] avg pft rainfall for last 24 hrs - rh24 => atm2lnd_inst%rh24_patch & ! Input: [real(r8) (:)] avg pft relative humidity for last 24 hrs - ) - - ! NOTE: t_veg24(:), prec24(:) and rh24(:) are p level temperatures, precipitation and RH, - ! which probably won't have much inpact, unless we decide to ever calculated the NI for each patch. - - temp_in_C = t_veg24(currentSite%oldest_patch%clm_pno) - tfrz - rainfall = prec24(currentSite%oldest_patch%clm_pno) *24.0_r8*3600._r8 - rh = rh24(currentSite%oldest_patch%clm_pno) - - if (rainfall > 3.0_r8) then !rezero NI if it rains... - d_NI = 0.0_r8 - currentSite%acc_NI = 0.0_r8 - else - yipsolon = (SF_val_fdi_a* temp_in_C)/(SF_val_fdi_b+ temp_in_C)+log(rh/100.0_r8) - dewpoint = (SF_val_fdi_b*yipsolon)/(SF_val_fdi_a-yipsolon) !Standard met. formula - d_NI = ( temp_in_C-dewpoint)* temp_in_C !follows Nesterov 1968. Equation 5. Thonicke et al. 2010. - if (d_NI < 0.0_r8) then !Change in NI cannot be negative. - d_NI = 0.0_r8 !check - endif - endif - currentSite%acc_NI = currentSite%acc_NI + d_NI !Accumulate Nesterov index over the fire season. - - end associate + ! NOTE that the boundary conditions of temperature, precipitation and relative humidity + ! are available at the patch level. We are currently using a simplification where the whole site + ! is simply using the values associated with the first patch. + ! which probably won't have much inpact, unless we decide to ever calculated the NI for each patch. + + iofp = currentSite%oldest_patch%patchno + + temp_in_C = bc_in%t_veg24_pa(iofp) - tfrz + rainfall = bc_in%precip24_pa(iofp)*sec_per_day + rh = bc_in%relhumid24_pa(iofp) + + if (rainfall > 3.0_r8) then !rezero NI if it rains... + d_NI = 0.0_r8 + currentSite%acc_NI = 0.0_r8 + else + yipsolon = (SF_val_fdi_a* temp_in_C)/(SF_val_fdi_b+ temp_in_C)+log(rh/100.0_r8) + dewpoint = (SF_val_fdi_b*yipsolon)/(SF_val_fdi_a-yipsolon) !Standard met. formula + d_NI = ( temp_in_C-dewpoint)* temp_in_C !follows Nesterov 1968. Equation 5. Thonicke et al. 2010. + if (d_NI < 0.0_r8) then !Change in NI cannot be negative. + d_NI = 0.0_r8 !check + endif + endif + currentSite%acc_NI = currentSite%acc_NI + d_NI !Accumulate Nesterov index over the fire season. end subroutine fire_danger_index @@ -179,15 +185,15 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac = 0.0_r8 if(write_sf == 1)then - if (masterproc) write(iulog,*) ' leaf_litter1 ',currentPatch%leaf_litter - if (masterproc) write(iulog,*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) - if (masterproc) write(iulog,*) ' leaf_litter3 ',currentPatch%livegrass - if (masterproc) write(iulog,*) ' sum fuel', currentPatch%sum_fuel + 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 endif currentPatch%sum_fuel = sum(currentPatch%leaf_litter) + sum(currentPatch%CWD_AG) + currentPatch%livegrass if(write_SF == 1)then - if (masterproc) write(iulog,*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area + if ( cp_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 @@ -199,9 +205,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 (masterproc) write(iulog,*) 'ff1 ',currentPatch%fuel_frac - if (masterproc) write(iulog,*) 'ff2 ',currentPatch%fuel_frac - if (masterproc) write(iulog,*) 'ff2a ',lg_sf,currentPatch%livegrass,currentPatch%sum_fuel + 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 endif currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel @@ -210,10 +216,10 @@ 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 (masterproc) write(iulog,*) 'ff3 ',currentPatch%fuel_frac - if (masterproc) write(iulog,*) 'fm ',fuel_moisture - if (masterproc) write(iulog,*) 'csa ',currentSite%acc_NI - if (masterproc) write(iulog,*) 'sfv ',SF_val_alpha_FMC + 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 endif ! FIX(RF,032414): needs refactoring. ! average water content !is this the correct metric? @@ -227,7 +233,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 (masterproc) write(iulog,*) 'ff4 ',currentPatch%fuel_eff_moist + if ( cp_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) @@ -254,14 +260,14 @@ subroutine charecteristics_of_fuel ( currentSite ) if(write_SF == 1)then - if (masterproc) write(iulog,*) 'no litter fuel at all',currentPatch%patchno, & + if ( cp_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 (masterproc) write(iulog,*) 'problem with spitfire fuel averaging' + if ( cp_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' ! FIX(SPM,032414) refactor...should not have 0 fuel unless everything is burnt ! off. @@ -277,7 +283,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 (masterproc) write(iulog,*) 'problem with spitfire fuel averaging' + if ( cp_masterproc == 1 ) write(fates_log(),*) 'problem with spitfire fuel averaging' endif currentPatch => currentPatch%younger @@ -288,33 +294,35 @@ end subroutine charecteristics_of_fuel !***************************************************************** - subroutine wind_effect ( currentSite, atm2lnd_inst) + subroutine wind_effect ( currentSite, bc_in) !*****************************************************************. ! Routine called daily from within ED within a site loop. ! Calculates the effective windspeed based on vegetation charecteristics. + use FatesConstantsMod, only : sec_per_min + type(ed_site_type) , intent(inout), target :: currentSite - type(atm2lnd_type) , intent(in) :: atm2lnd_inst + type(bc_in_type) , intent(in) :: bc_in type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - ! note - this is a p level temperature, which probably won't have much inpact, - ! unless we decide to ever calculated the NI for each patch. - real(r8), pointer :: wind24(:) - real(r8) :: wind ! daily wind real(r8) :: total_grass_area ! per patch,in m2 real(r8) :: tree_fraction ! site level. no units real(r8) :: grass_fraction ! site level. no units real(r8) :: bare_fraction ! site level. no units + integer :: iofp ! index of oldest fates patch - wind24 => atm2lnd_inst%wind24_patch ! Input: [real(r8) (:)] avg pft windspeed (m/s) + ! note - this is a patch level temperature, which probably won't have much inpact, + ! unless we decide to ever calculated the NI for each patch. + + iofp = currentSite%oldest_patch%patchno + wind = bc_in%wind24_pa(iofp) * sec_per_min ! Convert to m/min for SPITFIRE units. - wind = wind24(currentSite%oldest_patch%clm_pno) * 60._r8 ! Convert to m/min for SPITFIRE units. if(write_SF == 1)then - if (masterproc) write(iulog,*) 'wind24', wind24(currentSite%oldest_patch%clm_pno) + if ( cp_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 @@ -328,7 +336,7 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) currentCohort => currentPatch%tallest do while(associated(currentCohort)) - write(iulog,*) 'SF currentCohort%c_area ',currentCohort%c_area + write(fates_log(),*) 'SF currentCohort%c_area ',currentCohort%c_area if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area else @@ -340,10 +348,10 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) grass_fraction = grass_fraction + min(currentPatch%area,total_grass_area)/AREA if(DEBUG)then - !write(iulog,*) 'SF currentPatch%area ',currentPatch%area - !write(iulog,*) 'SF currentPatch%total_area ',currentPatch%total_tree_area - !write(iulog,*) 'SF total_grass_area ',tree_fraction,grass_fraction - !write(iulog,*) 'SF AREA ',AREA + !write(fates_log(),*) 'SF currentPatch%area ',currentPatch%area + !write(fates_log(),*) 'SF currentPatch%total_area ',currentPatch%total_tree_area + !write(fates_log(),*) 'SF total_grass_area ',tree_fraction,grass_fraction + !write(fates_log(),*) 'SF AREA ',AREA endif currentPatch => currentPatch%younger @@ -353,7 +361,7 @@ subroutine wind_effect ( currentSite, atm2lnd_inst) grass_fraction = min(grass_fraction,1.0_r8-tree_fraction) bare_fraction = 1.0 - tree_fraction - grass_fraction if(write_sf == 1)then - if (masterproc) write(iulog,*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction + if ( cp_masterproc == 1 ) write(fates_log(),*) 'grass, trees, bare',grass_fraction, tree_fraction, bare_fraction endif currentPatch=>currentSite%oldest_patch; @@ -403,18 +411,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 (masterproc.and.DEBUG) write(iulog,*) 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd - if (masterproc.and.DEBUG) write(iulog,*) 'SF - SF_val_part_dens ',SF_val_part_dens + 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 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 (masterproc.and.DEBUG) write(iulog,*) 'SF - beta ',beta - if (masterproc.and.DEBUG) write(iulog,*) 'SF - beta_op ',beta_op + 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 bet = beta/beta_op if(write_sf == 1)then - if (masterproc) write(iulog,*) 'esf ',currentPatch%fuel_eff_moist + if ( cp_masterproc == 1 ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist endif ! ---heat of pre-ignition--- ! Equation A4 in Thonicke et al. 2010 @@ -432,11 +440,11 @@ subroutine rate_of_spread ( currentSite ) ! Equation A5 in Thonicke et al. 2010 if (DEBUG) then - if (masterproc.and.DEBUG) write(iulog,*) 'SF - c ',c - if (masterproc.and.DEBUG) write(iulog,*) 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed - if (masterproc.and.DEBUG) write(iulog,*) 'SF - b ',b - if (masterproc.and.DEBUG) write(iulog,*) 'SF - bet ',bet - if (masterproc.and.DEBUG) write(iulog,*) 'SF - e ',e + 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 endif ! convert from m/min to ft/min for Rothermel ROS eqn @@ -464,18 +472,18 @@ subroutine rate_of_spread ( currentSite ) ! FIX(SPM, 040114) ask RF if this should be an endrun ! if(write_SF == 1)then - ! write(iulog,*) 'moist_damp' ,moist_damp,mw_weight,currentPatch%fuel_eff_moist,currentPatch%fuel_mef + ! write(fates_log(),*) 'moist_damp' ,moist_damp,mw_weight,currentPatch%fuel_eff_moist,currentPatch%fuel_mef ! endif ir = gamma_aptr*(currentPatch%sum_fuel/0.45_r8)*SF_val_fuel_energy*moist_damp*SF_val_miner_damp ! currentPatch%sum_fuel needs to be converted from kgC/m2 to kgBiomass/m2 - ! write(iulog,*) 'ir',gamma_aptr,moist_damp,SF_val_fuel_energy,SF_val_miner_damp + ! write(fates_log(),*) 'ir',gamma_aptr,moist_damp,SF_val_fuel_energy,SF_val_miner_damp if (((currentPatch%fuel_bulkd/0.45_r8) <= 0.0_r8).or.(eps <= 0.0_r8).or.(q_ig <= 0.0_r8)) then currentPatch%ROS_front = 0.0_r8 else ! Equation 9. Thonicke et al. 2010. currentPatch%ROS_front = (ir*xi*(1.0_r8+phi_wind)) / (currentPatch%fuel_bulkd/0.45_r8*eps*q_ig) - ! write(iulog,*) 'ROS',currentPatch%ROS_front,phi_wind,currentPatch%effect_wspeed - ! write(iulog,*) 'ros calcs',currentPatch%fuel_bulkd,ir,xi,eps,q_ig + ! write(fates_log(),*) 'ROS',currentPatch%ROS_front,phi_wind,currentPatch%effect_wspeed + ! write(fates_log(),*) 'ros calcs',currentPatch%fuel_bulkd,ir,xi,eps,q_ig endif ! Equation 10 in Thonicke et al. 2010 ! Can FBP System in m/min @@ -598,7 +606,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(masterproc) write(iulog,*) 'fire_intensity',currentPatch%fi,W,currentPatch%ROS_front + if( cp_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 @@ -609,7 +617,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 (masterproc) write(iulog,*) 'fire duration minutes',currentPatch%fd + if ( cp_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 @@ -635,12 +643,9 @@ subroutine area_burnt ( currentSite ) !currentPatch%AB daily area burnt (m2) !currentPatch%NF !Daily number of ignitions (lightning and human-caused), adjusted for size of patch. - use domainMod, only : ldomain use EDParamsMod, only : ED_val_nfires - use PatchType, only : patch type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), pointer :: currentPatch real lb !length to breadth ratio of fire ellipse @@ -682,15 +687,11 @@ subroutine area_burnt ( currentSite ) ! --- calculate area burnt--- if(lb > 0.0_r8) then - p = currentPatch%clm_pno - g = patch%gridcell(p) - ! g = currentSite%clmgcell (DEPRECATED VARIABLE) - ! INTERF-TODO: ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? - gridarea = ldomain%area(g) *1000000.0_r8 !convert from km2 into m2 - currentPatch%NF = ldomain%area(g) * ED_val_nfires * currentPatch%area/area /365 + gridarea = 1000000.0_r8 ! 1M m2 in a km2 + currentPatch%NF = ED_val_nfires * currentPatch%area/area /365 ! If there are 15 lightening strickes per year, per km2. (approx from NASA product) ! then there are 15/365 s/km2 each day. @@ -703,24 +704,25 @@ subroutine area_burnt ( currentSite ) currentPatch%AB = size_of_fire * currentPatch%nf if (currentPatch%AB > gridarea*currentPatch%area/area) then !all of patch burnt. - if (masterproc) write(iulog,*) 'burnt all of patch',currentPatch%patchno, & + if ( cp_masterproc == 1 ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & currentPatch%area/area,currentPatch%ab,currentPatch%area/area*gridarea - if (masterproc) write(iulog,*) 'ros',currentPatch%ROS_front,currentPatch%FD, & + if ( cp_masterproc == 1 ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & currentPatch%NF,currentPatch%FI,size_of_fire - if (masterproc) write(iulog,*) 'litter',currentPatch%sum_fuel,currentPatch%CWD_AG,currentPatch%leaf_litter + if ( cp_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 (masterproc) write(iulog,*) 'frac_burnt',currentPatch%frac_burnt + if ( cp_masterproc == 1 ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt endif endif endif! fire currentSite%frac_burnt = currentSite%frac_burnt + currentPatch%frac_burnt - currentPatch => currentPatch%younger; + currentPatch => currentPatch%younger enddo !end patch loop @@ -771,7 +773,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 (masterproc) write(iulog,*) 'currentPatch%SH',currentPatch%SH,f_ag_bmass + if ( cp_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/main/ChecksBalancesMod.F90 b/components/clm/src/ED/main/ChecksBalancesMod.F90 index 91d8d844fd..7a9e3e7467 100644 --- a/components/clm/src/ED/main/ChecksBalancesMod.F90 +++ b/components/clm/src/ED/main/ChecksBalancesMod.F90 @@ -206,7 +206,6 @@ subroutine FATES_BGC_Carbon_Balancecheck(nsites, sites, bc_in, is_beg_day, dtime sites(s)%fire_c_to_atm*SHR_CONST_CDAY) sites(s)%cbal_err_fates = sites(s)%cbal_err_fates / SHR_CONST_CDAY - sites(s)%cbal_err_bgc = sites(s)%totbgcc - & sites(s)%totbgcc_old - & (sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & diff --git a/components/clm/src/ED/main/EDInitMod.F90 b/components/clm/src/ED/main/EDInitMod.F90 index fb1e7ea275..c16cd70600 100755 --- a/components/clm/src/ED/main/EDInitMod.F90 +++ b/components/clm/src/ED/main/EDInitMod.F90 @@ -4,23 +4,19 @@ module EDInitMod ! Contains all modules to set up the ED structure. ! ============================================================================ - use shr_kind_mod , only : r8 => shr_kind_r8; - use spmdMod , only : masterproc - use decompMod , only : bounds_type + use FatesConstantsMod , only : r8 => fates_r8 use abortutils , only : endrun use EDTypesMod , only : cp_nclmax - use clm_varctl , only : iulog, use_ed_spit_fire + use FatesGlobals , only : fates_log + use clm_varctl , only : use_ed_spit_fire use clm_time_manager , only : is_restart - use CanopyStateType , only : canopystate_type - use WaterStateType , only : waterstate_type - use GridcellType , only : grc use EDPftvarcon , only : EDPftvarcon_inst use EDEcophysConType , only : EDecophyscon use EDGrowthFunctionsMod , only : bdead, bleaf, dbh 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, udata + use EDTypesMod , only : cohorts_per_col, ncwd, numpft_ed implicit none private @@ -281,7 +277,7 @@ subroutine init_cohorts( patch_in ) cstatus = patch_in%siteptr%dstatus endif - if ( DEBUG ) write(iulog,*) 'EDInitMod.F90 call create_cohort ' + if ( DEBUG ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' call create_cohort(patch_in, pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & diff --git a/components/clm/src/ED/main/EDMainMod.F90 b/components/clm/src/ED/main/EDMainMod.F90 index 9499f93d02..2bddac71cf 100755 --- a/components/clm/src/ED/main/EDMainMod.F90 +++ b/components/clm/src/ED/main/EDMainMod.F90 @@ -6,17 +6,25 @@ module EDMainMod use shr_kind_mod , only : r8 => shr_kind_r8 - use clm_varctl , only : iulog + 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 WaterStateType , only : waterstate_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 SFMainMod , only : fire_model - use EDtypesMod , only : ncwd, numpft_ed, udata + use EDtypesMod , only : ncwd, numpft_ed use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use FatesInterfaceMod , only : bc_in_type + use EDTypesMod , only : cp_masterproc + implicit none private @@ -39,24 +47,22 @@ module EDMainMod contains !-------------------------------------------------------------------------------! - subroutine ed_ecosystem_dynamics(currentSite, & - atm2lnd_inst, & - soilstate_inst, temperature_inst, waterstate_inst) + subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! ! !DESCRIPTION: ! Core of ed model, calling all subsequent vegetation dynamics routines ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite - type(atm2lnd_type) , intent(in) :: atm2lnd_inst - type(soilstate_type) , intent(in) :: soilstate_inst - type(temperature_type) , intent(in) :: temperature_inst - type(waterstate_type) , intent(in) :: waterstate_inst + type(bc_in_type) , intent(in) :: bc_in ! ! !LOCAL VARIABLES: 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 + !************************************************************************** ! Fire, growth, biogeochemistry. !************************************************************************** @@ -66,15 +72,15 @@ subroutine ed_ecosystem_dynamics(currentSite, & call ed_total_balance_check(currentSite, 0) - call phenology(currentSite, temperature_inst, waterstate_inst) + call phenology(currentSite, bc_in ) - call fire_model(currentSite, atm2lnd_inst, temperature_inst) + call fire_model(currentSite, bc_in) ! Calculate disturbance and mortality based on previous timestep vegetation. call disturbance_rates(currentSite) ! Integrate state variables from annual rates to daily timestep - call ed_integrate_state_variables(currentSite, temperature_inst ) + call ed_integrate_state_variables(currentSite, bc_in ) !****************************************************************************** ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organisation @@ -131,16 +137,18 @@ subroutine ed_ecosystem_dynamics(currentSite, & end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! - subroutine ed_integrate_state_variables(currentSite, temperature_inst ) + subroutine ed_integrate_state_variables(currentSite, bc_in ) ! ! !DESCRIPTION: ! FIX(SPM,032414) refactor so everything goes through interface ! ! !USES: + use EDTypesMod, only : ageclass_ed ! ! !ARGUMENTS: - type(ed_site_type) , intent(inout) :: currentSite - type(temperature_type) , intent(in) :: temperature_inst + type(ed_site_type) , intent(inout) :: currentSite + type(bc_in_type) , intent(in) :: bc_in + ! ! !LOCAL VARIABLES: type(ed_patch_type) , pointer :: currentPatch @@ -163,43 +171,46 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) do while(associated(currentPatch)) - currentPatch%age = currentPatch%age + udata%deltat + currentPatch%age = currentPatch%age + freq_day ! FIX(SPM,032414) valgrind 'Conditional jump or move depends on uninitialised value' if( currentPatch%age < 0._r8 )then - write(iulog,*) 'negative patch age?',currentPatch%age, & + write(fates_log(),*) 'negative patch age?',currentPatch%age, & currentPatch%patchno,currentPatch%area endif + ! check to see if the patch has moved to the next age class + currentPatch%age_class = count(currentPatch%age-ageclass_ed.ge.0.0_r8) + ! Find the derivatives of the growth and litter processes. - call canopy_derivs(currentSite, currentPatch) + call canopy_derivs(currentSite, currentPatch, bc_in) ! Update Canopy Biomass Pools currentCohort => currentPatch%shortest do while(associated(currentCohort)) cohort_biomass_store = (currentCohort%balive+currentCohort%bdead+currentCohort%bstore) - currentCohort%dbh = max(small_no,currentCohort%dbh + currentCohort%ddbhdt * udata%deltat ) - currentCohort%balive = currentCohort%balive + currentCohort%dbalivedt * udata%deltat - currentCohort%bdead = max(small_no,currentCohort%bdead + currentCohort%dbdeaddt * udata%deltat ) + 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 ) if ( DEBUG ) then - write(iulog,*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & - currentCohort%dbstoredt,udata%deltat + write(fates_log(),*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & + currentCohort%dbstoredt,freq_day end if - currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * udata%deltat + currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * freq_day if ( DEBUG ) then - write(iulog,*) 'EDMainMod dbstoredt II ',currentCohort%bstore, & - currentCohort%dbstoredt,udata%deltat + write(fates_log(),*) 'EDMainMod dbstoredt II ',currentCohort%bstore, & + currentCohort%dbstoredt,freq_day end if if( (currentCohort%balive+currentCohort%bdead+currentCohort%bstore)*currentCohort%n<0._r8)then - write(iulog,*) 'biomass is negative', currentCohort%n,currentCohort%balive, & + write(fates_log(),*) 'biomass is negative', currentCohort%n,currentCohort%balive, & currentCohort%bdead,currentCohort%bstore endif - if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+udata%deltat*(currentCohort%md+ & + if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+freq_day*(currentCohort%md+ & currentCohort%seed_prod)-cohort_biomass_store)-currentCohort%npp_acc) > 1e-8_r8)then - write(iulog,*) 'issue with c balance in integration', abs(currentCohort%balive+currentCohort%bdead+ & - currentCohort%bstore+udata%deltat* & + write(fates_log(),*) 'issue with c balance in integration', abs(currentCohort%balive+currentCohort%bdead+ & + currentCohort%bstore+freq_day* & (currentCohort%md+currentCohort%seed_prod)-cohort_biomass_store-currentCohort%npp_acc) endif @@ -218,41 +229,43 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) write(6,*)'DEBUG18: calling non_canopy_derivs with pno= ',currentPatch%clm_pno endif - call non_canopy_derivs( currentSite, currentPatch, temperature_inst ) + 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)* udata%deltat - currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + currentPatch%dcwd_bg_dt(c)* udata%deltat + 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 enddo do ft = 1,numpft_ed - currentPatch%leaf_litter(ft) = currentPatch%leaf_litter(ft) + currentPatch%dleaf_litter_dt(ft)* udata%deltat - currentPatch%root_litter(ft) = currentPatch%root_litter(ft) + currentPatch%droot_litter_dt(ft)* udata%deltat + 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 enddo do c = 1,ncwd if(currentPatch%cwd_ag(c) currentPatch%shortest do while(associated(currentCohort)) - currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * udata%deltat ) + currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * freq_day ) currentCohort => currentCohort%taller enddo @@ -273,13 +286,13 @@ subroutine ed_integrate_state_variables(currentSite, temperature_inst ) ! 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)*udata%deltat + currentSite%seed_bank(ft) = currentSite%seed_bank(ft) + currentSite%dseed_dt(ft)*freq_day enddo ! Check for negative values. Write out warning to show carbon balance. do ft = 1,numpft_ed if(currentSite%seed_bank(ft) currentPatch%younger @@ -344,8 +358,10 @@ subroutine ed_update_site( currentSite ) enddo ! FIX(RF,032414). This needs to be monthly, not annual - if((udata%time_period == udata%n_sub-1))then - write(iulog,*) 'calling trim canopy' + ! If this is the second to last day of the year, then perform trimming + if( day_of_year == days_per_year-1) then + + write(fates_log(),*) 'calling trim canopy' call trim_canopy(currentSite) endif @@ -415,14 +431,14 @@ subroutine ed_total_balance_check (currentSite, call_index ) error = abs(net_flux - change_in_stock) if ( abs(error) > 10e-6 ) then - write(iulog,*) 'total error: call index: ',call_index, & + write(fates_log(),*) 'total error: call index: ',call_index, & 'in: ',currentSite%flux_in, & 'out: ',currentSite%flux_out, & 'net: ',net_flux, & 'dstock: ',change_in_stock, & 'error=net_flux-dstock:', error - write(iulog,*) 'biomass,litter,seeds', biomass_stock,litter_stock,seed_stock - write(iulog,*) 'lat lon',currentSite%lat,currentSite%lon + write(fates_log(),*) 'biomass,litter,seeds', biomass_stock,litter_stock,seed_stock + write(fates_log(),*) 'lat lon',currentSite%lat,currentSite%lon endif currentSite%flux_in = 0.0_r8 diff --git a/components/clm/src/ED/main/EDTypesMod.F90 b/components/clm/src/ED/main/EDTypesMod.F90 index ce686880e5..5a263a127b 100755 --- a/components/clm/src/ED/main/EDTypesMod.F90 +++ b/components/clm/src/ED/main/EDTypesMod.F90 @@ -83,9 +83,12 @@ module EDTypesMod ! real(r8), parameter, dimension(16) :: sclass_ed = (/0.0_r8,1.0_r8,2.0_r8,3.0_r8,4.0_r8,5.0_r8,10.0_r8,20.0_r8,30.0_r8,40.0_r8, & ! 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) - real(r8), parameter, dimension(13) :: sclass_ed = (/0.0_r8,5.0_r8,10.0_r8,15.0_r8,20.0_r8,30.0_r8,40.0_r8, & + real(r8), parameter, dimension(nlevsclass_ed) :: sclass_ed = (/0.0_r8,5.0_r8,10.0_r8,15.0_r8,20.0_r8,30.0_r8,40.0_r8, & 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) + integer, parameter :: nlevage_ed = 7 ! Number of patch-age classes for age structured analyses + real(r8), parameter, dimension(nlevage_ed) :: ageclass_ed = (/0.0_r8,1.0_r8,2._r8,5.0_r8,10.0_r8,20.0_r8,50.0_r8/) + ! integer, parameter :: nlevsclass_ed = 17 ! real(r8), parameter, dimension(17) :: sclass_ed = (/0.1_r8, 5.0_r8,10.0_r8,15.0_r8,20.0_r8,25.0_r8, & @@ -99,13 +102,15 @@ module EDTypesMod character(len = 10), parameter,dimension(5) :: char_list = (/"background","hydraulic ","carbon ","impact ","fire "/) - ! These three vectors are used for history output mapping + ! These vectors are used for history output mapping real(r8) ,allocatable :: levsclass_ed(:) ! The lower bound on size classes for ED trees. This ! is used really for IO into the ! history tapes. It gets copied from ! the parameter array sclass_ed. integer , allocatable :: pft_levscpf_ed(:) integer , allocatable :: scls_levscpf_ed(:) + real(r8), allocatable :: levage_ed(:) + integer , allocatable :: levpft_ed(:) ! Control Parameters (cp_) @@ -149,6 +154,18 @@ module EDTypesMod ! 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 ** !************************************ @@ -313,6 +330,7 @@ module EDTypesMod ! PATCH INFO real(r8) :: age ! average patch age: years + integer :: age_class ! age class of the patch for history binning purposes real(r8) :: area ! patch area: m2 integer :: countcohorts ! Number of cohorts in patch integer :: ncl_p ! Number of occupied canopy layers @@ -376,8 +394,6 @@ module EDTypesMod ! 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) :: 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:- @@ -545,16 +561,14 @@ module EDTypesMod !** 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 +! 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 @@ -575,11 +589,20 @@ subroutine ed_hist_scpfmaps allocate( levsclass_ed(1:nlevsclass_ed )) allocate( pft_levscpf_ed(1:nlevsclass_ed*mxpft)) allocate(scls_levscpf_ed(1:nlevsclass_ed*mxpft)) + allocate( levpft_ed(1:mxpft )) + allocate( levage_ed(1:nlevage_ed )) ! Fill the IO array of plant size classes ! For some reason the history files did not like ! a hard allocation of sclass_ed levsclass_ed(:) = sclass_ed(:) + + levage_ed(:) = ageclass_ed(:) + + ! make pft array + do ipft=1,mxpft + levpft_ed(ipft) = ipft + end do ! Fill the IO arrays that match pft and size class to their combined array i=0 @@ -660,4 +683,10 @@ subroutine set_root_fraction( this , depth_gl) end subroutine set_root_fraction + + ! ===================================================================================== + + + + end module EDTypesMod diff --git a/components/clm/src/ED/main/FatesConstantsMod.F90 b/components/clm/src/ED/main/FatesConstantsMod.F90 index 3df36d6b56..bf1f7e562f 100644 --- a/components/clm/src/ED/main/FatesConstantsMod.F90 +++ b/components/clm/src/ED/main/FatesConstantsMod.F90 @@ -39,8 +39,11 @@ module FatesConstantsMod real(fates_r8), parameter :: umol_per_mol = 1.0E6_fates_r8 - ! Conversion: secons per minute + ! Conversion: seconds per minute real(fates_r8), parameter :: sec_per_min = 60.0_fates_r8 + + ! Conversion: seconds per day + real(fates_r8), parameter :: sec_per_day = 86400.0_fates_r8 ! Physical constants @@ -55,4 +58,16 @@ module FatesConstantsMod real(fates_r8), parameter :: t_water_freeze_k_triple = 273.16_fates_r8 + ! For numerical inquiry + real(fates_r8), parameter :: fates_huge = huge(g_per_kg) + + real(fates_r8), parameter :: fates_tiny = tiny(g_per_kg) + + ! Geometric Constants + + ! 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 9ae06e207c..0b4e11e7f3 100644 --- a/components/clm/src/ED/main/FatesGlobals.F90 +++ b/components/clm/src/ED/main/FatesGlobals.F90 @@ -4,14 +4,36 @@ module FatesGlobals ! global data that needs to be dealt with, but doesn't have an ! immediately obvious home. + use FatesConstantsMod , only : r8 => fates_r8 + implicit none - integer, private :: fates_log_ - logical, private :: fates_global_verbose_ + 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 @@ -35,4 +57,39 @@ logical function fates_global_verbose() fates_global_verbose = fates_global_verbose_ end function fates_global_verbose + ! ===================================================================================== + + 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 + + end module FatesGlobals diff --git a/components/clm/src/ED/main/FatesHistoryInterfaceMod.F90 b/components/clm/src/ED/main/FatesHistoryInterfaceMod.F90 index 662ead47bc..bb43fe5e8f 100644 --- a/components/clm/src/ED/main/FatesHistoryInterfaceMod.F90 +++ b/components/clm/src/ED/main/FatesHistoryInterfaceMod.F90 @@ -63,16 +63,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_maint_resp_pa integer, private :: ih_growth_resp_pa - ! Indices to (patch x pft) variables (using nlevgrnd as surrogate) - - integer, private :: ih_biomass_pa_pft - integer, private :: ih_leafbiomass_pa_pft - integer, private :: ih_storebiomass_pa_pft - integer, private :: ih_nindivs_pa_pft - ! Indices to (site) variables - - integer, private :: ih_nep_si integer, private :: ih_nep_timeintegrated_si integer, private :: ih_npp_timeintegrated_si @@ -134,10 +125,28 @@ module FatesHistoryInterfaceMod integer, private :: ih_ar_crootm_si_scpf integer, private :: ih_ar_frootm_si_scpf + ! indices to (site x scls) variables + integer, private :: ih_ba_si_scls + + ! indices to (site x pft) variables + integer, private :: ih_biomass_si_pft + integer, private :: ih_leafbiomass_si_pft + integer, private :: ih_storebiomass_si_pft + integer, private :: ih_nindivs_si_pft + + + ! indices to (site x patch-age) variables + integer, private :: ih_area_si_age + integer, private :: ih_lai_si_age + integer, private :: ih_canopy_area_si_age + integer, private :: ih_gpp_si_age + integer, private :: ih_npp_si_age + integer, private :: ih_ncl_si_age + integer, private :: ih_npatches_si_age ! The number of variable dim/kind types we have defined (static) - integer, parameter :: fates_history_num_dimensions = 4 - integer, parameter :: fates_history_num_dim_kinds = 6 + integer, parameter :: fates_history_num_dimensions = 7 + integer, parameter :: fates_history_num_dim_kinds = 9 @@ -171,6 +180,7 @@ module FatesHistoryInterfaceMod type(iovar_map_type), pointer :: iovar_map(:) integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ + integer, private :: levscls_index_, levpft_index_, levage_index_ contains procedure, public :: Init @@ -188,6 +198,9 @@ module FatesHistoryInterfaceMod procedure, public :: column_index procedure, public :: levgrnd_index procedure, public :: levscpf_index + procedure, public :: levscls_index + procedure, public :: levpft_index + procedure, public :: levage_index ! private work functions procedure, private :: define_history_vars @@ -200,6 +213,9 @@ module FatesHistoryInterfaceMod procedure, private :: set_column_index procedure, private :: set_levgrnd_index procedure, private :: set_levscpf_index + procedure, private :: set_levscls_index + procedure, private :: set_levpft_index + procedure, private :: set_levage_index end type fates_history_interface_type @@ -212,6 +228,7 @@ module FatesHistoryInterfaceMod subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf + use FatesIODimensionsMod, only : levscls, levpft, levage use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -240,7 +257,22 @@ subroutine Init(this, num_threads, fates_bounds) dim_count = dim_count + 1 call this%set_levscpf_index(dim_count) call this%dim_bounds(dim_count)%Init(levscpf, num_threads, & + fates_bounds%sizepft_class_begin, fates_bounds%sizepft_class_end) + + dim_count = dim_count + 1 + call this%set_levscls_index(dim_count) + call this%dim_bounds(dim_count)%Init(levscls, num_threads, & + fates_bounds%size_class_begin, fates_bounds%size_class_end) + + dim_count = dim_count + 1 + call this%set_levpft_index(dim_count) + call this%dim_bounds(dim_count)%Init(levpft, num_threads, & fates_bounds%pft_class_begin, fates_bounds%pft_class_end) + + dim_count = dim_count + 1 + call this%set_levage_index(dim_count) + call this%dim_bounds(dim_count)%Init(levage, num_threads, & + fates_bounds%age_class_begin, fates_bounds%age_class_end) ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) ! Allocate the mapping between FATES indices and the IO indices @@ -275,9 +307,21 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) thread_bounds%ground_begin, thread_bounds%ground_end) index = this%levscpf_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%sizepft_class_begin, thread_bounds%sizepft_class_end) + + index = this%levscls_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%size_class_begin, thread_bounds%size_class_end) + + index = this%levpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%pft_class_begin, thread_bounds%pft_class_end) + index = this%levage_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%age_class_begin, thread_bounds%age_class_end) + end subroutine SetThreadBoundsEach ! =================================================================================== @@ -285,6 +329,7 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 implicit none @@ -308,6 +353,15 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_size_pft_r8, 1, this%column_index()) call this%set_dim_indices(site_size_pft_r8, 2, this%levscpf_index()) + call this%set_dim_indices(site_size_r8, 1, this%column_index()) + call this%set_dim_indices(site_size_r8, 2, this%levscls_index()) + + call this%set_dim_indices(site_pft_r8, 1, this%column_index()) + call this%set_dim_indices(site_pft_r8, 2, this%levpft_index()) + + call this%set_dim_indices(site_age_r8, 1, this%column_index()) + call this%set_dim_indices(site_age_r8, 2, this%levage_index()) + end subroutine assemble_history_output_types ! =================================================================================== @@ -407,6 +461,48 @@ integer function levscpf_index(this) levscpf_index = this%levscpf_index_ end function levscpf_index + ! ======================================================================= + subroutine set_levscls_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levscls_index_ = index + end subroutine set_levscls_index + + integer function levscls_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levscls_index = this%levscls_index_ + end function levscls_index + + ! ======================================================================= + subroutine set_levpft_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levpft_index_ = index + end subroutine set_levpft_index + + integer function levpft_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levpft_index = this%levpft_index_ + end function levpft_index + + ! ======================================================================= + subroutine set_levage_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levage_index_ = index + end subroutine set_levage_index + + integer function levage_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levage_index = this%levage_index_ + end function levage_index + ! ====================================================================================== subroutine flush_hvars(this,nc,upfreq_in) @@ -500,6 +596,7 @@ subroutine init_dim_kinds_maps(this) ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 implicit none @@ -533,6 +630,18 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_size_pft_r8, 2) + ! site x size-class + index = index + 1 + call this%dim_kinds(index)%Init(site_size_r8, 2) + + ! site x pft + index = index + 1 + call this%dim_kinds(index)%Init(site_pft_r8, 2) + + ! site x patch-age clase + index = index + 1 + call this%dim_kinds(index)%Init(site_age_r8, 2) + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) end subroutine init_dim_kinds_maps @@ -606,7 +715,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) ed_patch_type, & AREA, & sclass_ed, & - nlevsclass_ed + nlevsclass_ed, & + levage_ed, & + nlevage_ed, & + levpft_ed use EDParamsMod , only : ED_val_ag_biomass ! Arguments @@ -618,7 +730,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Locals integer :: s ! The local site index integer :: io_si ! The site index of the IO array - integer :: ipa ! The local "I"ndex of "PA"tches + integer :: ipa, ipa2 ! The local "I"ndex of "PA"tches integer :: io_pa ! The patch index of the IO array integer :: io_pa1 ! The first patch index in the IO array for each site integer :: io_soipa @@ -637,6 +749,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? real(r8), parameter :: yeardays = 365.0_r8 ! ALM/CLM do not use leap-years + real(r8), parameter :: tiny = 1.e-5_r8 ! some small number associate( hio_npatches_si => this%hvars(ih_npatches_si)%r81d, & hio_ncohorts_si => this%hvars(ih_ncohorts_si)%r81d, & @@ -644,10 +757,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_area_plant_pa => this%hvars(ih_area_plant_pa)%r81d, & hio_area_treespread_pa => this%hvars(ih_area_treespread_pa)%r81d, & hio_canopy_spread_pa => this%hvars(ih_canopy_spread_pa)%r81d, & - hio_biomass_pa_pft => this%hvars(ih_biomass_pa_pft)%r82d, & - hio_leafbiomass_pa_pft => this%hvars(ih_leafbiomass_pa_pft)%r82d, & - hio_storebiomass_pa_pft => this%hvars(ih_storebiomass_pa_pft)%r82d, & - hio_nindivs_pa_pft => this%hvars(ih_nindivs_pa_pft)%r82d, & + hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & + hio_leafbiomass_si_pft => this%hvars(ih_leafbiomass_si_pft)%r82d, & + hio_storebiomass_si_pft => this%hvars(ih_storebiomass_si_pft)%r82d, & + hio_nindivs_si_pft => this%hvars(ih_nindivs_si_pft)%r82d, & hio_nesterov_fire_danger_pa => this%hvars(ih_nesterov_fire_danger_pa)%r81d, & hio_spitfire_ros_pa => this%hvars(ih_spitfire_ROS_pa)%r81d, & hio_tfc_ros_pa => this%hvars(ih_TFC_ROS_pa)%r81d, & @@ -688,7 +801,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m2_si_scpf => this%hvars(ih_m2_si_scpf)%r82d, & hio_m3_si_scpf => this%hvars(ih_m3_si_scpf)%r82d, & hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & - hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d ) + hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & + hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & + hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & + hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & + hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & + hio_ncl_si_age => this%hvars(ih_ncl_si_age)%r82d, & + hio_npatches_si_age => this%hvars(ih_npatches_si_age)%r82d) + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in @@ -720,6 +840,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 + + ! Increment the fractional area in each age class bin + hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + + cpatch%area/AREA + + ! Increment some patch-age-resolved diagnostics + hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & + + cpatch%lai * cpatch%area + hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & + + cpatch%canopy_area/AREA + hio_ncl_si_age(io_si,cpatch%age_class) = hio_ncl_si_age(io_si,cpatch%age_class) & + + cpatch%ncl_p * cpatch%area + hio_npatches_si_age(io_si,cpatch%age_class) = hio_npatches_si_age(io_si,cpatch%age_class) + 1._r8 ccohort => cpatch%shortest do while(associated(ccohort)) @@ -768,17 +901,17 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * ccohort%balive * 1.e3_r8 ! Update PFT partitioned biomass components - hio_biomass_pa_pft(io_pa,ft) = hio_biomass_pa_pft(io_pa,ft) + & - n_density * ccohort%b * 1.e3_r8 - - hio_leafbiomass_pa_pft(io_pa,ft) = hio_leafbiomass_pa_pft(io_pa,ft) + & - n_density * ccohort%bl * 1.e3_r8 + hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & + (ccohort%n / AREA) * ccohort%bl * 1.e3_r8 - hio_storebiomass_pa_pft(io_pa,ft) = hio_storebiomass_pa_pft(io_pa,ft) + & - n_density * ccohort%bstore * 1.e3_r8 + hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & + (ccohort%n / AREA) * ccohort%bstore * 1.e3_r8 - hio_nindivs_pa_pft(io_pa,ft) = hio_nindivs_pa_pft(io_pa,ft) + & - ccohort%n + hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & + ccohort%n / AREA + + hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & + (ccohort%n / AREA) * ccohort%b * 1.e3_r8 ! Site by Size-Class x PFT (SCPF) ! ------------------------------------------------------------------------ @@ -789,7 +922,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! have any meaning, otherwise they are just inialization values if( .not.(ccohort%isnew) ) then - associate( scpf => ccohort%size_by_pft_class ) + associate( scpf => ccohort%size_by_pft_class, & + scls => ccohort%size_class ) hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold ! [kgC/m2/yr] @@ -840,6 +974,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! basal area [m2/ha] hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA + ! also by size class only + hio_ba_si_scls(io_si,scls) = hio_ba_si_scls(io_si,scls) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*n_perm2*AREA ! number density [/ha] hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + AREA*n_perm2 @@ -903,6 +1040,17 @@ subroutine update_history_dyn(this,nc,nsites,sites) ipa = ipa + 1 cpatch => cpatch%younger end do !patch loop + + ! divide so-far-just-summed but to-be-averaged patch-age-class variables by patch-age-class area to get mean values + do ipa2 = 1, nlevage_ed + if (hio_area_si_age(io_si, ipa2) .gt. tiny) then + hio_lai_si_age(io_si, ipa2) = hio_lai_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + hio_ncl_si_age(io_si, ipa2) = hio_ncl_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + else + hio_lai_si_age(io_si, ipa2) = 0._r8 + hio_ncl_si_age(io_si, ipa2) = 0._r8 + endif + end do enddo ! site loop @@ -924,6 +1072,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ed_cohort_type, & ed_patch_type, & AREA, & + nlevage_ed, & sclass_ed, & nlevsclass_ed ! Arguments @@ -945,6 +1094,9 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) integer :: ft ! functional type index real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8) :: patch_area_by_age(nlevage_ed) ! patch area in each bin for normalizing purposes + real(r8), parameter :: tiny = 1.e-5_r8 ! some small number + integer :: ipa2 ! patch incrementer type(fates_history_variable_type),pointer :: hvar type(ed_patch_type),pointer :: cpatch @@ -965,7 +1117,10 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_ar_agsapm_si_scpf => this%hvars(ih_ar_agsapm_si_scpf)%r82d, & hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & - hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d ) + hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d, & + hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & + hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d & + ) ! Flush the relevant history variables @@ -979,10 +1134,15 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ipa = 0 cpatch => sites(s)%oldest_patch + + patch_area_by_age(:) = 0._r8 + do while(associated(cpatch)) io_pa = io_pa1 + ipa + patch_area_by_age(cpatch%age_class) = patch_area_by_age(cpatch%age_class) + cpatch%area + ccohort => cpatch%shortest do while(associated(ccohort)) @@ -1045,6 +1205,11 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & ccohort%froot_mr * n_perm2 * daysecs * yeardays + ! accumulate fluxes per patch age bin + hio_gpp_si_age(io_si,cpatch%age_class) = hio_gpp_si_age(io_si,cpatch%age_class) & + + ccohort%gpp_tstep * ccohort%n * 1.e3_r8 / dt_tstep + hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & + + ccohort%npp_tstep * ccohort%n * 1.e3_r8 / dt_tstep end associate endif @@ -1053,6 +1218,16 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ipa = ipa + 1 cpatch => cpatch%younger end do !patch loop + + do ipa2 = 1, nlevage_ed + if (patch_area_by_age(ipa2) .gt. tiny) then + hio_gpp_si_age(io_si, ipa2) = hio_gpp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) + hio_npp_si_age(io_si, ipa2) = hio_npp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) + else + hio_gpp_si_age(io_si, ipa2) = 0._r8 + hio_npp_si_age(io_si, ipa2) = 0._r8 + endif + end do enddo ! site loop @@ -1124,6 +1299,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1169,23 +1345,49 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='PFTbiomass', units='gC/m2', & long='total PFT level biomass', use_default='active', & - avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_biomass_pa_pft ) + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & long='total PFT level leaf biomass', use_default='active', & - avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_pa_pft ) + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & - avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_pa_pft ) + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_si_pft ) call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & long='total PFT level number of individuals', use_default='active', & - avgflag='A', vtype=patch_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nindivs_pa_pft ) + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nindivs_si_pft ) + + ! patch age class variables + call this%set_history_var(vname='PATCH_AREA_BY_AGE', units='m2/m2', & + long='patch area by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_si_age ) + + call this%set_history_var(vname='LAI_BY_AGE', units='m2/m2', & + long='leaf area index by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_lai_si_age ) + + call this%set_history_var(vname='CANOPY_AREA_BY_AGE', units='m2/m2', & + long='canopy area by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_canopy_area_si_age ) + + call this%set_history_var(vname='NCL_BY_AGE', units='--', & + long='number of canopy levels by age bin', use_default='inactive', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_ncl_si_age ) + + call this%set_history_var(vname='NPATCH_BY_AGE', units='--', & + long='number of patches by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_npatches_si_age ) ! Fire Variables @@ -1341,6 +1543,18 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_maint_resp_pa ) + ! fast fluxes by age bin + call this%set_history_var(vname='NPP_BY_AGE', units='gC/m^2/s', & + long='net primary productivity by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_npp_si_age ) + + call this%set_history_var(vname='GPP_BY_AGE', units='gC/m^2/s', & + long='gross primary productivity by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_age ) + + ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! ! (BECAUSE THEY TAKE UP SPACE!!! @@ -1474,6 +1688,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_frootm_si_scpf ) + ! size-class only variables + call this%set_history_var(vname='BA_SCLS', units = 'm2/ha', & + long='basal area by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls ) ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS diff --git a/components/clm/src/ED/main/FatesHistoryVariableType.F90 b/components/clm/src/ED/main/FatesHistoryVariableType.F90 index 44d6458668..20abd41f89 100644 --- a/components/clm/src/ED/main/FatesHistoryVariableType.F90 +++ b/components/clm/src/ED/main/FatesHistoryVariableType.F90 @@ -45,6 +45,7 @@ subroutine Init(this, vname, units, long, use_default, & use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : iotype_index implicit none @@ -118,6 +119,18 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval + case(site_size_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_pft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_age_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + case default write(fates_log(),*) 'Incompatible vtype passed to set_history_var' write(fates_log(),*) 'vtype = ',trim(vtype),' ?' @@ -183,6 +196,7 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 implicit none @@ -208,6 +222,12 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_size_pft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_size_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_pft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_age_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(patch_int) this%int1d(lb1:ub1) = nint(this%flushval) case default diff --git a/components/clm/src/ED/main/FatesIODimensionsMod.F90 b/components/clm/src/ED/main/FatesIODimensionsMod.F90 index 84c082e75c..83b2475aad 100644 --- a/components/clm/src/ED/main/FatesIODimensionsMod.F90 +++ b/components/clm/src/ED/main/FatesIODimensionsMod.F90 @@ -9,6 +9,9 @@ module FatesIODimensionsMod character(*), parameter :: column = 'column' character(*), parameter :: levgrnd = 'levgrnd' character(*), parameter :: levscpf = 'levscpf' + character(*), parameter :: levscls = 'levscls' + character(*), parameter :: levpft = 'levpft' + character(*), parameter :: levage = 'levage' ! patch = This is a structure that records where FATES patch boundaries ! on each thread point to in the host IO array, this structure @@ -24,6 +27,15 @@ module FatesIODimensionsMod ! levscpf = This is a structure that records the boundaries for the ! number of size-class x pft dimension + ! levscls = This is a structure that records the boundaries for the + ! number of size-class dimension + + ! levpft = This is a structure that records the boundaries for the + ! number of pft dimension + + ! levage = This is a structure that records the boundaries for the + ! number of patch-age-class dimension + type, public :: fates_bounds_type integer :: patch_begin @@ -34,8 +46,14 @@ module FatesIODimensionsMod integer :: column_end ! we call this a "site" (rgk 11-2016) integer :: ground_begin integer :: ground_end + integer :: sizepft_class_begin + integer :: sizepft_class_end + integer :: size_class_begin + integer :: size_class_end integer :: pft_class_begin integer :: pft_class_end + integer :: age_class_begin + integer :: age_class_end end type fates_bounds_type diff --git a/components/clm/src/ED/main/FatesIOVariableKindMod.F90 b/components/clm/src/ED/main/FatesIOVariableKindMod.F90 index 343d3b4364..2c8eb98216 100644 --- a/components/clm/src/ED/main/FatesIOVariableKindMod.F90 +++ b/components/clm/src/ED/main/FatesIOVariableKindMod.F90 @@ -16,9 +16,13 @@ module FatesIOVariableKindMod character(*), parameter :: site_int = 'SI_INT' character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' character(*), parameter :: site_size_pft_r8 = 'SI_SCPF_R8' + character(*), parameter :: site_size_r8 = 'SI_SCLS_R8' character(*), parameter :: patch_int = 'PA_INT' character(*), parameter :: cohort_r8 = 'CO_R8' character(*), parameter :: cohort_int = 'CO_INT' + character(*), parameter :: site_pft_r8 = 'SI_PFT_R8' + character(*), parameter :: site_age_r8 = 'SI_AGE_R8' + ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES ! control parameter passing to ensure all active dimension types received all diff --git a/components/clm/src/ED/main/FatesInterfaceMod.F90 b/components/clm/src/ED/main/FatesInterfaceMod.F90 index 9be0bfa859..272bbfbc38 100644 --- a/components/clm/src/ED/main/FatesInterfaceMod.F90 +++ b/components/clm/src/ED/main/FatesInterfaceMod.F90 @@ -9,27 +9,20 @@ module FatesInterfaceMod ! which is allocated by thread ! ------------------------------------------------------------------------------------ - ! ------------------------------------------------------------------------------------ - ! Used CLM Modules - ! INTERF-TODO: NO CLM MODULES SHOULD BE ACCESSIBLE BY THE FATES - ! PUBLIC API!!!! - ! ------------------------------------------------------------------------------------ - - use EDtypesMod , only : ed_site_type, & - maxPatchesPerCol, & - cp_nclmax, & - cp_numSWb, & - cp_numlevgrnd, & - cp_maxSWb, & - cp_numlevdecomp, & - cp_numlevdecomp_full, & - cp_hlm_name, & - cp_hio_ignore_val, & - cp_numlevsoil + 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 shr_kind_mod , only : r8 => shr_kind_r8 ! INTERF-TODO: REMOVE THIS - - implicit none ! ------------------------------------------------------------------------------------ @@ -41,15 +34,50 @@ module FatesInterfaceMod ! (Intel-Forum Post), ALLOCATABLES are better perfomance wise as long as they point ! to contiguous memory spaces and do not alias other variables, the case here. ! Naming conventions: _gl means ground layer dimensions + ! _si means site dimensions (scalar in that case) ! _pa means patch dimensions ! _rb means radiation band ! ------------------------------------------------------------------------------------ + + + type, public :: bc_in_type ! The actual number of FATES' ED patches integer :: npatches + ! Vegetation Dynamics + ! --------------------------------------------------------------------------------- + + ! The site level 24 hour vegetation temperature is used for various purposes during vegetation + ! dynamics. However, we are currently using the bare ground patch's value [K] + ! TO-DO: Get some consensus on the correct vegetation temperature used for phenology. + ! It is possible that the bare-ground value is where the average is being stored. + ! (RGK-01-2017) + real(r8) :: t_veg24_si + + ! Patch 24 hour vegetation temperature [K] + real(r8),allocatable :: t_veg24_pa(:) + + ! NOTE: h2osoi_vol_si is used to update surface water memory + ! CLM/ALM may be using "waterstate%h2osoi_vol_col" on the first index (coli,1) + ! to inform this. I think this should be re-evaluated (RGK 01/2017) + ! Site volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] + real(r8) :: h2osoi_vol_si + + ! Fire Model + + ! Average precipitation over the last 24 hours [mm/s] + real(r8), allocatable :: precip24_pa(:) + + ! Average relative humidity over past 24 hours [-] + real(r8), allocatable :: relhumid24_pa(:) + + ! Patch 24-hour running mean of wind (m/s ?) + real(r8), allocatable :: wind24_pa(:) + + ! Radiation variables for calculating sun/shade fractions ! --------------------------------------------------------------------------------- @@ -191,14 +219,13 @@ module FatesInterfaceMod ! Shaded canopy resistance [s/m] real(r8), allocatable :: rssha_pa(:) - ! Canopy conductance [mmol m-2 s-1] - real(r8), allocatable :: gccanopy_pa(:) + ! leaf photosynthesis (umol CO2 /m**2/ s) + ! (NOT CURRENTLY USED, PLACE-HOLDER) + !real(r8), allocatable :: psncanopy_pa(:) - ! patch sunlit leaf photosynthesis (umol CO2 /m**2/ s) - real(r8), allocatable :: psncanopy_pa(:) - - ! patch sunlit leaf maintenance respiration rate (umol CO2/m**2/s) - real(r8), allocatable :: lmrcanopy_pa(:) + ! leaf maintenance respiration rate (umol CO2/m**2/s) + ! (NOT CURRENTLY USED, PLACE-HOLDER) + !real(r8), allocatable :: lmrcanopy_pa(:) ! Canopy Radiation Boundaries ! --------------------------------------------------------------------------------- @@ -345,6 +372,13 @@ subroutine allocate_bcin(bc_in) ! Allocate input boundaries + ! Vegetation Dynamics + allocate(bc_in%t_veg24_pa(maxPatchesPerCol)) + + allocate(bc_in%wind24_pa(maxPatchesPerCol)) + allocate(bc_in%relhumid24_pa(maxPatchesPerCol)) + allocate(bc_in%precip24_pa(maxPatchesPerCol)) + ! Radiation allocate(bc_in%solad_parb(maxPatchesPerCol,cp_numSWb)) allocate(bc_in%solai_parb(maxPatchesPerCol,cp_numSWb)) @@ -404,11 +438,9 @@ subroutine allocate_bcout(bc_out) allocate(bc_out%btran_pa(maxPatchesPerCol)) ! Photosynthesis + allocate(bc_out%rssun_pa(maxPatchesPerCol)) allocate(bc_out%rssha_pa(maxPatchesPerCol)) - allocate(bc_out%gccanopy_pa(maxPatchesPerCol)) - allocate(bc_out%lmrcanopy_pa(maxPatchesPerCol)) - allocate(bc_out%psncanopy_pa(maxPatchesPerCol)) ! Canopy Radiation allocate(bc_out%albd_parb(maxPatchesPerCol,cp_numSWb)) @@ -448,6 +480,13 @@ subroutine zero_bcs(this,s) ! Input boundaries + this%bc_in(s)%t_veg24_si = 0.0_r8 + this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 + this%bc_in(s)%h2osoi_vol_si = 0.0_r8 + this%bc_in(s)%precip24_pa(:) = 0.0_r8 + this%bc_in(s)%relhumid24_pa(:) = 0.0_r8 + this%bc_in(s)%wind24_pa(:) = 0.0_r8 + this%bc_in(s)%solad_parb(:,:) = 0.0_r8 this%bc_in(s)%solai_parb(:,:) = 0.0_r8 this%bc_in(s)%smp_gl(:) = 0.0_r8 @@ -481,9 +520,6 @@ subroutine zero_bcs(this,s) this%bc_out(s)%rssun_pa(:) = 0.0_r8 this%bc_out(s)%rssha_pa(:) = 0.0_r8 - this%bc_out(s)%gccanopy_pa(:) = 0.0_r8 - this%bc_out(s)%psncanopy_pa(:) = 0.0_r8 - this%bc_out(s)%lmrcanopy_pa(:) = 0.0_r8 this%bc_out(s)%albd_parb(:,:) = 0.0_r8 this%bc_out(s)%albi_parb(:,:) = 0.0_r8 @@ -558,6 +594,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) cp_numlevdecomp = unset_int cp_hlm_name = 'unset' cp_hio_ignore_val = unset_double + cp_masterproc = unset_int case('check_allset') @@ -569,6 +606,14 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! end_run('MESSAGE') end if + if(cp_masterproc .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES parameter unset: cp_masterproc' + end if + ! INTERF-TODO: FATES NEEDS INTERNAL end_run + ! end_run('MESSAGE') + end if + if(cp_numSWb > cp_maxSWb) then if (fates_global_verbose()) then write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' @@ -639,36 +684,38 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if(present(ival))then select case (trim(tag)) - - case('num_sw_bbands') + case('masterproc') + cp_masterproc = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering masterproc = ',ival,' to FATES' + end if + + case('num_sw_bbands') cp_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 if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' end if + case('num_lev_soil') - cp_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 if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_levdecomp_full = ',ival,' to FATES' end if case('num_levdecomp') - cp_numlevdecomp = ival if (fates_global_verbose()) then write(fates_log(),*) 'Transfering num_levdecomp = ',ival,' to FATES' diff --git a/components/clm/src/ED/main/FatesParameterDerivedMod.F90 b/components/clm/src/ED/main/FatesParameterDerivedMod.F90 new file mode 100644 index 0000000000..41641d754e --- /dev/null +++ b/components/clm/src/ED/main/FatesParameterDerivedMod.F90 @@ -0,0 +1,116 @@ +module FatesParameterDerivedMod + + ! ------------------------------------------------------------------------------------- + ! This module contains all procedures types and settings for any quantities that are + ! statically derived from static model parameters. These are unchanging quantities + ! and are based off of simple relationships from parameters that the user can + ! vary. This should be called once, and early in the model initialization call + ! sequence immediately after FATES parameters are read in. + ! ------------------------------------------------------------------------------------- + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + + type param_derived_type + + real(r8), allocatable :: vcmax25top(:) ! canopy top: maximum rate of carboxylation + ! at 25C (umol CO2/m**2/s) + real(r8), allocatable :: jmax25top(:) ! canopy top: maximum electron transport + ! rate at 25C (umol electrons/m**2/s) + real(r8), allocatable :: tpu25top(:) ! canopy top: triose phosphate utilization + ! rate at 25C (umol CO2/m**2/s) + real(r8), allocatable :: kp25top(:) ! canopy top: initial slope of CO2 response + ! curve (C4 plants) at 25C + real(r8), allocatable :: lmr25top(:) ! canopy top: leaf maintenance respiration + ! rate at 25C (umol CO2/m**2/s) + contains + + procedure :: Init + procedure :: InitAllocate + + end type param_derived_type + + type(param_derived_type) :: param_derived + +contains + + subroutine InitAllocate(this,maxpft) + + class(param_derived_type), intent(inout) :: this + integer, intent(in) :: maxpft + + allocate(this%vcmax25top(maxpft)) + allocate(this%jmax25top(maxpft)) + allocate(this%tpu25top(maxpft)) + allocate(this%kp25top(maxpft)) + allocate(this%lmr25top(maxpft)) + + return + end subroutine InitAllocate + + ! ===================================================================================== + + subroutine Init(this,maxpft) + + use pftconMod , only: pftcon + + class(param_derived_type), intent(inout) :: this + integer, intent(in) :: maxpft + + ! local variables + integer :: ft ! pft index + real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) + + associate( & + slatop => pftcon%slatop , & ! specific leaf area at top of canopy, + ! projected area basis [m^2/gC] + fnitr => pftcon%fnitr , & ! foliage nitrogen limitation factor (-) + leafcn => pftcon%leafcn ) ! leaf C:N (gC/gN) + + call this%InitAllocate(maxpft) + + do ft = 1,maxpft + + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + lnc = 1._r8 / (slatop(ft) * leafcn(ft)) + + ! at the moment in ED we assume that there is no active N cycle. + ! This should change, of course. FIX(RF,032414) Sep2011. + ! fudge - shortcut using fnitr as a proxy for vcmax... + this%vcmax25top(ft) = fnitr(ft) + + ! Parameters derived from vcmax25top. + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! used jmax25 = 1.97 vcmax25, from Wullschleger (1993) Journal of + ! Experimental Botany 44:907-920. Here use a factor "1.67", from + ! Medlyn et al (2002) Plant, Cell and Environment 25:1167-1179 + + ! RF - copied this from the CLM trunk code, but where did it come from, + ! and how can we make these consistant? + ! jmax25top(ft) = & + ! (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrzc),11._r8),35._r8)) * vcmax25top(ft) + + this%jmax25top(ft) = 1.67_r8 * this%vcmax25top(ft) + this%tpu25top(ft) = 0.167_r8 * this%vcmax25top(ft) + this%kp25top(ft) = 20000._r8 * this%vcmax25top(ft) + + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + ! + ! + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s + ! + ! Then scale this value at the top of the canopy for canopy depth + + this%lmr25top(ft) = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + this%lmr25top(ft) = this%lmr25top(ft) * lnc / (umolC_to_kgC * g_per_kg) + + end do !ft + end associate + return + end subroutine Init + + +end module FatesParameterDerivedMod diff --git a/components/clm/src/biogeophys/PhotosynthesisMod.F90 b/components/clm/src/biogeophys/PhotosynthesisMod.F90 index 9eec7baf1a..e95cc17b39 100644 --- a/components/clm/src/biogeophys/PhotosynthesisMod.F90 +++ b/components/clm/src/biogeophys/PhotosynthesisMod.F90 @@ -162,10 +162,6 @@ module PhotosynthesisMod real(r8), pointer, public :: rssun_patch (:) ! patch sunlit stomatal resistance (s/m) real(r8), pointer, public :: rssha_patch (:) ! patch shaded stomatal resistance (s/m) - ! ED specific variables -! real(r8), pointer, public :: psncanopy_patch (:) ! patch sunlit leaf photosynthesis (umol CO2 /m**2/ s) (ED specific) -! real(r8), pointer, public :: lmrcanopy_patch (:) ! sunlit leaf maintenance respiration rate (umol CO2/m**2/s) (ED specific) - ! LUNA specific variables real(r8), pointer, public :: vcmx25_z_patch (:,:) ! patch leaf Vc,max25 (umol CO2/m**2/s) for canopy layer real(r8), pointer, public :: jmx25_z_patch (:,:) ! patch leaf Jmax25 (umol electron/m**2/s) for canopy layer diff --git a/components/clm/src/main/clm_initializeMod.F90 b/components/clm/src/main/clm_initializeMod.F90 index 92290cae27..1c54d2596b 100644 --- a/components/clm/src/main/clm_initializeMod.F90 +++ b/components/clm/src/main/clm_initializeMod.F90 @@ -647,7 +647,7 @@ subroutine initialize2( ) ! Initialise the ED model state structure ! -------------------------------------------------------------- - if ( use_ed .and. .not.is_restart() ) then + if ( use_ed .and. .not.is_restart() .and. finidat == ' ') then call clm_fates%init_coldstart(waterstate_inst,canopystate_inst) diff --git a/components/clm/src/main/histFileMod.F90 b/components/clm/src/main/histFileMod.F90 index e1d6b56352..d4b7f1e679 100644 --- a/components/clm/src/main/histFileMod.F90 +++ b/components/clm/src/main/histFileMod.F90 @@ -21,7 +21,8 @@ module histFileMod use ColumnType , only : col use PatchType , only : patch use ncdio_pio - use EDtypesMod , only : nlevsclass_ed + use EDtypesMod , only : nlevsclass_ed, nlevage_ed + use clm_varpar , only : mxpft ! implicit none save @@ -1849,6 +1850,8 @@ subroutine htape_create (t, histrest) if(use_ed)then call ncd_defdim(lnfid, 'levscls', nlevsclass_ed, dimid) + call ncd_defdim(lnfid, 'levpft', mxpft, dimid) + call ncd_defdim(lnfid, 'levage', nlevage_ed, dimid) call ncd_defdim(lnfid, 'levscpf', nlevsclass_ed*mxpft, dimid) end if @@ -2265,6 +2268,7 @@ subroutine htape_timeconst(t, mode) use clm_time_manager, only : get_nstep, get_curr_date, get_curr_time use clm_time_manager, only : get_ref_date, get_calendar, NO_LEAP_C, GREGORIAN_C use EDTypesMod, only : levsclass_ed, pft_levscpf_ed, scls_levscpf_ed + use EDTypesMod, only : levage_ed, levpft_ed ! ! !ARGUMENTS: integer, intent(in) :: t ! tape index @@ -2317,11 +2321,15 @@ subroutine htape_timeconst(t, mode) if(use_ed)then call ncd_defvar(varname='levscls', xtype=tape(t)%ncprec, dim1name='levscls', & - long_name='diameter size class lower bound', units='cm', ncid=nfid(t)) + long_name='FATES diameter size class lower bound', units='cm', ncid=nfid(t)) call ncd_defvar(varname='pft_levscpf',xtype=ncd_int, dim1name='levscpf', & - long_name='pft index of the combined pft-size class dimension', units='-', ncid=nfid(t)) + long_name='FATES pft index of the combined pft-size class dimension', units='-', ncid=nfid(t)) call ncd_defvar(varname='scls_levscpf',xtype=ncd_int, dim1name='levscpf', & - long_name='size index of the combined pft-size class dimension', units='-', ncid=nfid(t)) + long_name='FATES size index of the combined pft-size class dimension', units='-', ncid=nfid(t)) + call ncd_defvar(varname='levage',xtype=tape(t)%ncprec, dim1name='levage', & + long_name='FATES patch age (yr)', ncid=nfid(t)) + call ncd_defvar(varname='levpft',xtype=ncd_int, dim1name='levpft', & + long_name='FATES pft number', ncid=nfid(t)) end if elseif (mode == 'write') then @@ -2338,6 +2346,8 @@ subroutine htape_timeconst(t, mode) call ncd_io(varname='levscls',data=levsclass_ed, ncid=nfid(t), flag='write') call ncd_io(varname='pft_levscpf',data=pft_levscpf_ed, ncid=nfid(t), flag='write') call ncd_io(varname='scls_levscpf',data=scls_levscpf_ed, ncid=nfid(t), flag='write') + call ncd_io(varname='levage',data=levage_ed, ncid=nfid(t), flag='write') + call ncd_io(varname='levpft',data=levpft_ed, ncid=nfid(t), flag='write') end if endif @@ -4439,6 +4449,10 @@ subroutine hist_addfld2d (fname, type2d, units, avgflag, long_name, type1d_out, num2d = nlevdecomp_full case ('levscls') num2d = nlevsclass_ed + case ('levpft') + num2d = mxpft + case ('levage') + num2d = nlevage_ed case ('levscpf') num2d = nlevsclass_ed*mxpft case('ltype') diff --git a/components/clm/src/utils/clmfates_interfaceMod.F90 b/components/clm/src/utils/clmfates_interfaceMod.F90 index bd124668bc..b31dd572ad 100644 --- a/components/clm/src/utils/clmfates_interfaceMod.F90 +++ b/components/clm/src/utils/clmfates_interfaceMod.F90 @@ -40,7 +40,6 @@ module CLMFatesInterfaceMod use TemperatureType , only : temperature_type use EnergyFluxType , only : energyflux_type use SoilStateType , only : soilstate_type - use PhotosynthesisMod , only : photosyns_type use clm_varctl , only : iulog, use_ed use clm_varcon , only : tfrz use clm_varcon , only : spval @@ -50,6 +49,7 @@ module CLMFatesInterfaceMod nlevsoi, & nlevdecomp, & nlevdecomp_full + use PhotosynthesisMod , only : photosyns_type use atm2lndType , only : atm2lnd_type use SurfaceAlbedoType , only : surfalb_type use SolarAbsorbedType , only : solarabs_type @@ -82,11 +82,12 @@ module CLMFatesInterfaceMod allocate_bcin, & allocate_bcout + use FatesGlobals , only : SetFatesTime + 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 : udata use EDTypesMod , only : ed_patch_type use EDtypesMod , only : cp_numlevgrnd use EDMainMod , only : ed_ecosystem_dynamics @@ -100,7 +101,7 @@ module CLMFatesInterfaceMod use EDBtranMod , only : btran_ed, & get_active_suction_layers use EDCanopyStructureMod , only : canopy_summarization, update_hlm_dynamics - use EDPhotosynthesisMod , only : Photosynthesis_ED + use FatesPlantRespPhotosynthMod, only : FatesPlantRespPhotosynthDrive use EDAccumulateFluxesMod , only : AccumulateFluxes_ED use EDPhysiologyMod , only : flux_into_litter_pools @@ -157,7 +158,6 @@ module CLMFatesInterfaceMod procedure, public :: wrap_accumulatefluxes procedure, public :: prep_canopyfluxes procedure, public :: wrap_canopy_radiation - procedure, private :: wrap_litter_fluxout procedure, public :: wrap_bgc_summary procedure, private :: init_history_io procedure, private :: wrap_update_hlmfates_dyn @@ -191,8 +191,9 @@ subroutine init(this, bounds_proc, use_ed) ! is not turned on ! --------------------------------------------------------------------------------- - use FatesInterfaceMod, only : FatesInterfaceInit - + use FatesInterfaceMod, only : FatesInterfaceInit + use EDTypesMod , only : numpft_ed + use FatesParameterDerivedMod, only : param_derived implicit none @@ -207,6 +208,7 @@ subroutine init(this, bounds_proc, use_ed) ! local variables integer :: nclumps ! Number of threads logical :: verbose_output + integer :: pass_masterproc if (use_ed) then @@ -214,10 +216,9 @@ subroutine init(this, bounds_proc, use_ed) ! This involves to stages ! 1) allocate the vectors ! 2) add the history variables defined in clm_inst to the history machinery -! call this%fates2hlm%Init(bounds_proc) - call EDecophysconInit( EDpftvarcon_inst, numpft ) - + call param_derived%Init(numpft_ed) + end if if(DEBUG)then @@ -248,6 +249,12 @@ subroutine init(this, bounds_proc, use_ed) call set_fates_ctrlparms('num_levdecomp_full',ival=nlevdecomp_full) call set_fates_ctrlparms('hlm_name',cval='CLM') call set_fates_ctrlparms('hio_ignore_val',rval=spval) + if(masterproc)then + pass_masterproc = 1 + else + pass_masterproc = 0 + end if + call set_fates_ctrlparms('masterproc',ival=pass_masterproc) ! Check through FATES parameters to see if all have been set call set_fates_ctrlparms('check_allset') @@ -448,65 +455,122 @@ subroutine dynamics_driv(this, nc, bounds_clump, & type(soilbiogeochem_carbonflux_type), intent(inout) :: soilbiogeochem_carbonflux_inst ! !LOCAL VARIABLES: - real(r8) :: dayDiff ! day of run - integer :: dayDiffInt ! integer of day of run - integer :: s ! site + integer :: s ! site index + integer :: c ! column index (HLM) + integer :: ifp ! patch index + integer :: p ! HLM patch index integer :: yr ! year (0, ...) integer :: mon ! month (1, ..., 12) integer :: day ! day of month (1, ..., 31) integer :: sec ! seconds of the day - integer :: ncdate ! current date - integer :: nbdate ! base date (reference date) + integer :: current_year + integer :: current_month + integer :: current_day + integer :: current_tod + integer :: current_date + integer :: jan01_curr_year + integer :: reference_date + integer :: days_per_year + real(r8) :: model_day + real(r8) :: day_of_year !----------------------------------------------------------------------- - ! --------------------------------------------------------------------------------- - ! INTERF-TODO: REMOVE ED_DRIVER ARGUMENTS OF CLM STUCTURED TYPES AND - ! REPLACE THEM WITH FATES_BC TYPES WITH ITS OWN MAPPING SCHEME - ! ALSO, NOTE THAT THE ED_DYNAMICS IS A MODULE OF FATES NOW - ! ie: - ! fates(nc)%fatesbc%leaf_temp <=> canopystate_inst% - ! - ! call this%fates(nc)%ed_driver(this%fates(nc)%site, & - ! this%fates(nc)%fatesbc) + ! Part I. + ! Prepare input boundary conditions for FATES dynamics + ! Note that timing information is the same across all sites, this may + ! seem redundant, but it is possible that we may have asynchronous site simulations + ! one day. The cost of holding site level boundary conditions is minimal + ! and it keeps all the boundaries in one location ! --------------------------------------------------------------------------------- - - ! timing statements. - udata%n_sub = get_days_per_year() - udata%deltat = 1.0_r8/dble(udata%n_sub) !for working out age of patches in years - if(udata%time_period == 0)then - udata%time_period = udata%n_sub - endif - - call get_curr_date(yr, mon, day, sec) - ncdate = yr*10000 + mon*100 + day + + days_per_year = get_days_per_year() + call get_curr_date(current_year,current_month,current_day,current_tod) + current_date = current_year*10000 + current_month*100 + current_day + jan01_curr_year = current_year*10000 + 100 + 1 + call get_ref_date(yr, mon, day, sec) - nbdate = yr*10000 + mon*100 + day - - call timemgr_datediff(nbdate, 0, ncdate, sec, dayDiff) - - dayDiffInt = floor(dayDiff) - udata%time_period = mod( dayDiffInt , udata%n_sub ) + reference_date = yr*10000 + mon*100 + day + + call timemgr_datediff(reference_date, sec, current_date, current_tod, model_day) + + call timemgr_datediff(jan01_curr_year,0,current_date,sec,day_of_year) + call SetFatesTime(current_year, current_month, & + current_day, current_tod, & + current_date, reference_date, & + model_day, floor(day_of_year), & + days_per_year, 1.0_r8/dble(days_per_year)) - ! TODO-INTEF: PROCEDURE FOR CONVERTING CLM/ALM FIELDS TO MODEL BOUNDARY - ! CONDITIONS. IE. + do s=1,this%fates(nc)%nsites + c = this%f2hmap(nc)%fcolumn(s) + this%fates(nc)%bc_in(s)%h2osoi_vol_si = & + waterstate_inst%h2osoi_vol_col(c,1) + + this%fates(nc)%bc_in(s)%t_veg24_si = & + temperature_inst%t_veg24_patch(col%patchi(c)) + + this%fates(nc)%bc_in(s)%max_rooting_depth_index_col = canopystate_inst%altmax_lastyear_indx_col(c) + + do ifp = 1, this%fates(nc)%sites(s)%youngest_patch%patchno + p = ifp+col%patchi(c) + this%fates(nc)%bc_in(s)%t_veg24_pa(ifp) = & + temperature_inst%t_veg24_patch(p) + + this%fates(nc)%bc_in(s)%precip24_pa(ifp) = & + atm2lnd_inst%prec24_patch(p) + + this%fates(nc)%bc_in(s)%relhumid24_pa(ifp) = & + atm2lnd_inst%rh24_patch(p) + + this%fates(nc)%bc_in(s)%wind24_pa(ifp) = & + atm2lnd_inst%wind24_patch(p) + + end do + end do + + ! --------------------------------------------------------------------------------- + ! Part II: Call the FATES model now that input boundary conditions have been + ! provided. + ! --------------------------------------------------------------------------------- - ! where most things happen do s = 1,this%fates(nc)%nsites call ed_ecosystem_dynamics(this%fates(nc)%sites(s), & - atm2lnd_inst, & - soilstate_inst, temperature_inst, waterstate_inst) + this%fates(nc)%bc_in(s)) + + call ed_update_site(this%fates(nc)%sites(s), & + this%fates(nc)%bc_in(s)) - call ed_update_site(this%fates(nc)%sites(s)) - enddo + + ! call subroutine to aggregate ED litter output fluxes and + ! package them for handing across interface + call flux_into_litter_pools(this%fates(nc)%nsites, & + this%fates(nc)%sites, & + this%fates(nc)%bc_in, & + this%fates(nc)%bc_out) + + + ! --------------------------------------------------------------------------------- + ! Part III: Process FATES output into the dimensions and structures that are part + ! of the HLMs API. (column, depth, and litter fractions) + ! --------------------------------------------------------------------------------- + + do s = 1, this%fates(nc)%nsites + c = this%f2hmap(nc)%fcolumn(s) + soilbiogeochem_carbonflux_inst%FATES_c_to_litr_lab_c_col(c,:) = & + this%fates(nc)%bc_out(s)%FATES_c_to_litr_lab_c_col(:) + soilbiogeochem_carbonflux_inst%FATES_c_to_litr_cel_c_col(c,:) = & + this%fates(nc)%bc_out(s)%FATES_c_to_litr_cel_c_col(:) + soilbiogeochem_carbonflux_inst%FATES_c_to_litr_lig_c_col(c,:) = & + this%fates(nc)%bc_out(s)%FATES_c_to_litr_lig_c_col(:) + end do - call this%wrap_litter_fluxout(nc, bounds_clump, canopystate_inst, soilbiogeochem_carbonflux_inst) ! --------------------------------------------------------------------------------- + ! Part III.2 (continued). ! Update diagnostics of the FATES ecosystem structure that are used in the HLM. ! --------------------------------------------------------------------------------- call this%wrap_update_hlmfates_dyn(nc, & @@ -515,6 +579,7 @@ subroutine dynamics_driv(this, nc, bounds_clump, & canopystate_inst) ! --------------------------------------------------------------------------------- + ! Part IV: ! Update history IO fields that depend on ecosystem dynamics ! --------------------------------------------------------------------------------- call this%fates_hist%update_history_dyn( nc, & @@ -523,7 +588,7 @@ subroutine dynamics_driv(this, nc, bounds_clump, & if (masterproc) then write(iulog, *) 'clm: leaving ED model', bounds_clump%begg, & - bounds_clump%endg, dayDiffInt + bounds_clump%endg end if @@ -873,7 +938,8 @@ subroutine restart( this, bounds_proc, ncid, flag, waterstate_inst, canopystate_ ! I think ed_update_site and update_hlmfates_dyn are doing some similar ! update type stuff, should consolidate (rgk 11-2016) do s = 1,this%fates(nc)%nsites - call ed_update_site( this%fates(nc)%sites(s) ) + call ed_update_site( this%fates(nc)%sites(s), & + this%fates(nc)%bc_in(s) ) end do ! ------------------------------------------------------------------------ @@ -935,7 +1001,8 @@ subroutine init_coldstart(this, waterstate_inst, canopystate_inst) call init_patches(this%fates(nc)%nsites, this%fates(nc)%sites) do s = 1,this%fates(nc)%nsites - call ed_update_site(this%fates(nc)%sites(s)) + call ed_update_site(this%fates(nc)%sites(s), & + this%fates(nc)%bc_in(s)) end do @@ -1340,11 +1407,11 @@ subroutine wrap_photosynthesis(this, nc, bounds, fn, filterp, & ! Call photosynthesis - call Photosynthesis_ED (this%fates(nc)%nsites, & - this%fates(nc)%sites, & - this%fates(nc)%bc_in, & - this%fates(nc)%bc_out, & - dtime) + call FatesPlantRespPhotosynthDrive (this%fates(nc)%nsites, & + this%fates(nc)%sites, & + this%fates(nc)%bc_in, & + this%fates(nc)%bc_out, & + dtime) ! Perform a double check to see if all patches on naturally vegetated columns ! were activated for photosynthesis @@ -1501,46 +1568,6 @@ subroutine wrap_canopy_radiation(this, bounds_clump, nc, & end subroutine wrap_canopy_radiation - ! ====================================================================================== - - subroutine wrap_litter_fluxout(this, nc, bounds_clump, canopystate_inst, soilbiogeochem_carbonflux_inst) - - implicit none - - ! Arguments - class(hlm_fates_interface_type), intent(inout) :: this - integer , intent(in) :: nc - type(bounds_type),intent(in) :: bounds_clump - type(canopystate_type) , intent(inout) :: canopystate_inst - type(soilbiogeochem_carbonflux_type), intent(inout) :: soilbiogeochem_carbonflux_inst - - ! local variables - integer :: s, c - - - ! process needed input boundary conditions to define rooting profiles - ! call subroutine to aggregate ED litter output fluxes and package them for handing across interface - ! process output into the dimensions that the BGC model wants (column, depth, and litter fractions) - - do s = 1, this%fates(nc)%nsites - c = this%f2hmap(nc)%fcolumn(s) - this%fates(nc)%bc_in(s)%max_rooting_depth_index_col = canopystate_inst%altmax_lastyear_indx_col(c) - end do - - call flux_into_litter_pools(this%fates(nc)%nsites, & - this%fates(nc)%sites, & - this%fates(nc)%bc_in, & - this%fates(nc)%bc_out) - - do s = 1, this%fates(nc)%nsites - c = this%f2hmap(nc)%fcolumn(s) - soilbiogeochem_carbonflux_inst%FATES_c_to_litr_lab_c_col(c,:) = this%fates(nc)%bc_out(s)%FATES_c_to_litr_lab_c_col(:) - soilbiogeochem_carbonflux_inst%FATES_c_to_litr_cel_c_col(c,:) = this%fates(nc)%bc_out(s)%FATES_c_to_litr_cel_c_col(:) - soilbiogeochem_carbonflux_inst%FATES_c_to_litr_lig_c_col(c,:) = this%fates(nc)%bc_out(s)%FATES_c_to_litr_lig_c_col(:) - end do - - end subroutine wrap_litter_fluxout - ! ====================================================================================== subroutine wrap_bgc_summary(this, nc, soilbiogeochem_carbonflux_inst, & @@ -1608,6 +1635,7 @@ subroutine init_history_io(this,bounds_proc) use FatesConstantsMod, only : fates_short_string_length, fates_long_string_length use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIODimensionsMod, only : fates_bounds_type @@ -1769,6 +1797,33 @@ subroutine init_history_io(this,bounds_proc) ptr_col=this%fates_hist%hvars(ivar)%r82d, & default=trim(vdefault), & set_lake=0._r8,set_urb=0._r8) + case(site_size_r8) + d_index = this%fates_hist%dim_kinds(dk_index)%dim2_index + dim2name = this%fates_hist%dim_bounds(d_index)%name + call hist_addfld2d(fname=trim(vname),units=trim(vunits), & + type2d=trim(dim2name), & + avgflag=trim(vavgflag),long_name=trim(vlong), & + ptr_col=this%fates_hist%hvars(ivar)%r82d, & + default=trim(vdefault), & + set_lake=0._r8,set_urb=0._r8) + case(site_pft_r8) + d_index = this%fates_hist%dim_kinds(dk_index)%dim2_index + dim2name = this%fates_hist%dim_bounds(d_index)%name + call hist_addfld2d(fname=trim(vname),units=trim(vunits), & + type2d=trim(dim2name), & + avgflag=trim(vavgflag),long_name=trim(vlong), & + ptr_col=this%fates_hist%hvars(ivar)%r82d, & + default=trim(vdefault), & + set_lake=0._r8,set_urb=0._r8) + case(site_age_r8) + d_index = this%fates_hist%dim_kinds(dk_index)%dim2_index + dim2name = this%fates_hist%dim_bounds(d_index)%name + call hist_addfld2d(fname=trim(vname),units=trim(vunits), & + type2d=trim(dim2name), & + avgflag=trim(vavgflag),long_name=trim(vlong), & + ptr_col=this%fates_hist%hvars(ivar)%r82d, & + default=trim(vdefault), & + set_lake=0._r8,set_urb=0._r8) case default write(iulog,*) 'A FATES iotype was created that was not registerred' @@ -1783,7 +1838,7 @@ end subroutine init_history_io subroutine hlm_bounds_to_fates_bounds(hlm, fates) use FatesIODimensionsMod, only : fates_bounds_type - use EDtypesMod, only : nlevsclass_ed + use EDtypesMod, only : nlevsclass_ed, nlevage_ed use clm_varpar, only : mxpft, nlevgrnd implicit none @@ -1803,8 +1858,17 @@ subroutine hlm_bounds_to_fates_bounds(hlm, fates) fates%ground_begin = 1 fates%ground_end = nlevgrnd + fates%sizepft_class_begin = 1 + fates%sizepft_class_end = nlevsclass_ed * mxpft + + fates%size_class_begin = 1 + fates%size_class_end = nlevsclass_ed + fates%pft_class_begin = 1 - fates%pft_class_end = nlevsclass_ed * mxpft + fates%pft_class_end = mxpft + + fates%age_class_begin = 1 + fates%age_class_end = nlevage_ed end subroutine hlm_bounds_to_fates_bounds